diff --git a/LICENSE b/LICENSE
--- a/LICENSE
+++ b/LICENSE
@@ -1,26 +1,35 @@
+Copyright (c) 2008-2010 Jesse A. Tov
+
+All rights reserved.
+
Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions
-are met:
+modification, are permitted (subject to the limitations in the
+disclaimer below) provided that the following conditions are met:
-Redistributions of source code must retain the above copyright
-notice, this list of conditions and the following disclaimer.
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
-Redistributions in binary form must reproduce the above copyright
-notice, this list of conditions and the following disclaimer in the
-documentation and/or other materials provided with the distribution.
+ * Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the
+ distribution.
-Neither the name of Northeastern University; nor the names of its
-contributors may be used to endorse or promote products derived from
-this software without specific prior written permission.
+ * Neither the name of the author, nor the name of Northeastern
+ University, nor the names of its contributors may be used to
+ endorse or promote products derived from this software without
+ specific prior written permission.
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
-IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
-TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
-PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
-TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
-PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
-LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
-NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+NO EXPRESS OR IMPLIED LICENSES TO ANY PARTY'S PATENT RIGHTS ARE
+GRANTED BY THIS LICENSE. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT
+HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED
+WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
+IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
diff --git a/Makefile b/Makefile
--- a/Makefile
+++ b/Makefile
@@ -3,7 +3,7 @@
EXAMPLES = examples
SRC = $(HS_SRC) $(HSBOOT_SRC)
HS_SRC = src/*.hs src/Basis/*.hs src/Basis/Channel/*.hs \
- src/Syntax/*.hs src/Meta/*.hs
+ src/Syntax/*.hs src/Message/*.hs src/Meta/*.hs
HSBOOT_SRC = src/Syntax/*.hs-boot
DOC = dist/doc/html/alms/alms/
@@ -50,7 +50,7 @@
$(RM) html
-VERSION = 0.4.9.1
+VERSION = 0.4.10
DISTDIR = alms-$(VERSION)
TARBALL = $(DISTDIR).tar.gz
diff --git a/README b/README
--- a/README
+++ b/README
@@ -14,8 +14,8 @@
GETTING STARTED
- We require GHC to build. It is known to work with GHC 6.10.4,
- and likely no longer works with GHC 6.8.
+ Alms requires GHC to build. It is known to work with GHC 6.12.1 and
+ 6.10.4, and likely no longer works with GHC 6.8.
Provided that a recent ghc is in your path, to build on UNIX it ought
to be be sufficient to type:
@@ -72,9 +72,9 @@
from another terminal.
- The examples directory contains many more examples, many of which
- are small, but demonstrate type or or contract errors -- the comment at
- the top of each example says what to expect. Run many of the examples
+ The examples directory contains many more examples, many of which are
+ small, but demonstrate type or contract errors -- the comment at the
+ top of each example says what to expect. Run many of the examples
with:
% make examples
diff --git a/TODO b/TODO
--- a/TODO
+++ b/TODO
@@ -1,5 +1,3 @@
- - find a more systematic way to generate and print errors
- - modify the lexer to get more precise source locations
- some termination checking for type operators
- remove direct dependency of Parser on Sigma (! patterns)
- row types for protocols
diff --git a/alms.cabal b/alms.cabal
--- a/alms.cabal
+++ b/alms.cabal
@@ -1,5 +1,5 @@
Name: alms
-Version: 0.4.9.1
+Version: 0.4.10
Copyright: 2010, Jesse A. Tov
Cabal-Version: >= 1.8
License: BSD3
@@ -16,11 +16,11 @@
README Makefile
Description:
- Alms is a general-purpose programming language that supports practical
- affine types. To offer the expressiveness of Girard’s linear logic while
- keeping the type system light and convenient, Alms uses expressive kinds
- that minimize notation while maximizing polymorphism between affine and
- unlimited types.
+ 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
@@ -71,9 +71,14 @@
Coercion,
Dynamics,
Env,
+ ErrorMessage,
ErrorST,
Lexer,
Loc,
+ Message.AST,
+ Message.Parser,
+ Message.Quasi,
+ Message.Render,
Meta.DeriveNotable,
Meta.FileString,
Meta.Quasi,
@@ -83,6 +88,7 @@
Parser,
Paths,
Ppr,
+ PprClass,
Prec,
Rename,
Sigma,
@@ -99,6 +105,7 @@
Syntax.Patt,
Syntax.SyntaxTable,
Syntax.Type,
+ Token,
Type,
TypeRel,
Util,
diff --git a/examples/ex60-popl-deposit.alms b/examples/ex60-popl-deposit.alms
--- a/examples/ex60-popl-deposit.alms
+++ b/examples/ex60-popl-deposit.alms
@@ -12,9 +12,9 @@
* but for the sake of example: *)
module type LOCK = sig
type lock
- val new : unit -> lock
- val acquire : lock -> unit
- val release : lock -> unit
+ val new : unit → lock
+ val acquire : lock → unit
+ val release : lock → unit
end
module Lock : LOCK = struct
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
@@ -3,11 +3,11 @@
module type AF_ARRAY = sig
type 'a array : A
- val new : int -> 'a -> 'a array
- val set : 'a array -> int -o 'a -o 'a array
- val get : 'a array -> int -o 'a * 'a array
+ val new : int → 'a → 'a array
+ val set : 'a array → int ⊸ 'a ⊸ 'a array
+ val get : 'a array → int ⊸ 'a * 'a array
- val size : 'a array -> int * 'a array
+ val size : 'a array → int * 'a array
end
#load "libarray"
@@ -62,7 +62,7 @@
: int * int A.array =
if i < limit
then let (ai, a) = A.get a i in
- if ai <= pivot
+ if ai ≤ pivot
then loop (i + 1) (j + 1) (swapIndices a i j)
else loop (i + 1) j a
else (j, a) in
@@ -79,8 +79,8 @@
let n = length xs + 1 in
let rec loop (i: int) (xs: 'a list) (a: 'a A.array) : 'a A.array =
match xs with
- | Nil -> a
- | Cons(x,xs) -> loop (i + 1) xs (A.set a i x)
+ | Nil → a
+ | Cons(x,xs) → loop (i + 1) xs (A.set a i x)
in loop 1 xs (A.new n x)
let arrayToList (a: 'a A.array) =
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
@@ -4,12 +4,12 @@
type ('a,'b) array
type 'b cap : A
- val new : int -> 'a -> ex 'b. ('a,'b) array * 'b cap
- val set : ('a,'b) array -> int -> 'a -> 'b cap -> 'b cap
- val get : ('a,'b) array -> int -> 'b cap -> 'a * 'b cap
+ val new : int → 'a → ∃'b. ('a,'b) array * 'b cap
+ val set : ('a,'b) array → int → 'a → 'b cap → 'b cap
+ val get : ('a,'b) array → int → 'b cap → 'a * 'b cap
- val dirtyGet : ('a,'b) array -> int -> 'a
- val size : ('a,'b) array -> int
+ val dirtyGet : ('a,'b) array → int → 'a
+ val size : ('a,'b) array → int
end
#load "libarray"
@@ -59,8 +59,8 @@
in loop (A.size a - 1) 0
let shuffleAndDirtySum (a: (int,'b) A.array) (cap: 'b A.cap) =
- let f1 = Future.new (fun _ -> inPlaceShuffle a cap) in
- let f2 = Future.new (fun _ -> dirtySumArray a) in
+ let f1 = Future.new (λ _ → inPlaceShuffle a cap) in
+ let f2 = Future.new (λ _ → dirtySumArray a) in
(Future.sync f1, Future.sync f2)
(* For testing: *)
@@ -69,8 +69,8 @@
let ('b, a, cap) = A.new n x in
let rec loop (i: int) (xs: 'a list) (cap: 'b A.cap) : 'b A.cap =
match xs with
- | Nil -> cap
- | Cons(x,xs) -> loop (i + 1) xs (A.set a i x cap)
+ | Nil → cap
+ | Cons(x,xs) → loop (i + 1) xs (A.set a i x cap)
in Pack('b, a, loop 1 xs cap)
let dirtyArrayToList (a: ('a,'b) A.array) =
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
@@ -7,15 +7,15 @@
(* Already inherited new from CAP_ARRAY, so we need to use a
* different name here: *)
- val new' : int -> 'a -> ex 'b. ('a,'b) array
- val acquire : ('a, 'b) array -> 'b cap
- val release : ('a, 'b) array -> 'b cap -> unit
+ val new' : int → 'a → ∃'b. ('a,'b) array
+ val acquire : ('a, 'b) array → 'b cap
+ val release : ('a, 'b) array → 'b cap → unit
end
module CapLockArray : CAP_LOCK_ARRAY = struct
open CapArray
- type ('a,'b) array = ('a,'b) CapArray.array * 'b cap MVar.mvar
+ 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
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
@@ -7,15 +7,15 @@
type 'c / 'd
type ('b,'c) cap : A
- val new : int -> 'a ->
- ex 'b. ('a,'b) array * ('b,1) cap
- val get : ('a,'b) array -> int ->
- ('b,'c) cap -> 'a * ('b,'c) cap
- val set : ('a,'b) array -> int -> 'a ->
- ('b,1) cap -> ('b,1) cap
+ val new : int → 'a →
+ ∃'b. ('a,'b) array × ('b,1) cap
+ val get : ('a,'b) array → int →
+ ('b,'c) cap → 'a × ('b,'c) cap
+ val set : ('a,'b) array → int → 'a →
+ ('b,1) cap → ('b,1) cap
- val split : ('b,'c) cap -> ('b,'c/2) cap * ('b,'c/2) cap
- val join : ('b,'c/2) cap * ('b,'c/2) cap -> ('b,'c) cap
+ val split : ('b,'c) cap → ('b,'c/2) cap × ('b,'c/2) cap
+ val join : ('b,'c/2) cap × ('b,'c/2) cap → ('b,'c) cap
end
#load "libarray"
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
@@ -1,23 +1,23 @@
(* Example: reader-writer locks with capabilities *)
module type RW_LOCK = sig
- type ('a,'b) array
+ type ('α,'β) array
type read
type write
- type 'b@'c : A
+ type 'β@'γ : A
- val new : int -> 'a -> ex 'b. ('a, 'b) array
+ val new : int → 'α → ∃'β. ('α, 'β) array
(* build is more convenient than new, but it would take more space
* in the paper. *)
- val build : int -> (int -> 'a) -> ex 'b. ('a, 'b) array
+ val build : int → (int → 'α) → ∃'β. ('α, 'β) array
- val acquireR : ('a,'b) array -> 'b@read
- val acquireW : ('a,'b) array -> 'b@write
- val release : ('a,'b) array -> 'b@'c -> unit * unit
+ val acquireR : ('α,'β) array → 'β@read
+ val acquireW : ('α,'β) array → 'β@write
+ val release : ('α,'β) array → 'β@'γ → unit × unit
- val get : ('a,'b) array -> int -> 'b@'c -> 'a * 'b@'c
- val set : ('a,'b) array -> int -> 'a -> 'b@write -> unit * 'b@write
- (* We added (unit * _) to result types of release and get to support
+ val get : ('α,'β) array → int → 'β@'γ → 'α × 'β@'γ
+ val set : ('α,'β) array → int → 'α → 'β@write → unit × 'β@write
+ (* We added (unit × _) to result types of release and get to support
* the imperative variable notation. *)
end
@@ -37,29 +37,29 @@
* an integer, which tells us what capabilites are outstanding:
* - -1 for read-write
* - 0 for nothing outstanding
- * - N >= 0 for N readers
+ * - N ≥ 0 for N readers
*)
- type lock = (queue * int) MVar.mvar
- type ('a,'t) array = 'a A.array * lock
+ type lock = (queue × int) MVar.mvar
+ type ('α,'β) array = 'α A.array × lock
type read
type write
- type 't@'m = unit
+ type 'β@'γ = unit
- let new (size: int) (init: 'a) =
+ let new (size: int) (init: 'α) =
(A.new size init, MVar.new ((Queue.empty : queue), 0))
- let build (size: int) (builder: int -> 'a) =
+ let build (size: int) (builder: int → 'α) =
(A.build size builder, MVar.new ((Queue.empty : queue), 0))
(* To see what's happening, uncomment the rest of show. *)
- let show (who: string) ((q, count): queue * int) = ()
+ let show (who: string) ((q, count): queue × int) = ()
(*
;
putStr ("[" ^ who ^ "] count: " ^ string_of_int count ^ " ");
let rec loop (q: queue) : unit =
match Queue.dequeueA q with
- | None -> putStr "\n"
- | Some (Left _, q) -> putStr "R"; loop q
- | Some (Right _, q) -> putStr "W"; loop q
+ | None → putStr "\n"
+ | Some (Left _, q) → putStr "R"; loop q
+ | Some (Right _, q) → putStr "W"; loop q
in loop q;
*)
@@ -75,24 +75,24 @@
let rec wakeReaders (q: queue) (count: int) : unit =
show "wakeReaders" (q, count);
match Queue.dequeueA q with
- | Some (Left reader, q) ->
+ | Some (Left reader, q) →
MVar.put reader ();
wakeReaders q (count + 1)
- | _ -> MVar.put lock (q, count); show "endWR" (q, count) in
+ | _ → MVar.put lock (q, count); show "endWR" (q, count) in
match MVar.take lock with
- | (q, -1) -> MVar.put lock (q, -1)
- | (q, 0) -> (match Queue.dequeueA q with
- | None -> MVar.put lock (q, 0)
- | Some (Right writer, q) ->
+ | (q, -1) → MVar.put lock (q, -1)
+ | (q, 0) → (match Queue.dequeueA q with
+ | None → MVar.put lock (q, 0)
+ | Some (Right writer, q) →
MVar.put writer ();
MVar.put lock (q, -1)
- | _ -> wakeReaders q 0)
- | (q, count) -> wakeReaders q count
+ | _ → wakeReaders q 0)
+ | (q, count) → wakeReaders q count
(* acquireR creates an mvar for the requesting reader to wait on and
* adds it to the tail of the queue. It calls wake to process the
* queue and then waits in the mvar. *)
- let acquireR ((rep, lock) : ('a,'t) array) =
+ let acquireR ((rep, lock) : ('α,'t) array) =
let (q, count) = MVar.take lock in
show "acquireR" (q, count);
let wait = MVar.newEmpty[unit] () in
@@ -101,7 +101,7 @@
MVar.take wait
(* Same idea as acquireR -- could probably refactor. *)
- let acquireW ((rep, lock) : ('a,'t) array) =
+ let acquireW ((rep, lock) : ('α,'β) array) =
let (q, count) = MVar.take lock in
show "acquireW" (q, count);
let wait = MVar.newEmpty[unit] () in
@@ -112,16 +112,16 @@
(* We don't need separate releaseR and releaseW because the count has
* enough information to figure out what kind of release is happening.
* We update the counter and then call wake to process the queue. *)
- let release ((rep, lock) : ('a,'t) array) _ =
+ let release ((rep, lock) : ('α,'β) array) _ =
let (q, count) = MVar.take lock in
show "release" (q, count);
let count' = if count > 1 then count - 1 else 0 in
MVar.put lock (q, count');
(wake lock, ())
- let get ((rep, _) : ('a,'t) array) (ix: int) () =
+ let get ((rep, _) : ('α,'β) array) (ix: int) () =
(A.get rep ix, ())
- let set ((rep, _) : ('a,'t) array) (ix: int) (v: 'a) () =
+ let set ((rep, _) : ('α,'β) array) (ix: int) (v: 'α) () =
(A.set rep ix v, ())
end
@@ -141,16 +141,16 @@
let makeCounter () =
let counter = MVar.new 0 in
- fun () ->
+ fun () →
let count = MVar.take counter in
MVar.put counter (count + 1);
count
let delay () = Thread.delay 250000
- let reader (me: int) (a: (int,'t) array) =
+ let reader (me: int) (a: (int,'β) array) =
Future.new
- (fun () ->
+ (fun () →
putStrLn ("reader " ^ string_of_int me ^ ": waiting");
let !cap = acquireR a in
putStrLn ("reader " ^ string_of_int me ^ ": acquired");
@@ -163,9 +163,9 @@
then failwith "reader: meh"
else ())
- let writer (me: int) (a: (int,'t) array) =
+ let writer (me: int) (a: (int,'β) array) =
Future.new
- (fun () ->
+ (fun () →
putStrLn ("writer " ^ string_of_int me ^ ": waiting");
let !cap = acquireW a in
putStrLn ("writer " ^ string_of_int me ^ ": acquired");
@@ -180,7 +180,7 @@
let go (iters: int) =
let next = makeCounter () in
- let ('t,a) = build 10 (fun x:int -> x) in
+ let ('β,a) = build 10 (fun x:int → x) in
let rec start (n: int) : U Future.future list =
if n < 1
then Nil[any]
@@ -190,7 +190,7 @@
start (n - 1)) in
let rec stop (fs: U Future.future list) : unit =
match fs with
- | Nil -> ()
- | Cons(f, fs) -> Future.sync f; stop fs in
+ | Nil → ()
+ | Cons(f, fs) → Future.sync f; stop fs in
stop (start iters)
end
diff --git a/examples/run-test.sh b/examples/run-test.sh
--- a/examples/run-test.sh
+++ b/examples/run-test.sh
@@ -8,7 +8,7 @@
case "$test" in
*-type-error.alms)
if ! ./"$exe" "$test" 2>&1 |
- grep '^\(type\|name\) error: ' > /dev/null; then
+ grep '^\(Type\|name\) error ' > /dev/null; then
echo
echo "TEST FAILED (expected type error):"
head -1 "$test"
diff --git a/lib/libbasis.alms b/lib/libbasis.alms
--- a/lib/libbasis.alms
+++ b/lib/libbasis.alms
@@ -95,6 +95,14 @@
let (>.) = flip (<.)
let (>=.) = flip (<=.)
+type `a × `b = `a * `b
+(* These have too-tight precedences *)
+let (≠) = (!=)
+let (≤) = (<=)
+let (≥) = (>=)
+let (≤.) = (<=.)
+let (≥.) = (>=.)
+
let null = fun 'a (x : 'a list) ->
match x with
| Nil -> true
@@ -149,6 +157,10 @@
let snd[`a,`b] (_: `a, y: `b) = y
let (=>!) [`a] (x: `a) [`b] (y: `b) = (y, x)
+let (⇒) = (=>!)
+
+let (←) = (<-)
+let (⇐) = (<-!)
open INTERNALS
open Exn
diff --git a/src/BasisUtils.hs b/src/BasisUtils.hs
--- a/src/BasisUtils.hs
+++ b/src/BasisUtils.hs
@@ -31,6 +31,7 @@
import Dynamics (E, addVal, addMod)
import Env (GenEmpty(..))
+import ErrorMessage (AlmsMonad)
import Meta.Quasi
import Parser (ptd)
import Ppr (ppr, pprPrec, text, precApp)
@@ -156,8 +157,8 @@
infixr 0 `vapp`
-- | Build the renaming environment and rename the entries
-basis2renv :: Monad m => [Entry Raw] ->
- m ([Entry Renamed], RenameState)
+basis2renv :: AlmsMonad m =>
+ [Entry Raw] -> m ([Entry Renamed], RenameState)
basis2renv =
runRenamingM False _loc renameState0 . renameMapM each where
each ValEn { enName = u, enType = t, enValue = v } = do
@@ -175,9 +176,9 @@
return ModEn { enModName = u', enEnts = es' }
-- | Build the dynamic environment
-basis2venv :: Monad m => [Entry Renamed] -> m E
+basis2venv :: AlmsMonad m => [Entry Renamed] -> m E
basis2venv es = foldM add genEmpty es where
- add :: Monad m => E -> Entry Renamed -> m E
+ add :: AlmsMonad m => E -> Entry Renamed -> m E
add e (ValEn { enName = n, enValue = v })
= return (Dynamics.addVal e n v)
add e (ModEn { enModName = n, enEnts = es' })
@@ -185,7 +186,7 @@
add e _ = return e
-- | Build the static environment
-basis2tenv :: Monad m => [Entry Renamed] -> m S
+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
diff --git a/src/ErrorMessage.hs b/src/ErrorMessage.hs
new file mode 100644
--- /dev/null
+++ b/src/ErrorMessage.hs
@@ -0,0 +1,116 @@
+{-# LANGUAGE
+ DeriveDataTypeable,
+ FlexibleInstances,
+ MultiParamTypeClasses,
+ QuasiQuotes
+ #-}
+module ErrorMessage (
+ AlmsException(..), Phase(..), AlmsMonad(..),
+ almsBug, (!::),
+ 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 .
+ |]
+
+(!::) :: Show a => String -> a -> Message d
+msg0 !:: thing = [$msg| $words:msg0 $show: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 . Block . Words
diff --git a/src/Lexer.hs b/src/Lexer.hs
--- a/src/Lexer.hs
+++ b/src/Lexer.hs
@@ -1,13 +1,16 @@
-- | Lexer setup for parsec
module Lexer (
+ -- * Class for saving pre-whitespace position
+ T.TokenEnd(..),
-- * Identifier tokens
isUpperIdentifier, lid, uid,
- -- * Special, unreserved operators
- sharpLoad, sharpInfo,
+ -- * Operators
semis, bang, star, slash, plus,
- lolli, arrow, funbraces, funbraceLeft, funbraceRight,
- qualbox, qualboxLeft, qualboxRight,
+ sharpLoad, sharpInfo, sharpPrec,
+ lolli, arrow, funbraces,
+ lambda, forall, exists, mu,
+ qualbox,
qualU, qualA,
opP,
@@ -21,11 +24,11 @@
import Prec
-import Data.Char (isUpper)
+import Data.Char
import Text.ParserCombinators.Parsec
-import qualified Text.ParserCombinators.Parsec.Token as T
+import qualified Token as T
-tok :: T.TokenParser st
+tok :: T.TokenEnd st => T.TokenParser st
tok = T.makeTokenParser T.LanguageDef {
T.commentStart = "(*",
T.commentEnd = "*)",
@@ -33,9 +36,9 @@
T.nestedComments = True,
T.identStart = upper <|> lower <|> oneOf "_",
T.identLetter = alphaNum <|> oneOf "_'",
- T.opStart = oneOf "!$%&*+-/<=>?@^|~",
- T.opLetter = oneOf "!$%&*+-/<=>?@^|~.:",
- T.reservedNames = ["fun", "sigma",
+ T.opStart = satisfy isOpStart,
+ T.opLetter = satisfy isOpLetter,
+ T.reservedNames = ["fun", "λ",
"if", "then", "else",
"match", "with", "as", "_",
"try",
@@ -45,27 +48,55 @@
"interface", "abstype", "end",
"module", "struct",
"sig", "val", "include",
- "all", "ex", "mu", "of",
+ "all", "ex", "mu", "μ", "of",
"type", "qualifier"],
- T.reservedOpNames = ["|", "=", ":", ":>", "->"],
+ T.reservedOpNames = ["|", "=", ":", ":>", "->", "→", "⊸",
+ "∀", "∃" ],
T.caseSensitive = True
}
-identifier :: CharParser st String
+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 :: String -> CharParser st ()
+reserved :: T.TokenEnd st => String -> CharParser st ()
reserved = T.reserved tok
-operator :: CharParser st String
+operator :: T.TokenEnd st => CharParser st String
operator = T.operator tok
-reservedOp :: String -> CharParser st ()
+reservedOp :: T.TokenEnd st => String -> CharParser st ()
reservedOp = T.reservedOp tok
-charLiteral :: CharParser st Char
+charLiteral :: T.TokenEnd st => CharParser st Char
charLiteral = T.charLiteral tok
-stringLiteral :: CharParser st String
+stringLiteral :: T.TokenEnd st => CharParser st String
stringLiteral = T.stringLiteral tok
-natural :: CharParser st Integer
+natural :: T.TokenEnd st => CharParser st Integer
natural = T.natural tok
-integer :: CharParser st Integer
+integer :: T.TokenEnd st => CharParser st Integer
integer = lexeme $ try $ do
sign <- choice [
char '+' >> return id,
@@ -74,7 +105,7 @@
]
nat <- natural
return (sign nat)
-integerOrFloat :: CharParser st (Either Integer Double)
+integerOrFloat :: T.TokenEnd st => CharParser st (Either Integer Double)
integerOrFloat = lexeme $ try $ do
sign <- choice [
char '+' >> return id,
@@ -84,112 +115,132 @@
nof <- naturalOrFloat
return (sign nof)
-float :: CharParser st Double
+float :: T.TokenEnd st => CharParser st Double
float = T.float tok
-naturalOrFloat :: CharParser st (Either Integer Double)
+naturalOrFloat :: T.TokenEnd st => CharParser st (Either Integer Double)
naturalOrFloat = T.naturalOrFloat tok
-decimal :: CharParser st Integer
+decimal :: T.TokenEnd st => CharParser st Integer
decimal = T.decimal tok
-hexadecimal :: CharParser st Integer
+hexadecimal :: T.TokenEnd st => CharParser st Integer
hexadecimal = T.hexadecimal tok
-octal :: CharParser st Integer
+octal :: T.TokenEnd st => CharParser st Integer
octal = T.octal tok
-symbol :: String -> CharParser st String
+symbol :: T.TokenEnd st => String -> CharParser st String
symbol = T.symbol tok
-lexeme :: CharParser st a -> CharParser st a
+lexeme :: T.TokenEnd st => CharParser st a -> CharParser st a
lexeme = T.lexeme tok
-whiteSpace :: CharParser st ()
+whiteSpace :: T.TokenEnd st => CharParser st ()
whiteSpace = T.whiteSpace tok
-parens :: CharParser st a -> CharParser st a
+parens :: T.TokenEnd st => CharParser st a -> CharParser st a
parens = T.parens tok
-braces :: CharParser st a -> CharParser st a
+braces :: T.TokenEnd st => CharParser st a -> CharParser st a
braces = T.braces tok
-angles :: CharParser st a -> CharParser st a
+angles :: T.TokenEnd st => CharParser st a -> CharParser st a
angles = T.angles tok
-brackets :: CharParser st a -> CharParser st a
+brackets :: T.TokenEnd st => CharParser st a -> CharParser st a
brackets = T.brackets tok
-squares :: CharParser st a -> CharParser st a
+squares :: T.TokenEnd st => CharParser st a -> CharParser st a
squares = T.squares tok
-semi :: CharParser st String
+semi :: T.TokenEnd st => CharParser st String
semi = T.semi tok
-comma :: CharParser st String
+comma :: T.TokenEnd st => CharParser st String
comma = T.comma tok
-colon :: CharParser st String
+colon :: T.TokenEnd st => CharParser st String
colon = T.reservedOp tok ":" >> return ":"
-dot :: CharParser st String
+dot :: T.TokenEnd st => CharParser st String
dot = T.dot tok
-semiSep :: CharParser st a -> CharParser st [a]
+semiSep :: T.TokenEnd st => CharParser st a -> CharParser st [a]
semiSep = T.semiSep tok
-semiSep1 :: CharParser st a -> CharParser st [a]
+semiSep1 :: T.TokenEnd st => CharParser st a -> CharParser st [a]
semiSep1 = T.semiSep1 tok
-commaSep :: CharParser st a -> CharParser st [a]
+commaSep :: T.TokenEnd st => CharParser st a -> CharParser st [a]
commaSep = T.commaSep tok
-commaSep1 :: CharParser st a -> CharParser st [a]
+commaSep1 :: T.TokenEnd st => CharParser st a -> CharParser st [a]
commaSep1 = T.commaSep1 tok
-- | The @#load@ pragma
-sharpLoad :: CharParser st ()
+sharpLoad :: T.TokenEnd st => CharParser st ()
sharpLoad = reserved "#l" <|> reserved "#load"
-- | The @#info@ pragma
-sharpInfo :: CharParser st ()
+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 :: CharParser st String
+bang :: T.TokenEnd st => CharParser st String
bang = symbol "!"
-- | The @-o@ type operator, which violates our other lexer rules
-lolli :: CharParser st ()
-lolli = reserved "-o"
+lolli :: T.TokenEnd st => CharParser st ()
+lolli = reserved "-o" <|> reservedOp "⊸"
-- | The @->@ type operator
-arrow :: CharParser st ()
-arrow = reservedOp "->"
+arrow :: T.TokenEnd st => CharParser st ()
+arrow = reservedOp "->" <|> reservedOp "→"
-- | The left part of the $-[_]>$ operator
-funbraceLeft :: CharParser st ()
+funbraceLeft :: T.TokenEnd st => CharParser st ()
funbraceLeft = try (symbol "-[") >> return ()
-- | The right part of the $-[_]>$ operator
-funbraceRight :: CharParser st ()
+funbraceRight :: T.TokenEnd st => CharParser st ()
funbraceRight = try (symbol "]>") >> return ()
-funbraces :: CharParser st a -> CharParser st a
+funbraces :: T.TokenEnd st => CharParser st a -> CharParser st a
funbraces = between funbraceLeft funbraceRight
-- | The left part of the $|[_]$ annotation
-qualboxLeft :: CharParser st ()
+qualboxLeft :: T.TokenEnd st => CharParser st ()
qualboxLeft = try (symbol "|[") >> return ()
-- | The right part of the $|[_]$ annotation
-qualboxRight :: CharParser st ()
+qualboxRight :: T.TokenEnd st => CharParser st ()
qualboxRight = try (symbol "]") >> return ()
-qualbox :: CharParser st a -> CharParser st a
+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 :: CharParser st String
+semis :: T.TokenEnd st => CharParser st String
semis = lexeme (many1 (char ';'))
-- | @*@, which is reserved in types but not in expressions
-star :: CharParser st String
-star = symbol "*"
+star :: T.TokenEnd st => CharParser st String
+star = symbol "*" <|> symbol "×"
-- | @/@, which is reserved in types but not in expressions
-slash :: CharParser st String
+slash :: T.TokenEnd st => CharParser st String
slash = symbol "/"
-- | @+@, which is reserved in types but not in expressions
-plus :: CharParser st String
+plus :: T.TokenEnd st => CharParser st String
plus = symbol "+"
-- | Qualifier @U@ (not reserved)
-qualU :: CharParser st ()
+qualU :: T.TokenEnd st => CharParser st ()
qualU = reserved "U"
-- | Qualifier @A@ (not reserved)
-qualA :: CharParser st ()
+qualA :: T.TokenEnd st => CharParser st ()
qualA = reserved "A"
-- | Is the string an uppercase identifier? (Special case: @true@ and
@@ -202,14 +253,14 @@
isUpperIdentifier _ = False
-- | Lex a lowercase identifer
-lid :: CharParser st String
+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 :: CharParser st String
+uid :: T.TokenEnd st => CharParser st String
uid = try $ do
s <- identifier <|> symbol "()"
if isUpperIdentifier s
@@ -217,7 +268,7 @@
else pzero "uppercase identifier"
-- | Accept an operator having the specified precedence
-opP :: Prec -> CharParser st String
+opP :: T.TokenEnd st => Prec -> CharParser st String
opP p = try $ do
op <- operator
if precOp op == p
diff --git a/src/Loc.hs b/src/Loc.hs
--- a/src/Loc.hs
+++ b/src/Loc.hs
@@ -195,15 +195,15 @@
instance Show Loc where
showsPrec _ loc
- | isBogus loc = shows (file loc)
+ | isBogus loc = showString (showFile (file loc))
| otherwise =
- shows (file loc) . showString " (" .
+ showString (showFile (file loc)) . showString " (" .
showCoords . showString ")"
where
showCoords =
- if line1 loc == line2 loc || col2 loc == 1 then
+ if line1 loc == line2 loc then
showString "line " . shows (line1 loc) . showString ", " .
- if col1 loc == col2 loc || col2 loc == 1 then
+ if col1 loc + 1 >= col2 loc then
showString "column " . shows (col1 loc)
else
showString "columns " . shows (col1 loc) .
@@ -213,4 +213,10 @@
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
@@ -8,7 +8,8 @@
import Util
import Ppr (Ppr(..), (<+>), (<>), text, char, hang, ($$), nest, printDoc)
import qualified Ppr
-import Parser (parse, parseInteractive, parseProg, parseGetInfo)
+import Parser (parseFile, REPLCommand(..), parseCommand)
+import Prec (precOp)
import Paths (findAlmsLib, findAlmsLibRel, versionString, shortenPath)
import Rename (RenameState, runRenamingM, renameDecls, renameProg,
getRenamingInfo, RenamingInfo(..))
@@ -23,18 +24,19 @@
import Syntax (Prog, Decl, TyDec, BIdent(..), prog2decls,
Ident, Raw, Renamed)
import Env (empty, (=..=))
-import Loc (isBogus, initial)
+import Loc (isBogus, initial, bogus)
+import qualified ErrorMessage as EM
+import qualified Message.AST as Msg
+import Data.Char (isSpace)
import System.Exit (exitFailure)
import System.Environment (getArgs, getProgName, withProgName, withArgs)
import System.IO.Error (ioeGetErrorString, isUserError)
-import IO (hPutStrLn, stderr)
+import IO (hPutStrLn, hFlush, stdout, stderr)
import qualified Control.Exception as Exn
#ifdef USE_READLINE
import qualified USE_READLINE as RL
-#else
-import IO (hFlush, stdout)
#endif
data Option = Don'tExecute
@@ -43,6 +45,7 @@
| Verbose
| Quiet
| LoadFile String
+ | NoLineEdit
deriving Eq
-- | The main procedure
@@ -80,8 +83,8 @@
loadString :: ReplState -> String -> String -> IO ReplState
loadString st name src = do
- case parse parseProg name src of
- Left e -> fail $ show e
+ 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)
@@ -92,8 +95,8 @@
batch :: String -> IO String -> (Option -> Bool) -> ReplState -> IO ()
batch filename msrc opt st0 = do
src <- msrc
- case parse parseProg filename src of
- Left e -> fail $ show e
+ case parseFile filename src of
+ Left e -> Exn.throwIO e
Right ast -> rename ast where
rename :: Prog Raw -> IO ()
check :: Prog Renamed -> IO ()
@@ -163,20 +166,28 @@
handleExns :: IO a -> IO a -> IO a
handleExns body handler =
- (body
- `Exn.catch`
- \e@(VExn { }) -> do
+ body
+ `Exn.catches`
+ [ Exn.Handler $ \e@(VExn { }) -> do
prog <- getProgName
- hPutStrLn stderr .
- show $
- hang (text (prog ++ ": Uncaught exception:"))
- 2
- (vppr e)
- handler)
- `Exn.catch`
- \err -> do
- hPutStrLn stderr (errorString err)
- handler
+ continue $ EM.AlmsException
+ (EM.OtherError ("Uncaught exception"))
+ bogus
+ (Msg.Table [
+ ("in program:", Msg.Exact prog),
+ ("exception:", Msg.Printable (vppr e))
+ ]),
+ Exn.Handler continue,
+ Exn.Handler $ \err ->
+ continue $ EM.AlmsException EM.DynamicsPhase bogus $
+ Msg.Flow [Msg.Words (errorString err)],
+ Exn.Handler $ \(Exn.SomeException err) ->
+ continue $ EM.AlmsException EM.DynamicsPhase bogus $
+ Msg.Flow [Msg.Words (show err)] ]
+ where
+ continue err = do
+ hPutStrLn stderr (show (err :: EM.AlmsException))
+ handler
interactive :: (Option -> Bool) -> ReplState -> IO ()
interactive opt rs0 = do
@@ -226,9 +237,9 @@
return st3
in rename (st, ast)
- quiet = opt Quiet
- say = if quiet then const (return ()) else printDoc
- get = if quiet then const (readline "") else readline
+ getln = if opt NoLineEdit then getline else readline
+ say = if opt Quiet then const (return ()) else printDoc
+ get = if opt Quiet then const (getln "") else getln
reader :: Int -> ReplState -> IO (Maybe (Int, [Decl Raw]))
reader row st = loop 1 []
where
@@ -242,20 +253,24 @@
hPutStrLn stderr ""
hPutStrLn stderr (show err)
reader (row + count) st
- (Just line, _) ->
- case parseGetInfo line of
- Nothing ->
- let cmd = fixup (line : map fst acc) in
- case parseInteractive row cmd of
- Right ast -> do
- addHistory cmd
- return (Just (row + count, ast))
- Left derr ->
- loop (count + 1) ((line, derr) : acc)
- Just ids -> do
+ (Just line, _)
+ | all isSpace line -> loop count acc
+ | otherwise ->
+ let cmd = fixup (line : map fst acc) in
+ case parseCommand row line cmd of
+ GetInfoCmd ids -> do
mapM_ (printInfo st) ids
addHistory line
loop (count + 1) acc
+ GetPrecCmd lids -> do
+ mapM_ printPrec lids
+ addHistory line
+ loop (count + 1) acc
+ DeclsCmd ast -> do
+ addHistory cmd
+ return (Just (row + count, ast))
+ ParseError derr ->
+ loop (count + 1) ((line, derr) : acc)
printResult :: Module -> NewValues -> IO ()
printResult md00 values = say (loop True md00) where
loop tl md0 = case md0 of
@@ -325,6 +340,12 @@
else text " -- defined at" <+> text (show loc)
where (>?>) = if Ppr.isEmpty who then (<+>) else (Ppr.>?>)
+printPrec :: String -> IO ()
+printPrec oper = printDoc $
+ hang (text oper)
+ 2
+ (text ":" <+> text (show (precOp oper)))
+
mumble :: Ppr a => String -> a -> IO ()
mumble s a = printDoc $ hang (text s <> char ':') 2 (ppr a)
@@ -353,6 +374,7 @@
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
loop opts (('-':c:d:e):r)
= loop opts (['-',c]:('-':d:e):r)
loop _ (('-':_):_) = usage
@@ -370,6 +392,7 @@
hPutStrLn stderr "Options:"
hPutStrLn stderr " -l FILE Load file"
hPutStrLn stderr " -q Don't print prompt, greeting, responses"
+ hPutStrLn stderr " -e Don't use line editing"
hPutStrLn stderr ""
hPutStrLn stderr "Debugging options:"
hPutStrLn stderr " -b Don't load libbasis.alms"
@@ -379,8 +402,8 @@
exitFailure
initialize :: IO ()
-readline :: String -> IO (Maybe String)
addHistory :: String -> IO ()
+readline :: String -> IO (Maybe String)
#ifdef USE_READLINE
initialize = RL.initialize
@@ -389,8 +412,11 @@
#else
initialize = return ()
addHistory _ = return ()
-readline s = do
+readline = getline
+#endif
+
+getline :: String -> IO (Maybe String)
+getline s = do
putStr s
hFlush stdout
catch (fmap Just getLine) (\_ -> return Nothing)
-#endif
diff --git a/src/Makefile b/src/Makefile
--- a/src/Makefile
+++ b/src/Makefile
@@ -5,7 +5,8 @@
EXE = alms
EXAMPLES = ../examples
SRC = $(HS_SRC) $(HSBOOT_SRC)
-HS_SRC = *.hs Basis/*.hs Basis/Channel/*.hs Syntax/*.hs Meta/*.hs
+HS_SRC = *.hs Basis/*.hs Basis/Channel/*.hs Syntax/*.hs \
+ Message/*.hs Meta/*.hs
HSBOOT_SRC = Syntax/*.hs-boot
HCOPTS = -W -Wall -O0 $(EDITING) $(NOWARN)
diff --git a/src/Message/AST.hs b/src/Message/AST.hs
new file mode 100644
--- /dev/null
+++ b/src/Message/AST.hs
@@ -0,0 +1,43 @@
+{-# LANGUAGE
+ EmptyDataDecls,
+ GADTs
+ #-}
+module Message.AST (
+ Message(..),
+ V, H, MessageV, MessageH,
+ StackStyle(..)
+) where
+
+import PprClass
+
+-- | Simple message markup
+data Message d where
+ Words :: String -> Message d
+ Flow :: [Message H] -> Message d
+ Exact :: String -> Message d
+ Surround :: String -> String -> Message d -> Message d
+ Quote :: Message d -> Message d
+ Block :: Message H -> Message V
+ Stack :: StackStyle -> [Message V] -> Message V
+ Table :: [(String, Message V)] -> Message V
+ Indent :: Message V -> Message V
+ Printable :: Ppr a => a -> Message d
+ Showable :: Show a => a -> Message d
+ AntiMsg :: String -> String -> Message d
+
+data V
+data H
+
+-- | Vertical mode message
+type MessageV = Message V
+
+-- | Horizontal mode message
+type MessageH = Message H
+
+-- | Types of lists
+data StackStyle
+ = Numbered
+ | Bulleted
+ | Separated
+ | Broken
+
diff --git a/src/Message/Parser.hs b/src/Message/Parser.hs
new file mode 100644
--- /dev/null
+++ b/src/Message/Parser.hs
@@ -0,0 +1,240 @@
+module Message.Parser (
+ parseMessageQ, tokensT, messageP,
+) where
+
+import Loc
+import Message.AST
+import Util
+
+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
+-- location and for errors.
+parseMessageQ :: String -> Q MessageV
+parseMessageQ str0 = do
+ loc <- location
+ toks <- either (fail . show) return $
+ parse (setPosition (toSourcePos (fromTHLoc loc)) *> tokensT)
+ "" str0
+ either (fail . show) return $
+ parse messageP "" toks
+
+--
+-- Lexer
+--
+
+data Token
+ = BTag String
+ | ETag String
+ | Word String
+ | Chars String
+ | Whitespace String
+ | AntiTok String String
+ deriving (Eq, Show)
+
+tokensT :: CharParser () [(SourcePos, Token)]
+tokensT = many (getPosition |*| tokenT) <* eof
+
+tokenT :: CharParser () Token
+tokenT = choice [charsT, tagT, wordT, whitespaceT, antiT]
+
+charsT :: CharParser () Token
+charsT = tstring "" *>
+ (Chars <$> manyTill anyChar (tstring ""))
+
+tagT :: CharParser () Token
+tagT = between (char '<') (char '>') $
+ option BTag (ETag <$ char '/')
+ <*> many1 lower
+
+wordT :: CharParser () Token
+wordT = Word <$> many1 wordChar
+ where wordChar = satisfy (\x -> not (isSpace x || x `elem` "<&$"))
+ <|> '&' <$ tstring "&"
+ <|> '$' <$ tstring "$"
+ <|> '<' <$ tstring "<"
+ <|> '>' <$ tstring ">"
+
+whitespaceT :: CharParser () Token
+whitespaceT = Whitespace <$> many1 space
+
+antiT :: CharParser () Token
+antiT = char '$' *> (inner <|> between (char '<') (char '>') inner)
+ where inner = combine <$> many1 alphaNum
+ <*> optionMaybe (char ':' *> many1 alphaNum)
+ <|> AntiTok "" <$> (char ':' *> many1 alphaNum)
+ combine name Nothing = AntiTok "" name
+ combine tag (Just name) = AntiTok tag name
+
+tstring :: String -> CharParser () String
+tstring = try . string
+
+--
+-- Token parsers
+--
+
+type P a = GenParser (SourcePos, Token) () a
+
+tsatisfy :: (Token -> Maybe a) -> P a
+tsatisfy check = token show fst (check . snd)
+
+exact :: P String
+exact = tsatisfy check where
+ check (Chars s) = Just s
+ check _ = Nothing
+
+btag :: String -> P ()
+btag s = tsatisfy check where
+ check (BTag s') | s == s' = Just ()
+ check _ = Nothing
+
+etag :: String -> P ()
+etag s = tsatisfy check where
+ check (ETag s') | s == s' = Just ()
+ check _ = Nothing
+
+word :: P String
+word = tsatisfy check where
+ check (Word s) = Just s
+ check _ = Nothing
+
+whitespace :: P ()
+whitespace = tsatisfy check where
+ check (Whitespace _) = Just ()
+ check _ = Nothing
+
+ws :: P ()
+ws = () <$ many whitespace
+
+anti :: Bool -> P (String, String)
+anti v = tsatisfy check where
+ check (AntiTok tag name)
+ | elem tag vtags == v = Just (tag, name)
+ check _ = Nothing
+
+vtags :: [String]
+vtags = ["ol", "ul", "br", "p", "dl", "indent"]
+
+intag :: String -> P a -> P a
+intag s = between (btag s) (etag s)
+
+intagV :: String -> P a -> P a
+intagV s p = intag s (ws *> p) <* ws
+
+pretag :: String -> P a -> P a
+pretag s p = between (btag s *> ws) (optional (etag s)) p <* ws
+
+--
+-- Parser
+--
+
+messageP :: P MessageV
+messageP = ws *> parseV <* eof
+
+-- | Vertical-mode message
+parseV :: P MessageV
+parseV = option emptyMsg parse1V
+
+-- | Vertical-mode message, non-empty
+parse1V :: P MessageV
+parse1V = wrapMany (Stack Separated) <$> many1skip paragraphV (btag "p" *> ws)
+
+paragraphV :: P MessageV
+paragraphV = wrapMany (Stack Broken) <$> many1skip lineV (btag "br" *> ws)
+
+lineV :: P MessageV
+lineV = antiV
+ <|> blockV
+ <|> indentV
+ <|> quoteV
+ <|> listV
+ <|> tableV
+ <|> parse1H
+
+antiV :: P MessageV
+antiV = uncurry AntiMsg <$> anti True <* ws
+
+blockV :: P MessageV
+blockV = Block <$> intagV "block" parseH
+
+indentV :: P MessageV
+indentV = Indent <$> intagV "indent" parseV
+
+quoteV :: P MessageV
+quoteV = Quote <$> intagV "qq" parseV
+
+listV :: P MessageV
+listV = Stack Numbered <$> intagV "ol" items
+ <|> Stack Bulleted <$> intagV "ul" items
+ where items = many1skip parse1V (btag "li" *> ws)
+
+tableV :: P MessageV
+tableV = (Indent . Table) <$> intagV "dl" items
+ where items = many $
+ (unwords <$> pretag "dt" (manyskip word whitespace))
+ |*| pretag "dd" parseV
+
+-- | Horizontal-mode message, non-empty
+parse1H :: P (Message d)
+parse1H = Flow <$> many1skip itemH whitespace
+
+-- | Horizontal-mode message
+parseH :: P (Message d)
+parseH = Flow <$> manyskip itemH whitespace
+
+-- | A horizontal item, either text or special
+itemH :: P (Message d)
+itemH = trailingH "" <|> do
+ start <- word
+ option (Exact start) (trailingH start)
+
+-- | Special horizontal markup, maybe with some leading or
+-- trailing word
+trailingH :: String -> P (Message d)
+trailingH start = makeSurround start <$> specialH <*> option "" word
+
+-- | Special horizontal markup: quotations, exact, and antiquotes
+specialH :: P (Message d)
+specialH = Quote <$> intag "q" parseH
+ <|> Exact <$> exact
+ <|> uncurry AntiMsg <$> anti False
+
+makeSurround :: String -> Message d -> String -> Message d
+makeSurround "" m "" = m
+makeSurround start m end = Surround start end m
+
+-- | Combine, but only if there's more than one
+wrapMany :: ([a] -> a) -> [a] -> a
+wrapMany _ [x] = x
+wrapMany w xs = w xs
+
+emptyMsg :: Message d
+emptyMsg = Exact ""
+
+--
+-- Auxiliary
+--
+
+(|*|) :: Applicative f => f a -> f b -> f (a, b)
+a |*| b = (,) <$> a <*> b
+
+(|:|) :: Applicative f => f a -> f [a] -> f [a]
+a |:| b = (:) <$> a <*> b
+
+infixl 4 |*|, |:|
+
+-- | Parse a list of things, skipping optional things
+manyskip :: P a -> P b -> P [a]
+manyskip save skip = save |:| manyskip save skip
+ <|> skip *> manyskip save skip
+ <|> pure []
+
+-- | Parse a list of things (at least one), skipping optional things
+many1skip :: P a -> P b -> P [a]
+many1skip save skip = save |:| manyskip save skip
+ <|> skip *> many1skip save skip
+ <|> pzero
+
diff --git a/src/Message/Quasi.hs b/src/Message/Quasi.hs
new file mode 100644
--- /dev/null
+++ b/src/Message/Quasi.hs
@@ -0,0 +1,90 @@
+{-# LANGUAGE
+ FlexibleInstances,
+ GADTs,
+ GeneralizedNewtypeDeriving,
+ MultiParamTypeClasses,
+ TemplateHaskell
+ #-}
+module Message.Quasi (
+ msg, Message(), MessageV, MessageH
+) where
+
+import Message.AST
+import Message.Parser
+import PprClass
+import Util
+
+import qualified Data.Map as M
+import Language.Haskell.TH
+import Language.Haskell.TH.Quote (QuasiQuoter(..))
+import Language.Haskell.TH.Syntax (lift)
+
+msg :: QuasiQuoter
+msg = QuasiQuoter qexp qpat where
+ qexp s = parseMessageQ s >>= msgAstToExpQ
+ qpat _ = fail "Quasiquoter ‘msg’ does not support patterns"
+
+msgAstToExpQ :: Message d -> ExpQ
+msgAstToExpQ msg0 = do
+ namelist <- sequence
+ [ (,) (show z) `liftM` newName ("_v"++show z)
+ | z <- [ 1 .. highest msg0 ] ]
+ let expQ = translate (M.fromList namelist) msg0
+ foldr (\(_, var) -> lamE [varP var]) expQ namelist
+ where
+ highest :: Message d -> Int
+ highest msg1 = case msg1 of
+ Words _ -> 0
+ Flow msgs -> maximum (map highest msgs)
+ Exact _ -> 0
+ Surround _ _ msg' -> highest msg'
+ Quote msg' -> highest msg'
+ Block msg' -> highest msg'
+ Stack _ msgs -> maximum (map highest msgs)
+ Table rows -> maximum (map (highest . snd) rows)
+ Indent msg' -> highest msg'
+ Printable _ -> 0
+ Showable _ -> 0
+ AntiMsg _ name -> case readsPrec 0 name of
+ (z,""):_ -> z
+ _ -> 0
+ --
+ translate :: M.Map String Name -> Message d -> ExpQ
+ translate namemap = loop where
+ loop :: Message d -> ExpQ
+ loop msg1 = case msg1 of
+ Words s -> [| Words $(lift s) |]
+ Flow msgs -> [| Flow $(listE (map loop msgs)) |]
+ Exact s -> [| Exact $(lift s) |]
+ Surround s e msg'
+ -> [| Surround $(lift s) $(lift e) $(loop msg') |]
+ Quote msg' -> [| Quote $(loop msg') |]
+ Block msg' -> [| Block $(loop msg') |]
+ Stack sty msgs
+ -> [| Stack $(styleQ sty)
+ $(listE (map loop msgs)) |]
+ where styleQ Numbered = [| Numbered |]
+ styleQ Bulleted = [| Bulleted |]
+ styleQ Separated = [| Separated |]
+ styleQ Broken = [| Broken |]
+ Table rows -> [| Table $(listE (map each rows)) |]
+ where each (s,msg') = [| ($(lift s), $(loop msg')) |]
+ Indent msg' -> [| Indent $(loop msg') |]
+ Printable a -> [| Exact $(lift (show (PprClass.ppr a))) |]
+ Showable a -> [| Exact $(lift (show a)) |]
+ AntiMsg tag name -> case tag of
+ "words" -> [| Words $var |]
+ "flow" -> [| Flow $var |]
+ "exact" -> [| Exact $var |]
+ 'q':tag' -> [| Quote $(loop (AntiMsg tag' name)) |]
+ "msg" -> var
+ "ol" -> [| Stack Numbered $var |]
+ "ul" -> [| Stack Bulleted $var |]
+ "br" -> [| Stack Broken $var |]
+ "p" -> [| Stack Separated $var |]
+ "dl" -> [| Table $var |]
+ "indent" -> [| Indent $var |]
+ "show" -> [| Showable $var |]
+ _ -> [| Printable $var |]
+ where var = varE (M.findWithDefault (mkName name) name namemap)
+
diff --git a/src/Message/Render.hs b/src/Message/Render.hs
new file mode 100644
--- /dev/null
+++ b/src/Message/Render.hs
@@ -0,0 +1,110 @@
+{-# LANGUAGE
+ FlexibleInstances,
+ GADTs,
+ ParallelListComp,
+ QuasiQuotes
+ #-}
+module Message.Render (
+ module PprClass
+) where
+
+import PprClass
+import Message.AST
+
+-- | Context for message rendering
+data RenderContext
+ = RenderContext {
+ rcQtLevel :: Int,
+ rcLeft :: Doc,
+ rcRight :: Doc
+ }
+
+rc0 :: RenderContext
+rc0 = RenderContext 0 empty empty
+
+getQuotes :: RenderContext -> (String, String)
+getQuotes cxt =
+ if even (rcQtLevel cxt)
+ then ("‘", "’")
+ else ("“", "”")
+
+incQuotes :: RenderContext -> RenderContext
+incQuotes cxt = cxt { rcQtLevel = rcQtLevel cxt + 1 }
+
+clearLeft, clearRight :: RenderContext -> RenderContext
+clearLeft cxt = cxt { rcLeft = empty }
+clearRight cxt = cxt { rcRight = empty }
+
+addQuotes :: RenderContext -> Doc -> Doc
+addQuotes cxt doc = rcLeft cxt <> doc <> rcRight cxt
+
+renderAntiMsg :: String -> String -> Doc
+renderAntiMsg t a = text "${" <> text t <> colon <> text a <> char '}'
+
+renderMessageH :: RenderContext -> Message H -> [Doc]
+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 [msg'] -> renderMessageH cxt msg'
+ Flow (m:ms) -> renderMessageH (clearRight cxt) m ++
+ concatMap (renderMessageH cxt') (init ms) ++
+ renderMessageH (clearLeft cxt) (last ms)
+ where cxt' = clearRight (clearLeft cxt)
+ Surround s e msg'
+ -> renderMessageH cxt' {
+ rcLeft = rcLeft cxt <> text s,
+ rcRight = text e <> rcRight cxt
+ } msg'
+ where cxt' = clearRight (clearLeft cxt)
+ Quote msg' -> renderMessageH cxt' (Surround s e msg')
+ where (s, e) = getQuotes cxt
+ cxt' = incQuotes cxt
+ Printable a -> [addQuotes cxt (ppr a)]
+ Showable a -> [addQuotes cxt (text (show a))]
+ AntiMsg t a -> [addQuotes cxt (renderAntiMsg t a)]
+
+renderMessageV :: RenderContext -> Message V -> Doc
+renderMessageV cxt msg0 = case msg0 of
+ Words s -> renderMessageV cxt (Block (Words s))
+ Flow s -> renderMessageV cxt (Block (Flow s))
+ Exact s -> text s
+ Surround s e msg'
+ -> text s <> renderMessageV cxt msg' <> text e
+ Quote msg' -> renderMessageV cxt' (Surround s e msg')
+ where (s, e) = getQuotes cxt
+ cxt' = incQuotes cxt
+ Block msg' -> fsep (renderMessageH cxt msg')
+ Stack sty msgs -> case sty of
+ Numbered -> vcat [ integer i <> char '.' <+>
+ text (replicate (dent - length (show i)) ' ') <>
+ nest (dent + 2) (renderMessageV cxt msg')
+ | msg' <- msgs
+ | i <- [ 1 .. ] ]
+ where len = length msgs
+ dent = length (show len)
+ Bulleted -> vcat [ text " •" <+> nest 3 (renderMessageV cxt msg')
+ | msg' <- msgs ]
+ Separated -> vcat (punctuate (char '\n')
+ (map (renderMessageV cxt) msgs))
+ Broken -> vcat (map (renderMessageV cxt) msgs)
+ Table rows -> vcat [ text label <+>
+ text (replicate (dent - length label) ' ') <>
+ nest (dent + 1) (renderMessageV cxt msg')
+ | (label, msg') <- rows ]
+ where dent = maximum (map (length . fst) rows)
+ Indent msg' -> text " " <>
+ nest 4 (renderMessageV cxt msg')
+ Printable a -> ppr a
+ Showable a -> text (show a)
+ AntiMsg t a -> renderAntiMsg t a
+
+instance Ppr (Message H) where
+ ppr = fsep . renderMessageH rc0
+
+instance Ppr (Message V) where
+ ppr = renderMessageV rc0
+
+instance Show (Message H) where showsPrec = showFromPpr
+instance Show (Message V) where showsPrec = showFromPpr
+
diff --git a/src/Meta/THHelpers.hs b/src/Meta/THHelpers.hs
--- a/src/Meta/THHelpers.hs
+++ b/src/Meta/THHelpers.hs
@@ -219,9 +219,3 @@
hsOr hs1 (Just hs2) = HsOr hs1 hs2
underscore = symbol haskell "_"
lid_ = lid <|> underscore
-
--- | Parsec parsers are Applicatives, which lets us write slightly
--- more pleasant, non-monadic-looking parsers
-instance Applicative (GenParser a b) where
- pure = return
- (<*>) = ap
diff --git a/src/Parser.hs b/src/Parser.hs
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -7,10 +7,13 @@
module Parser (
-- * The parsing monad
P, parse,
+ -- ** Errors
+ ParseError,
-- ** Quasiquote parsing
parseQuasi,
- -- ** REPL command parsing
- parseGetInfo, parseInteractive,
+ -- ** File and REPL command parsing
+ parseFile,
+ REPLCommand(..), parseCommand,
-- ** Parsers
parseProg, parseRepl, parseDecls, parseDecl, parseModExp,
parseTyDec, parseAbsTy, parseType, parseTyPat,
@@ -27,24 +30,35 @@
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
+ 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
+ stAnti = False,
+ stPos = toSourcePos bogus
}
-- | Run a parser, given the source file name, on a given string
@@ -72,6 +86,53 @@
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.Block (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.Block . 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
@@ -81,6 +142,13 @@
<|> 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
@@ -105,16 +173,21 @@
getSigma :: P Bool
getSigma = stSigma `fmap` getState
-curLoc :: P Loc
-curLoc = getPosition >>! fromSourcePos
+-- | Get the ending position of the last token, before trailing whitespace
+getEndPosition :: P SourcePos
+getEndPosition = stPos <$> getState
-addLoc :: Relocatable a => P a -> P a
-addLoc p = do
+-- | Parse something and return the span of its location
+withLoc :: P a -> P (a, Loc)
+withLoc p = do
before <- getPosition
a <- p
- after <- getPosition
- return (a <<@ fromSourcePosSpan before after)
+ after <- getEndPosition
+ return (a, fromSourcePosSpan before after)
+addLoc :: Relocatable a => P a -> P a
+addLoc = uncurry (<<@) <$$> withLoc
+
class Nameable a where
(@@) :: String -> a -> a
@@ -299,8 +372,8 @@
oplevelp = ( "operator") . liftM Syntax.lid . opP
quantp :: P Quant
-quantp = Forall <$ reserved "all"
- <|> Exists <$ reserved "ex"
+quantp = Forall <$ forall
+ <|> Exists <$ exists
<|> antiblep
"quantifier"
@@ -312,7 +385,7 @@
_ | p == precStart
-> do
tc <- tyQu <$> quantp
- <|> tyMu <$ reserved "mu"
+ <|> tyMu <$ mu
tvs <- many tyvarp
dot
t <- typepP p
@@ -810,7 +883,7 @@
optional (reservedOp "|")
clauses <- flip sepBy1 (reservedOp "|") $ addLoc $ do
(xi, sigma, lift) <- pattbangp
- reservedOp "->"
+ arrow
ei <- mapSigma (sigma ||) expr0
return $
lift False
@@ -836,7 +909,7 @@
(exApp (exVar (qlid "INTERNALS.Exn.raise"))
(exVar (qlid "e")))
],
- do reserved "fun"
+ do lambda
(sigma, build) <- choice
[
argsp1,
@@ -908,7 +981,7 @@
preCasealtp :: Id i => P (Bool -> CaseAlt i)
preCasealtp = "match clause" @@ (const <$> antiblep) <|> do
(xi, sigma, lift) <- pattbangp
- reservedOp "->"
+ arrow
ei <- mapSigma (sigma ||) exprp
return (\b -> lift b caClause xi ei)
@@ -985,9 +1058,8 @@
(Type i -> Type i -> Type i) ->
P (Bool, Type i -> Type i, Expr i -> Expr i)
vargp arrcon = do
- inBang <- bangp
- loc <- curLoc
- (p, t) <- paty
+ 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
@@ -1056,10 +1128,10 @@
tyargp :: Id i => P (Type i -> Type i, Expr i -> Expr i)
tyargp = do
tvs <- liftM return loctv <|> brackets (commaSep1 loctv)
- return (\t -> foldr (\(_, tv) -> tyAll tv) t tvs,
- \e -> foldr (\(loc, tv) -> exTAbs tv <<@ loc) e tvs)
+ return (\t -> foldr (\(tv, _ ) -> tyAll tv) t tvs,
+ \e -> foldr (\(tv, loc) -> exTAbs tv <<@ loc) e tvs)
where
- loctv = liftM2 (,) curLoc tyvarp
+ loctv = withLoc tyvarp
pattbangp :: Id i =>
P (Patt i, Bool,
@@ -1135,7 +1207,7 @@
antiblep
]
-finish :: CharParser st a -> CharParser st a
+finish :: P a -> P a
finish p = do
optional (whiteSpace)
r <- p
diff --git a/src/Ppr.hs b/src/Ppr.hs
--- a/src/Ppr.hs
+++ b/src/Ppr.hs
@@ -5,20 +5,14 @@
TypeSynonymInstances
#-}
module Ppr (
- -- * Pretty-printing class
- Ppr(..),
- -- * Pretty-printing combinators
- parensIf, (>+>), (>?>), pprTyApp,
- -- * Renderers
- render, renderS, printDoc, printPpr,
- -- ** Instance helpers
- showFromPpr, pprFromShow,
+ pprTyApp,
-- * Re-exports
- module Text.PrettyPrint,
+ module PprClass,
module Prec
) where
import Meta.Quasi
+import PprClass
import Prec
import Syntax
import Util
@@ -29,85 +23,8 @@
import qualified Syntax.Patt
import qualified Loc
-import Text.PrettyPrint hiding (render)
import Data.List (intersperse)
--- | Class for pretty-printing at different types
---
--- Minimal complete definition is one of:
---
--- * 'pprPrec'
---
--- * 'ppr'
-class Ppr p where
- -- | Print at the specified enclosing precedence
- pprPrec :: Int -> p -> Doc
- -- | Print at top-level precedence
- ppr :: p -> Doc
- -- | Print a list at the specified enclosing precedence with
- -- the specified style
- pprPrecStyleList :: Int -> ListStyle -> [p] -> Doc
- -- | Print a list at the specified enclosing precedence
- pprPrecList :: Int -> [p] -> Doc
- -- | Print a list at top-level precedence
- pprList :: [p] -> Doc
- -- | Style for printing lists
- listStyle :: [p] -> ListStyle
- --
- ppr = pprPrec precDot
- pprPrec _ = ppr
- pprPrecStyleList _ st [] =
- if listStyleDelimitEmpty st
- then listStyleBegin st <> listStyleEnd st
- else empty
- pprPrecStyleList p st [x] =
- if listStyleDelimitSingleton st
- then listStyleBegin st <> ppr x <> listStyleEnd st
- else pprPrec p x
- pprPrecStyleList _ st xs =
- listStyleBegin st <>
- listStyleJoiner st (punctuate (listStylePunct st) (map ppr xs))
- <> listStyleEnd st
- pprPrecList p xs = pprPrecStyleList p (listStyle xs) xs
- pprList = pprPrecList 0
- listStyle _ = ListStyle {
- listStyleBegin = lparen,
- listStyleEnd = rparen,
- listStylePunct = comma,
- listStyleDelimitEmpty = False,
- listStyleDelimitSingleton = False,
- listStyleJoiner = fsep
- }
-
-data ListStyle = ListStyle {
- listStyleBegin, listStyleEnd, listStylePunct :: Doc,
- listStyleDelimitEmpty, listStyleDelimitSingleton :: Bool,
- listStyleJoiner :: [Doc] -> Doc
-}
-
--- | Conditionally add parens around the given 'Doc'
-parensIf :: Bool -> Doc -> Doc
-parensIf True doc = parens doc
-parensIf False doc = doc
-
-instance Ppr a => Ppr [a] where
- pprPrec = pprPrecList
-
-instance Ppr a => Ppr (Maybe a) where
- pprPrec _ Nothing = empty
- pprPrec p (Just a) = pprPrec p a
-
-class Ppr a => IsInfix a where
- isInfix :: a -> Bool
- pprRight :: Int -> a -> Doc
- pprRight p a =
- if isInfix a
- then pprPrec p a
- else ppr a
-
-instance Ppr Doc where
- ppr = id
-
instance IsInfix (Type i) where
isInfix [$ty| ($_, $_) $lid:n |] = isOperator n
isInfix [$ty| $_ -[$_]> $_ |] = True
@@ -198,9 +115,6 @@
map (pprPrec (precStar + 1)) qes
pprPrec p [$qeQ| $anti:a |] = pprPrec p a
-instance Ppr Int where
- ppr = int
-
instance Ppr (Prog i) where
ppr [$prQ| $list:ms |] = vcat (map ppr ms)
ppr [$prQ| $expr:e |] = ppr e
@@ -542,46 +456,4 @@
instance Ppr (TyVar i) where pprPrec = pprFromShow
instance Ppr Anti where pprPrec = pprFromShow
instance (Show p, Show k) => Ppr (Path p k) where pprPrec = pprFromShow
-
--- Render a document in the preferred style, given a string continuation
-renderS :: Doc -> ShowS
-renderS doc rest = fullRender PageMode 80 1.5 each rest doc
- where each (Chr c) s' = c:s'
- each (Str s) s' = s++s'
- each (PStr s) s' = s++s'
-
--- Render a document in the preferred style
-render :: Doc -> String
-render doc = renderS doc ""
-
--- Render and display a document in the preferred style
-printDoc :: Doc -> IO ()
-printDoc = fullRender PageMode 80 1.5 each (putChar '\n')
- where each (Chr c) io = putChar c >> io
- each (Str s) io = putStr s >> io
- each (PStr s) io = putStr s >> io
-
--- Pretty-print, render and display in the preferred style
-printPpr :: Ppr a => a -> IO ()
-printPpr = printDoc . ppr
-
-showFromPpr :: Ppr a => Int -> a -> ShowS
-showFromPpr p t = renderS (pprPrec p t)
-
-pprFromShow :: Show a => Int -> a -> Doc
-pprFromShow p t = text (showsPrec p t "")
-
-liftEmpty :: (Doc -> Doc -> Doc) -> Doc -> Doc -> Doc
-liftEmpty joiner d1 d2
- | isEmpty d1 = d2
- | isEmpty d2 = d1
- | otherwise = joiner d1 d2
-
-(>+>) :: Doc -> Doc -> Doc
-(>+>) = flip hang 2
-
-(>?>) :: Doc -> Doc -> Doc
-(>?>) = liftEmpty (>+>)
-
-infixr 5 >+>, >?>
diff --git a/src/PprClass.hs b/src/PprClass.hs
new file mode 100644
--- /dev/null
+++ b/src/PprClass.hs
@@ -0,0 +1,136 @@
+module PprClass (
+ -- * Pretty-printing class
+ Ppr(..), IsInfix(..),
+ -- * Pretty-printing combinators
+ parensIf, (>+>), (>?>),
+ -- * Renderers
+ render, renderS, printDoc, printPpr,
+ -- ** Instance helpers
+ showFromPpr, pprFromShow,
+ -- * Re-exports
+ module Text.PrettyPrint
+) where
+
+import Text.PrettyPrint hiding (render)
+
+-- | Class for pretty-printing at different types
+--
+-- Minimal complete definition is one of:
+--
+-- * 'pprPrec'
+--
+-- * 'ppr'
+class Ppr p where
+ -- | Print at the specified enclosing precedence
+ pprPrec :: Int -> p -> Doc
+ -- | Print at top-level precedence
+ ppr :: p -> Doc
+ -- | Print a list at the specified enclosing precedence with
+ -- the specified style
+ pprPrecStyleList :: Int -> ListStyle -> [p] -> Doc
+ -- | Print a list at the specified enclosing precedence
+ pprPrecList :: Int -> [p] -> Doc
+ -- | Print a list at top-level precedence
+ pprList :: [p] -> Doc
+ -- | Style for printing lists
+ listStyle :: [p] -> ListStyle
+ --
+ ppr = pprPrec 0
+ pprPrec _ = ppr
+ pprPrecStyleList _ st [] =
+ if listStyleDelimitEmpty st
+ then listStyleBegin st <> listStyleEnd st
+ else empty
+ pprPrecStyleList p st [x] =
+ if listStyleDelimitSingleton st
+ then listStyleBegin st <> ppr x <> listStyleEnd st
+ else pprPrec p x
+ pprPrecStyleList _ st xs =
+ listStyleBegin st <>
+ listStyleJoiner st (punctuate (listStylePunct st) (map ppr xs))
+ <> listStyleEnd st
+ pprPrecList p xs = pprPrecStyleList p (listStyle xs) xs
+ pprList = pprPrecList 0
+ listStyle _ = ListStyle {
+ listStyleBegin = lparen,
+ listStyleEnd = rparen,
+ listStylePunct = comma,
+ listStyleDelimitEmpty = False,
+ listStyleDelimitSingleton = False,
+ listStyleJoiner = fsep
+ }
+
+data ListStyle = ListStyle {
+ listStyleBegin, listStyleEnd, listStylePunct :: Doc,
+ listStyleDelimitEmpty, listStyleDelimitSingleton :: Bool,
+ listStyleJoiner :: [Doc] -> Doc
+}
+
+-- | Conditionally add parens around the given 'Doc'
+parensIf :: Bool -> Doc -> Doc
+parensIf True doc = parens doc
+parensIf False doc = doc
+
+instance Ppr a => Ppr [a] where
+ pprPrec = pprPrecList
+
+instance Ppr a => Ppr (Maybe a) where
+ pprPrec _ Nothing = empty
+ pprPrec p (Just a) = pprPrec p a
+
+class Ppr a => IsInfix a where
+ isInfix :: a -> Bool
+ pprRight :: Int -> a -> Doc
+ pprRight p a =
+ if isInfix a
+ then pprPrec p a
+ else ppr a
+
+instance Ppr Doc where
+ ppr = id
+
+instance Ppr Int where
+ ppr = int
+
+-- Render a document in the preferred style, given a string continuation
+renderS :: Doc -> ShowS
+renderS doc rest = fullRender 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 = fullRender PageMode 80 1.1 each (putChar '\n')
+ where each (Chr c) io = putChar c >> io
+ each (Str s) io = putStr s >> io
+ each (PStr s) io = putStr s >> io
+
+-- Pretty-print, render and display in the preferred style
+printPpr :: Ppr a => a -> IO ()
+printPpr = printDoc . ppr
+
+showFromPpr :: Ppr a => Int -> a -> ShowS
+showFromPpr p t = renderS (pprPrec p t)
+
+pprFromShow :: Show a => Int -> a -> Doc
+pprFromShow p t = text (showsPrec p t "")
+
+liftEmpty :: (Doc -> Doc -> Doc) -> Doc -> Doc -> Doc
+liftEmpty joiner d1 d2
+ | isEmpty d1 = d2
+ | isEmpty d2 = d1
+ | otherwise = joiner d1 d2
+
+(>+>) :: Doc -> Doc -> Doc
+(>+>) = flip hang 2
+
+(>?>) :: Doc -> Doc -> Doc
+(>?>) = liftEmpty (>+>)
+
+infixr 5 >+>, >?>
+
diff --git a/src/Prec.hs b/src/Prec.hs
--- a/src/Prec.hs
+++ b/src/Prec.hs
@@ -10,6 +10,8 @@
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.
@@ -24,12 +26,20 @@
precOp "!=" = Left precEq
precOp (c:_)
| c `elem` "=<>|&$" = Left precEq
- | c `elem` "*/%" = Left precStar
+ | c `elem` "*×/%" = Left precStar
| c `elem` "+-" = Left precPlus
| c `elem` "^" = Right precCaret
| c `elem` "@" = Right precAt
| c `elem` "!~?" = Right precBang
-precOp _ = Left precApp
+ | otherwise = case generalCategory c of
+ CurrencySymbol -> Left precEq
+ MathSymbol -> Left precStar
+ DashPunctuation -> Left precPlus
+ OtherSymbol -> Left precPlus
+ ConnectorPunctuation -> Right precCaret
+ OtherPunctuation -> Right precAt
+ _ -> Left precEq -- defaulty
+precOp "" = Left precApp
precMin, precStart, precMax,
precCast, precCom, precDot, precSemi, precEq, precCaret, precArr,
diff --git a/src/Rename.hs b/src/Rename.hs
--- a/src/Rename.hs
+++ b/src/Rename.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE
+ FlexibleContexts,
FlexibleInstances,
GeneralizedNewtypeDeriving,
MultiParamTypeClasses,
@@ -21,6 +22,8 @@
getRenamingInfo, RenamingInfo(..),
) where
+import ErrorMessage
+
import Meta.Quasi
import Syntax hiding ((&))
import qualified Loc
@@ -53,20 +56,27 @@
savedCounter = renamed0
}
+-- | Generate a renamer error.
+renameError :: MessageV -> 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 String) a
+ 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 s = R $ do
- loc <- asks location
- fail $ if isBogus loc
- then s
- else show loc ++ ":\nname error: " ++ s
+ fail = renameError . [$msg| $words:1 |]
instance MonadWriter Module Renaming where
listen = R . listen . unR
@@ -77,11 +87,15 @@
ask = R (asks env)
local f = R . local (\cxt -> cxt { env = f (env cxt) }) . unR
-instance MonadError String Renaming where
- throwError = fail
+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 ()),
@@ -117,7 +131,7 @@
-- | Run a renaming computation
runRenaming :: Bool -> Loc -> RenameState -> Renaming a ->
- Either String (a, RenameState)
+ Either AlmsException (a, RenameState)
runRenaming nonTrivial loc saved action = do
(result, counter, md) <-
runRWST (unR action)
@@ -131,9 +145,10 @@
return (result, RenameState env' counter)
-- | Run a renaming computation
-runRenamingM :: Monad m =>
- Bool -> Loc -> RenameState -> Renaming a -> m (a, RenameState)
-runRenamingM = either fail return <$$$$> runRenaming
+runRenamingM :: AlmsMonad m =>
+ Bool -> Loc -> RenameState -> Renaming a ->
+ m (a, RenameState)
+runRenamingM = unTryAlms . return <$$$$> runRenaming
-- | Alias
type R a = Renaming a
@@ -188,8 +203,27 @@
-- | Generate an unbound name error
unbound :: Show a => String -> a -> R b
-unbound ns a = fail $ ns ++ " not in scope: `" ++ show a ++ "'"
+unbound ns a =
+ renameError [$msg| $words:ns not in scope: $show:a
. |]
+-- | Generate an error about a name declared twice
+repeated :: Show a => String -> a -> String -> [Loc] -> R b
+repeated what a inwhat locs =
+ renameError [$msg|
+ $words:what $show: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)
@@ -245,7 +279,7 @@
case envLookup prj qx e of
Right qx' -> return qx'
Left Nothing -> unbound what qx
- Left (Just m) -> unbound "module" m
+ Left (Just m) -> unbound "Module" m
-- | Look up something in the environment
getGeneric :: (Ord (f Raw), Show (f Raw)) =>
@@ -255,25 +289,25 @@
-- | Look up a variable in the environment
getVar :: QLid Raw -> R (QLid Renamed)
-getVar = getGeneric "variable" vars
+getVar = getGeneric "Variable" vars
-- | Look up a data constructor in the environment
getDatacon :: QUid Raw -> R (QUid Renamed)
-getDatacon = getGeneric "data constructor" datacons
+getDatacon = getGeneric "Data constructor" datacons
-- | Look up a variable in the environment
getTycon :: QLid Raw -> R (QLid Renamed)
-getTycon = getGeneric "type constructor" tycons
+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
+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
+getSig = liftM pull . getGenericFull "Signature" sigs
where
pull (J ps (qu, _, (m, e))) = (J ps qu, m, e)
@@ -282,12 +316,15 @@
getTyvar tv = do
e <- asks tyvars
case M.lookup tv e of
- Nothing -> fail $ "type variable not in scope: " ++ show tv
+ Nothing -> unbound "Type variable" tv
Just (tv', _, True) -> return tv'
- Just (_, loc, False) -> fail $
- "type variable not in scope: " ++ show tv ++ "\n" ++
- "NB: It was bound at " ++ show loc ++ " but nested declarations\n" ++
- "cannot see tyvars from their parent expression."
+ Just (_, loc, False) -> renameError [$msg|
+ Type variable $show:tv not in scope.
+
+ (It was bound at $show: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) =>
@@ -378,9 +415,8 @@
(llocs, mdT) <- listen $ mapM bindEach ats
case unique fst llocs of
Nothing -> return ()
- Just ((l, loc1), (_, loc2)) -> fail $
- "type `" ++ show l ++ "' declared twice in abstype group at " ++
- show loc1 ++ " and " ++ show loc2
+ Just ((l, loc1), (_, loc2)) ->
+ repeated "Type" l "abstype group" [loc1, loc2]
(ats', mdD) <-
steal $
inModule mdT $
@@ -428,9 +464,8 @@
(llocs, md) <- listen $ mapM bindEach tds
case unique fst llocs of
Nothing -> return ()
- Just ((l, loc1), (_, loc2)) -> fail $
- "type `" ++ show l ++ "' declared twice in type group at " ++
- show loc1 ++ " and " ++ show loc2
+ Just ((l, loc1), (_, loc2)) ->
+ repeated "Type" l "type group" [loc1, loc2]
inModule md $ mapM (liftM snd . renameTyDec Nothing) tds
renameTyDec :: Maybe (QExp Raw) -> TyDec Raw ->
@@ -439,7 +474,8 @@
renameTyDec mqe (N note (TdSyn l clauses)) = withLoc note $ do
case mqe of
Nothing -> return ()
- Just _ -> fail "BUG! can't rename QExp in context of type synonym"
+ 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
@@ -451,8 +487,8 @@
let tvs = tdParams td
case unique id tvs of
Nothing -> return ()
- Just (tv, _) -> fail $
- "type variable " ++ show tv ++ " repeated in type parameters"
+ Just (tv, _) ->
+ repeated "Type variable" tv "type parameters" []
(tvs', mdTvs) <- steal $ mapM bindTyvar tvs
inModule mdTvs $ do
mqe' <- gmapM renameQExp mqe
@@ -460,12 +496,12 @@
TdAbs _ _ variances qe -> do
qe' <- renameQExp qe
return (tdAbs l' tvs' variances qe')
- TdSyn _ _ -> fail "BUG! can't happen in Rename.renameTyDec"
+ TdSyn _ _ -> renameBug "renameTyDec" "unexpected TdSyn"
TdDat _ _ cons -> do
case unique fst cons of
Nothing -> return ()
- Just ((u, _), (_, _)) -> fail $
- "repeated constructor `" ++ show u ++ "' in type declaration"
+ 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')
@@ -508,8 +544,7 @@
ql' <- onlyInModule md $ getTycon ql
case unique id tvs of
Nothing -> return ()
- Just (tv, _) -> fail $
- "type variable `" ++ show tv ++ "' bound twice in `with type'"
+ 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' |]
@@ -521,20 +556,18 @@
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
+ MdTycon loc l _ -> mustFail loc "Type" l $ getTycon (J [] l)
+ MdVar loc l _ -> mustFail loc "Variable" l $ getVar (J [] l)
+ MdDatacon loc u _ -> mustFail loc "Constructor" u $ getDatacon (J [] u)
+ MdModule loc u _ _ -> mustFail loc "Structure" u $ getModule (J [] u)
+ MdSig loc u _ _ -> mustFail loc "Signature" u $ getSig (J [] u)
+ MdTyvar loc tv _ -> mustFail loc "Tyvar" tv $ getTyvar tv
where
mustFail loc kind which check = do
failed <- (False <$ check) `M.E.catchError` \_ -> return True
unless failed $ do
withLoc loc $
- fail $
- "signature contains repeated " ++ kind ++
- " `" ++ show which ++ "'"
+ repeated kind which "signature" []
sealWith :: Module -> R ()
sealWith md = case md of
@@ -555,20 +588,25 @@
tell (MdModule loc u u' md1')
MdSig _ u _ md2 -> do
(u', loc, (md1, _)) <- find "module type" sigs u
- let ctch body = body `catchError` \_ -> fail $
- "signature `" ++ show u ++ "' must match exactly"
+ let ctch body = body `catchError` \_ -> renameError
+ [$msg| In signature matching, signature
+ $qshow:u does not match exactly. |]
((), _ ) <- ctch $ steal $ onlyInModule md2 $ sealWith md1
((), md1') <- ctch $ steal $ onlyInModule md1 $ sealWith md2
tell (MdSig loc u u' md1')
- MdTyvar _ _ _ -> fail $ "signature can't declare type variable"
+ MdTyvar _ _ _ ->
+ renameBug "sealWith" "signature can’t declare type variable"
where
find what prj ident = do
m <- asks prj
case M.lookup ident m of
Just ident' -> return ident'
- Nothing -> fail $
- "structure missing " ++ what ++ " `" ++ show ident ++
- "' which is present in ascribed signature"
+ Nothing -> renameError $
+ [$msg|
+ In signature matching, structure is missing
+ $words:what $qshow:ident,
+ which is present in ascribed signature.
+ |]
-- | Rename a signature item and return the environment
-- that they bind
@@ -685,9 +723,8 @@
[$bnQ| $antiB:a |] -> $antifail
case unique (\(_,x,_,_) -> x) lxtes of
Nothing -> return ()
- Just ((l1,x,_,_),(l2,_,_,_)) -> fail $
- "variable `" ++ show x ++ "' bound twice in let rec at " ++
- show l1 ++ " and " ++ show l2
+ Just ((l1,x,_,_),(l2,_,_,_)) ->
+ repeated "Variable" x "let-rec" [l1, l2]
let bindEach rest (l,x,t,e) = withLoc l $ do
x' <- bindVar x
return ((l,x',t,e):rest)
@@ -747,9 +784,8 @@
tyvar loc1 tv = do
seen <- get
case M.lookup tv seen of
- Just loc2 -> fail $
- "type variable " ++ show tv ++ " bound twice in type pattern at " ++
- show loc1 ++ " and " ++ show loc2
+ Just loc2 ->
+ lift (repeated "Type variable" tv "type pattern" [loc1, loc2])
Nothing -> do
put (M.insert tv loc1 seen)
lift (bindTyvar tv)
@@ -813,9 +849,7 @@
var loc1 l = do
seen <- get
case M.lookup (Left l) seen of
- Just loc2 -> fail $
- "variable `" ++ show l ++ "' bound twice in pattern at " ++
- show loc1 ++ " and " ++ show loc2
+ Just loc2 -> lift (repeated "Variable" l "pattern" [loc1, loc2])
Nothing -> do
put (M.insert (Left l) loc1 seen)
lift (withLoc loc1 (bindVar l))
@@ -823,9 +857,7 @@
tyvar loc1 tv = do
seen <- get
case M.lookup (Right tv) seen of
- Just loc2 -> fail $
- "type variable " ++ show tv ++ " bound twice in pattern at " ++
- show loc1 ++ " and " ++ show loc2
+ Just loc2 -> lift (repeated "Type variable" tv "pattern" [loc1, loc2])
Nothing -> do
put (M.insert (Right tv) loc1 seen)
lift (bindTyvar tv)
diff --git a/src/Statics.hs b/src/Statics.hs
--- a/src/Statics.hs
+++ b/src/Statics.hs
@@ -45,8 +45,11 @@
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 Data.Data (Typeable, Data)
import Data.Generics (everywhere, mkT)
import Data.List (transpose)
@@ -192,9 +195,15 @@
-- | The type checking monad reads an environment, writes a module,
-- and keeps track of a gensym counter (currently unused).
-newtype TC m a = TC { unTC :: RWST Context Module Int m a }
- deriving (Functor, Monad)
+newtype TC m a = TC {
+ unTC :: RWST Context Module Int (ErrorT AlmsException m) a
+} deriving Functor
+instance Monad m => Monad (TC m) where
+ return = TC . return
+ m >>= k = TC (unTC m >>= unTC . k)
+ fail = let ?loc = bogus in typeError . Block . Words
+
instance Monad m => Applicative (TC m) where
pure = return
(<*>) = ap
@@ -208,20 +217,37 @@
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) => MessageV -> m a
+typeError msg = throwAlms (AlmsException RenamerPhase ?loc msg)
+
+-- | Indicate a type checker bug.
+typeBug :: AlmsMonad m => String -> String -> m a
+typeBug culprit msg = throwAlms (almsBug RenamerPhase bogus culprit msg)
+
-- | Like 'ask', but monadic
asksM :: MonadReader r m => (r -> m a) -> m a
asksM = (ask >>=)
-- | Run a type checking computation with the given initial state,
-- returning the result and the updated state
-runTC :: Monad m => S -> TC m a -> m (a, S)
+runTC :: 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 :: Monad m => S -> TC m a -> m (a, Module, S)
-runTCNew s action = do
+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
@@ -309,8 +335,7 @@
k -> TC m v
find k = asksM $ \cxt -> case cxt =..= k of
Just v -> return v
- Nothing -> fail $
- "BUG! type checker got unbound identifier: " ++ show k
+ 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) =>
@@ -322,34 +347,72 @@
---
-- | Raise a type error, with the dynamically-bound source location
-terr :: (?loc :: Loc, Monad m) => String -> m a
-terr = fail . (label ++)
- where label = if isBogus ?loc
- then "type error: "
- else show ?loc ++ ":\ntype error: "
+terr :: (?loc :: Loc, AlmsMonad m) => String -> m a
+terr = typeError . Words
-- | A type checking "assertion" raises a type error if the
-- asserted condition is false.
-tassert :: (?loc :: Loc, Monad m) =>
+tassert :: (?loc :: Loc, AlmsMonad m) =>
Bool -> String -> m ()
tassert True _ = return ()
tassert False s = terr s
+-- | A type checking "assertion" raises a type error if the
+-- asserted condition is false.
+tassert' :: (?loc :: Loc, AlmsMonad m) =>
+ Bool -> MessageV -> m ()
+tassert' True _ = return ()
+tassert' False m = typeError m
+
-- | A common form of type error: A got B where C expected
-tgot :: (?loc :: Loc, Monad m) =>
+tgot :: (?loc :: Loc, AlmsMonad m) =>
String -> Type -> String -> m a
-tgot who got expected = terr $ who ++ " got " ++ show got ++
- " where " ++ expected ++ " expected"
+tgot who got expected = typeError $
+ Flow [
+ Words who,
+ Words "got",
+ Quote (Printable got),
+ Words "where",
+ Words expected,
+ Words "expected."
+ ]
-- | Combination of 'tassert' and 'tgot'
-tassgot :: (?loc :: Loc, Monad m) =>
+tassgot :: (?loc :: Loc, AlmsMonad m) =>
Bool -> String -> Type -> String -> m ()
tassgot False = tgot
tassgot True = \_ _ _ -> return ()
+-- | Common message pattern involving text and table:
+terrtab :: (?loc :: Loc, AlmsMonad m) =>
+ [MessageH] -> [(String, [MessageH])] -> m a
+terrtab msg rows = typeError $
+ Stack Broken [
+ Flow msg,
+ Indent $ Table (map (second Flow) rows)
+ ]
+
+-- | Common message pattern involving text and table:
+tasstab :: (?loc :: Loc, AlmsMonad m) =>
+ Bool -> [MessageH] -> [(String, [MessageH])] -> m ()
+tasstab False = terrtab
+tasstab True = \_ _ -> return ()
+
+-- | Common message pattern, actual vs. expected
+terrexp :: (?loc :: Loc, AlmsMonad m) =>
+ [MessageH] -> [MessageH] -> [MessageH] -> m a
+terrexp msg actual expected =
+ terrtab msg [("actual:", actual), ("expected:", expected)]
+
+-- | Common message pattern, actual vs. expected
+tassexp :: (?loc :: Loc, AlmsMonad m) =>
+ Bool -> [MessageH] -> [MessageH] -> [MessageH] -> m ()
+tassexp False = terrexp
+tassexp True = \_ _ _ -> return ()
+
-- | Run a partial computation, and if it fails, substitute
-- the given failure message for the one generated
-(|!) :: (?loc :: Loc, Monad m) => Maybe a -> String -> m a
+(|!) :: (?loc :: Loc, AlmsMonad m) => Maybe a -> String -> m a
m |! s = case m of
Just r -> return r
_ -> terr s
@@ -378,27 +441,36 @@
return (tyApp tc' ts')
where
checkLength len =
- tassert (length ts == len) $
- "Type constructor " ++ show n ++ " applied to " ++
- show (length ts) ++ " arguments where " ++
- show len ++ " expected"
+ tassexp (length ts == len)
+ [ Words "Type constructor",
+ Quote (Showable n),
+ Words "got wrong number of parameters:" ]
+ [Showable (length ts)]
+ [Showable len]
checkBound quals ts' =
- tassert (all2 (\qlit t -> qualConst t <: qlit) quals ts') $
- "Type constructor " ++ show n ++
- " used at " ++ show (map (qRepresent . qualifier) ts') ++
- " where at most " ++ show quals ++ " is permitted"
+ tassexp (all2 (\qlit t -> qualConst t <: qlit) quals ts')
+ [ Words "Type constructor",
+ Quote (Showable n),
+ Words "used on higher qualifiers than permitted:" ]
+ [Showable (map (qRepresent . qualifier) ts')]
+ [Showable quals, Words "(or less)"]
tc [$ty| $quant:u '$tv . $t |] =
TyQu u tv <$> tc t
tc [$ty| mu '$tv . $t |] = do
case unfoldTyMu t of
(_, N _ (Syntax.TyVar tv')) | tv == tv' ->
- terr $ "Recursive type ‘" ++ show (Syntax.tyMu tv t) ++
- "’ is not contractive."
+ typeError $
+ "Recursive type is not contractive:" !:: Syntax.tyMu tv t
_ -> return ()
t' <- tc t
- tassert (qualConst t' == tvqual tv) $
- "Recursive type " ++ show (Syntax.tyMu tv t) ++ " qualifier " ++
- "does not match its own type variable."
+ tassert' (qualConst t' == tvqual tv) $
+ Flow [
+ Words "Recursive type",
+ Quote (Showable (Syntax.tyMu tv t)),
+ Words "has qualifier",
+ Quote (Showable (qualConst t')),
+ Words "which does not match its own type variable."
+ ]
return (TyMu tv t')
tc [$ty| $anti:a |] = $antifail
@@ -421,7 +493,7 @@
(t1:ts, clauses') <- liftM unzip . forM clauses $ \(N note ca) -> do
(xi', md) <- steal $ tcPatt t0 (capatt ca)
(ti, ei') <- inModule md $ tc (caexpr ca)
- checkSharing "match" (caexpr ca) md
+ checkSharing "match or let" (caexpr ca) md
return (ti, caClause xi' ei' <<@ note)
tr <- foldM (\ti' ti -> ti' \/? ti
|! "Mismatch in match/let: " ++ show ti ++
@@ -432,18 +504,19 @@
let bs = map dataOf bsN
(tfs, md) <- steal $ forM bs $ \b -> do
t' <- tcType (bntype b)
- tassert (syntacticValue (bnexpr b)) $
- "Not a syntactic value in let rec: " ++ show (bnexpr b)
- tassert (qualConst t' <: Qu) $
- "Affine type in let rec binding: " ++ show t'
+ 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 ->
- tassert (ta <: tf) $
- "Actual type " ++ show ta ++
- " does not agree with declared type " ++
- show tf ++ " in let rec")
+ tassexp (ta <: tf)
+ [Words "In let rec, actual type does not",
+ Words "agree with declared type:"]
+ [Showable ta]
+ [Showable tf])
tfs tas
(t2, e2') <- inModule md $ tc e2
let b's =
@@ -462,15 +535,15 @@
[$ex| fun ($x : $t) -> $e |] -> do
t' <- tcType t
(x', md) <- steal $ tcPatt t' x
- checkSharing "lambda" e md
+ checkSharing "function body" e md
(te, e') <- inModule md $ tc e
q <- getWorthiness e0
return (TyFun q t' te, [$ex|+ fun ($x' : $stx:t') -> $e' |])
[$ex| $_ $_ |] -> do
tcExApp tc e0
[$ex| fun '$tv -> $e |] -> do
- tassert (syntacticValue e) $
- "Not a syntactic value under type abstraction: " ++ show e0
+ 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
@@ -487,17 +560,20 @@
case t1' of
TyQu Exists tv t11' -> do
te' <- tapply (tyAll tv t11') t2'
- tassert (te <: te') $
- "Could not pack type " ++ show te ++
- " (abstracting " ++ show t2 ++
- ") to get " ++ show t1'
+ tasstab (te <: te')
+ [ Words "Could not pack existential:" ]
+ [ ("concrete type:", [Showable te]),
+ ("hiding:", [Showable t2]),
+ ("to get:", [Showable t1']) ]
return (t1', [$ex| Pack[$stx:t1']($stx:t2', $e') |])
- _ -> tgot "Pack[-]" t1' "ex(istential) type"
+ _ -> tgot "Pack[-]" t1' "existential type"
[$ex| ( $e1 : $t2 ) |] -> do
(t1, e1') <- tc e1
t2' <- tcType t2
- tassgot (t1 <: t2')
- "type ascription (:)" t1 (show t2')
+ tassexp (t1 <: t2')
+ [Words "Type ascription mismatch:"]
+ [Showable t1]
+ [Showable t2']
return (t2', e1')
[$ex| ( $e1 :> $t2 ) |] -> do
(t1, e1') <- tc e1
@@ -517,9 +593,15 @@
loop md0 = case md0 of
MdApp md1 md2 -> do loop md1; loop md2
MdValue (Var l) t ->
- tassert (qualConst t <: usage (J [] l) e) $
- "Affine variable " ++ show l ++ " : " ++
- show t ++ " duplicated in " ++ name ++ " body"
+ tassert' (qualConst t <: usage (J [] l) e) $
+ Flow [
+ Words "Affine variable",
+ Quote (Showable l),
+ Words "of type",
+ Quote (Showable t),
+ Words "duplicated in",
+ Words (name ++ ".")
+ ]
_ -> return ()
--
-- | What is the join of the qualifiers of all free variables
@@ -566,18 +648,24 @@
arrows t'@(view -> TyQu Forall _ _) ts = foralls t' ts
arrows (view -> TyFun _ ta tr) (t:ts) = do
b <- unifies [] t ta
- tassgot b "Application (operand)" t (show ta)
+ tassexp b
+ [Words "In application, operand type not in operator’s domain:"]
+ [Showable t]
+ [Showable ta]
arrows tr ts
arrows (view -> TyMu tv t') ts = arrows (tysubst tv (TyMu tv t') t') ts
- arrows t' _ = tgot "Application (operator)" t' "function type"
- unifies tvs ta tf =
- case tryUnify tvs ta tf of
- Just ts -> do
- ta' <- foldM tapply (foldr tyAll ta tvs) ts
- if (ta' <: tf)
- then return True
- else deeper
- Nothing -> deeper
+ arrows t' (t:_) =
+ terrexp
+ [Words "In application, operator is not a function:"]
+ [Showable t']
+ [Showable t, Words "-[...]> ..."]
+ 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
@@ -590,14 +678,17 @@
-- | Figure out the result type of a type application, given
-- the type of the function and the argument type
-tapply :: (?loc :: Loc, Monad m) =>
+tapply :: (?loc :: Loc, AlmsMonad m) =>
Type -> Type -> m Type
tapply (view -> TyQu Forall tv t1') t2 = do
- tassert (qualConst t2 <: tvqual tv) $
- "Type application cannot instantiate type variable " ++
- show tv ++ " with type " ++ show t2
+ tasstab (qualConst t2 <: tvqual tv)
+ [Words "Type application cannot instantiate type variable:"]
+ [("type variable:", [Showable tv]),
+ ("expected qualifier:", [Showable (tvqual tv)]),
+ ("type given:", [Showable t2]),
+ ("actual qualifier:", [Showable (qualifier t2)])]
return (tysubst tv t2 t1')
-tapply t1 _ = tgot "type application" t1 "(for)all type"
+tapply t1 _ = tgot "Type application" t1 "forall type"
-- Given the type of thing to match and a pattern, return
-- the type environment bound by that pattern.
@@ -616,8 +707,12 @@
-> return (params, Just arg, res)
(params, res)
-> return (params, Nothing, res)
- tassgot (t' <: tysubsts params ts res)
- "Pattern" t' ("constructor " ++ show u)
+ let te = tysubsts params ts res
+ tasstab (t' <: te)
+ [Words "Pattern got wrong type:"]
+ [("actual:", [Showable t']),
+ ("expected:", [Showable te]),
+ ("in pattern:", [Showable x0])]
case (mt, mx) of
(Nothing, Nothing) ->
return [$pa|+ $quid:u |]
@@ -625,11 +720,18 @@
let t1' = tysubsts params ts t1
x1' <- tcPatt t1' x1
return [$pa|+ $quid:u $x1' |]
- _ -> tgot "Pattern" t "wrong arity"
+ (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 -> tgot "Pattern" t' ("constructor " ++ show u)
+ | otherwise ->
+ terrtab
+ [Words "Pattern got wrong type:"]
+ [("type:", [Showable t']),
+ ("pattern:", [Showable x0])]
[$pa| ($x, $y) |] -> do
t' <- hnT t >>! mapBottom (tyApp tcTuple . replicate 2)
case t' of
@@ -658,9 +760,13 @@
t' <- hnT t >>! mapBottom (tyEx tv)
case t' of
TyQu Exists tve te -> do
- tassert (tvqual tve <: tvqual tv) $
- "Cannot bind existential tyvar " ++ show tv ++
- " to " ++ show tve
+ tasstab (tvqual tve <: tvqual tv)
+ [Words "Existential unpacking pattern cannot",
+ Words "instantiate type variable:"]
+ [("pattern type variable:", [Showable tv]),
+ ("expected qualifier:", [Showable (tvqual tv)]),
+ ("actual type variable:", [Showable tve]),
+ ("actual qualifier:", [Showable (tvqual tve)])]
let te' = tysubst tve (TyVar tv) te
x' <- tcPatt te' x
return [$pa| Pack('$tv, $x') |]
@@ -678,7 +784,7 @@
-- Given a list of type variables tvs, a type t in which tvs
-- may be free, and a type t', tries to substitute for tvs in t
-- to produce a type that *might* unify with t'
-tryUnify :: (?loc :: Loc, Monad m) =>
+tryUnify :: (?loc :: Loc, AlmsMonad m) =>
[TyVarR] -> Type -> Type -> m [Type]
tryUnify [] _ _ = return []
tryUnify tvs t t' =
@@ -686,13 +792,25 @@
Left s -> giveUp (s :: String)
Right (_, ts) -> return ts
where
- giveUp _ = terr $
- "\nCannot guess type" ++
- (if length tvs == 1 then " t1" else "s t1, .., t" ++ show (length tvs))
- ++ " such that\n " ++ showsPrec 10 t "" ++
- concat [ "[t" ++ show i ++ "/" ++ show tv ++ "]"
- | tv <- tvs | i <- [ 1.. ] :: [Integer] ] ++
- "\n >: " ++ show t'
+ giveUp _ = typeError $
+ Stack Broken [
+ Flow [
+ Words "In application, cannot find substitution for type",
+ Flow $ case tvs of
+ [tv] -> [Words "variable", Showable tv]
+ [tv1,tv2] -> [Words "variables",
+ Showable tv1,
+ Words "and",
+ Showable tv2]
+ _ -> [Words "variables",
+ Flow (map Showable tvs)],
+ Words "to unify types:"
+ ],
+ Indent $ Table [
+ ("actual:", Showable t'),
+ ("expected:", Showable t)
+ ]
+ ]
-- | Convert qualset representations from a list of all tyvars and
-- list of qualifier-significant tyvars to a set of type parameter
@@ -702,8 +820,8 @@
indexQuals name tvs qexp = do
qden <- qInterpretM qexp
numberQDenM unbound tvs qden where
- unbound tv = terr $ "unbound tyvar " ++ show tv ++
- " in qualifier list for type " ++ show name
+ unbound tv = typeError $
+ "unbound tyvar " ++ show tv ++ " in qualifier list for type" !:: name
-- BEGIN type decl checking
@@ -742,8 +860,8 @@
case tcNext tc of
Nothing -> return ()
Just clauses -> forM_ clauses $ \(tps, rhs) ->
- tassert (rhs /= tyPatToType (TpApp tc {tcNext = Nothing} tps)) $
- "Type synonym ‘" ++ show tc ++ "’ is not contractive."
+ tassert' (rhs /= tyPatToType (TpApp tc {tcNext = Nothing} tps)) $
+ "Recursive type synonym is not contractive:" !:: tc
tell (replaceTyCons tcs md')
return tds0
where
@@ -782,8 +900,11 @@
TdSyn name cs -> do
tc <- find (J [] name :: QLid R)
let nparams = length (fst (head cs))
- tassert (all ((==) nparams . length . fst) cs) $
- "all type operator clauses have the same number of parameters"
+ tassert' (all ((==) nparams . length . fst) cs) $
+ Flow [
+ Words "Not all type operator clauses have",
+ Words "the same number of parameters."
+ ]
(cs', quals, vqs) <- liftM unzip3 $ forM cs $ \(tps, rhs) -> do
rhs' <- tcType rhs
let vs1 = ftvVs rhs'
@@ -854,7 +975,7 @@
-- and a list of node values, returns a list of node values (or
-- fails if there's a cycle).
topSort :: forall node m a.
- (?loc :: Loc, Monad m, Ord node, Show node) =>
+ (?loc :: Loc, AlmsMonad m, Ord node, Show node) =>
(a -> (node, S.Set node)) -> [a] -> m [a]
topSort getEdge edges = do
(_, w) <- RWS.execRWST visitAll S.empty S.empty
@@ -865,8 +986,9 @@
visit :: node -> RWS.RWST (S.Set node) [a] (S.Set node) m ()
visit node = do
stack <- RWS.ask
- tassert (not (node `S.member` stack)) $
- "unproductive cycle in type definitions, via type " ++ show node
+ 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 ()
@@ -902,16 +1024,15 @@
tcTyPat :: Monad m => Syntax.TyPat R -> TC m TyPat
tcTyPat (N note (Syntax.TpVar tv var)) = do
let ?loc = getLoc note
- tassert (var == Invariant) $
- "type pattern variable " ++ show tv ++
- " cannot have a variance annotation"
+ tassert' (var == Invariant) $
+ "Type pattern variable " ++ show tv ++
+ "has a variance annotation:" !:: var
return (TpVar tv)
tcTyPat tp@[$tpQ| ($list:tps) $qlid:qu |] = do
let ?loc = _loc
tc <- find qu
- tassert (isNothing (tcNext tc)) $
- "type operator pattern `" ++ show tp ++
- "' cannot also be a type operator"
+ tassert' (isNothing (tcNext tc)) $
+ "Type operator pattern is also a type operator:" !:: tp
TpApp tc <$> mapM tcTyPat tps
tcTyPat [$tpQ| $antiP:a |] = $antifail
@@ -938,13 +1059,15 @@
[TyVar R] -> QLid R -> Type -> Module -> TC m ()
fibrate tvs ql t md = do
let Just tc = findTycon ql md
- tassert (isAbstractTyCon tc) $
- "with-type: cannot update concrete type constructor `" ++
- show ql
- tassert (length tvs == length (tcArity tc)) $
- "with-type: " ++ show (length tvs) ++
- " parameters for type " ++ show ql ++
- " which has " ++ show (length (tcArity tc))
+ tassert' (isAbstractTyCon tc) $
+ "Signature fibration (with-type) cannot update concrete" ++
+ "type constructor:" !:: ql
+ tasstab (length tvs == length (tcArity tc))
+ [Words "In signature fibration (with-type), wrong number",
+ Words "of parameters to type:"]
+ [("actual count:", [Showable (length tvs)]),
+ ("expected count:", [Showable (length (tcArity tc))]),
+ ("for type:", [Showable ql])]
let amap = ftvVs t
arity = map (\tv -> fromJust (M.lookup tv amap)) tvs
bounds = map tvqual tvs
@@ -998,21 +1121,26 @@
Patt R -> Maybe (Syntax.Type R) -> Expr R ->
TC m (Patt R, Maybe (Syntax.Type R), Expr R)
tcLet x mt e = do
- tassert (S.null (dtv x)) $
- "Cannot unpack existential in top-level binding"
+ 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) $
- "Declared type of top-level binding " ++ show x ++ " is not unlimited"
- tassert (te <: t') $
- "Declared type for top-level binding " ++ show x ++ " : " ++ show t' ++
- " is not subsumed by actual type " ++ show te
+ tassert' (qualConst t' == Qu) $
+ "Declared type of top-level binding is not unlimited" !:: x
+ tasstab (te <: t')
+ [Words "Mismatch in declared type for top-level binding:"]
+ [("actual:", [Showable te]),
+ ("expected:", [Showable t']),
+ ("in pattern:", [Showable x])]
return t'
Nothing -> do
- tassert (qualConst te == Qu) $
- "Type of top-level binding `" ++ show x ++ "' is not unlimited"
+ tasstab (qualConst te == Qu)
+ [Words "Type of top-level binding is not unlimited:"]
+ [("type:", [Showable te]),
+ ("qualifier:", [Showable (qualifier te)]),
+ ("in pattern:", [Showable x])]
return te
x' <- tcPatt t' x
return (x', Just (typeToStx t'), e')
@@ -1159,24 +1287,30 @@
let env = envify md1
tc = fromJust (env =..= name)
qualSet <- indexQuals name params quals
- tassert (length params == length (tcArity tc)) $
- "abstract-with-end: " ++ show (length params) ++
- " given for type " ++ show name ++
+ 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))
- tassert (all2 (<:) (tcArity tc) arity) $
- "abstract-with-end: declared arity for type " ++ show name ++
- ", " ++ show arity ++
- ", is more general than actual arity " ++ show (tcArity tc)
- tassert (tcQual tc <: qualSet) $
- "abstract-with-end: declared qualifier for type " ++ show name ++
- ", " ++ show qualSet ++
- ", is more general than actual qualifier " ++ show (tcQual tc)
+ tassexp (all2 (<:) (tcArity tc) arity)
+ [Words "In abstype declaration, declared arity for type",
+ Quote (Showable name),
+ Words "is more permissive than actual arity:"]
+ [Showable (tcArity tc)]
+ [Showable arity]
+ tassexp (tcQual tc <: qualSet)
+ [Words "In abstype declaration, declared qualifier for type",
+ Quote (Showable name),
+ Words "is more permissive than actual qualifier:"]
+ [Showable (tcQual tc)]
+ [Showable qualSet]
return $ abstractTyCon tc {
tcQual = qualSet,
tcArity = arity,
tcCons = ([], empty)
}
- _ -> terr "(BUG) Can't abstract non-datatypes"
+ _ -> typeBug "tcAbsTy" "Can’t do abstype with non-datatypes"
tell (replaceTyCons tcs (md1 `mappend` md2))
return (atds, ds')
@@ -1347,36 +1481,33 @@
MdApp md1 md2 -> do loop md1; loop md2
MdValue x t -> do
t' <- find (J [] x :: Ident R)
- tassgot (t' <: t)
- ("in signature matching, variable `"++show x++"'") t' (show t)
+ tassexp (t' <: t)
+ [Words "In signature matching, type mismatch for",
+ Quote (Showable x)]
+ [Showable t']
+ [Showable t]
MdTycon x tc -> do
tc' <- find (J [] x :: QLid R)
case varietyOf tc of
AbstractType -> do
- tassert (length (tcArity tc') == length (tcArity tc)) $
- "in signature matching, cannot match type definition for " ++
- show (tcName tc) ++ " because the actual number of type " ++
- "parameters (" ++ show (length (tcArity tc')) ++
- " does not match the expected number (" ++
- show (length (tcArity tc)) ++ "("
- tassert (all2 (<:) (tcArity tc') (tcArity tc)) $
- "in signature matching, cannot match type definition for " ++
- show (tcName tc) ++ " because actual variance " ++
- show (tcArity tc') ++
- " is less general than expected variance " ++
- show (tcArity tc)
- tassert (all2 (<:) (tcBounds tc') (tcBounds tc)) $
- "in signature matching, cannot match type definition for " ++
- show (tcName tc) ++ " because actual parameter bounds " ++
- show (tcBounds tc') ++
- " is less general than expected parameter bounds " ++
- show (tcBounds tc)
- tassert (tcQual tc' <: tcQual tc) $
- "in signature matching, cannot match type definition for " ++
- show (tcName tc) ++ " because actual qualifier " ++
- show (tcQual tc') ++
- " is less general than expected qualifier " ++
- show (tcQual tc)
+ let sigass assertion thing getter =
+ tassexp assertion
+ [Words "In signature matching, cannot match the",
+ Words "type definition for type",
+ Quote (Showable (tcName tc)),
+ Words "because the actual",
+ Words thing,
+ Words "does not match what is expected:"]
+ [Showable (getter tc')]
+ [Showable (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
diff --git a/src/Token.hs b/src/Token.hs
new file mode 100644
--- /dev/null
+++ b/src/Token.hs
@@ -0,0 +1,494 @@
+{-# 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/Util.hs b/src/Util.hs
--- a/src/Util.hs
+++ b/src/Util.hs
@@ -45,6 +45,7 @@
import Control.Arrow hiding (loop, (<+>))
import Control.Monad
import Control.Applicative (Applicative(..), (<$>), (<$), (<**>))
+import Text.ParserCombinators.Parsec (GenParser)
-- | Right-associative monadic fold
foldrM :: Monad m => (a -> b -> m a) -> a -> [b] -> m a
@@ -83,7 +84,7 @@
-- | Apply one function to the head of a list and another to the
-- tail
mapCons :: (a -> b) -> ([a] -> [b]) -> [a] -> [b]
-mapCons fh ft [] = []
+mapCons _ _ [] = []
mapCons fh ft (x:xs) = fh x : ft xs
-- | Map a function over only the first element of a list
@@ -221,3 +222,8 @@
gsequence = maybe (return Nothing) (liftM return)
gsequence_ = maybe (return ()) (>> return ())
+-- | Parsec parsers are Applicatives, which lets us write slightly
+-- more pleasant, non-monadic-looking parsers
+instance Applicative (GenParser a b) where
+ pure = return
+ (<*>) = ap