alms 0.4.9.1 → 0.4.10
raw patch · 32 files changed
+2060/−603 lines, 32 files
Files
- LICENSE +30/−21
- Makefile +2/−2
- README +5/−5
- TODO +0/−2
- alms.cabal +13/−6
- examples/ex60-popl-deposit.alms +3/−3
- examples/ex61-popl-AfArray.alms +7/−7
- examples/ex63-popl-CapArray.alms +9/−9
- examples/ex64-popl-CapLockArray.alms +4/−4
- examples/ex65-popl-Fractional.alms +8/−8
- examples/ex66-popl-RWLock.alms +41/−41
- examples/run-test.sh +1/−1
- lib/libbasis.alms +12/−0
- src/BasisUtils.hs +6/−5
- src/ErrorMessage.hs +116/−0
- src/Lexer.hs +116/−65
- src/Loc.hs +10/−4
- src/Main.hs +65/−39
- src/Makefile +2/−1
- src/Message/AST.hs +43/−0
- src/Message/Parser.hs +240/−0
- src/Message/Quasi.hs +90/−0
- src/Message/Render.hs +110/−0
- src/Meta/THHelpers.hs +0/−6
- src/Parser.hs +95/−23
- src/Ppr.hs +3/−131
- src/PprClass.hs +136/−0
- src/Prec.hs +12/−2
- src/Rename.hs +97/−65
- src/Statics.hs +283/−152
- src/Token.hs +494/−0
- src/Util.hs +7/−1
LICENSE view
@@ -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.+
Makefile view
@@ -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
README view
@@ -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
TODO view
@@ -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
alms.cabal view
@@ -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,
examples/ex60-popl-deposit.alms view
@@ -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
examples/ex61-popl-AfArray.alms view
@@ -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) =
examples/ex63-popl-CapArray.alms view
@@ -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) =
examples/ex64-popl-CapLockArray.alms view
@@ -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
examples/ex65-popl-Fractional.alms view
@@ -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"
examples/ex66-popl-RWLock.alms view
@@ -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
examples/run-test.sh view
@@ -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"
lib/libbasis.alms view
@@ -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
src/BasisUtils.hs view
@@ -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
+ src/ErrorMessage.hs view
@@ -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.+ <p>+ Details:+ <dl>+ <dt>who: <dd>$words:culprit+ <dt>what: <dd>$words:msg0+ <dt>where:<dd>$show:loc+ <dt>when: <dd>$show:phase+ </dl>+ <p>+ Please report to <exact><tov@ccs.neu.edu></exact>.+ |]++(!::) :: Show a => String -> a -> Message d+msg0 !:: thing = [$msg| $words:msg0 <q>$show:thing</q> |]+infix 1 !::++---+--- The AlmsMonad class for carrying alms errors+---++class Monad m => AlmsMonad m where+ throwAlms :: AlmsException -> m a+ catchAlms :: m a -> (AlmsException -> m a) -> m a+ unTryAlms :: m (Either AlmsException a) -> m a+ unTryAlms = (>>= either throwAlms return)++instance AlmsMonad IO where+ throwAlms = throwIO+ catchAlms = Control.Exception.catch++instance AlmsMonad (Either AlmsException) where+ throwAlms = Left+ catchAlms (Right a) _ = Right a+ catchAlms (Left e) k = k e++---+--- Instances+---++instance Ppr AlmsException where+ ppr (AlmsException phase loc msg0) =+ (text phaseString <+> locString <> colon)+ $$+ ppr (Indent msg0)+ where locString = if isBogus loc+ then empty+ else text "at" <+> text (show loc)+ phaseString = case phase of+ ParserPhase -> "Syntax error"+ RenamerPhase -> "Type error"+ StaticsPhase -> "Type error"+ DynamicsPhase -> "Run-time error"+ OtherError s -> s++instance Show AlmsException where showsPrec = showFromPpr++instance Exception AlmsException++instance Error AlmsException where+ strMsg = AlmsException (OtherError "Error") bogus . Block . Words
src/Lexer.hs view
@@ -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
src/Loc.hs view
@@ -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 "-" = "<stdin>"+ showFile s =+ let shown = show s+ in if shown == '"' : s ++ "\""+ then shown+ else s
src/Main.hs view
@@ -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
src/Makefile view
@@ -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)
+ src/Message/AST.hs view
@@ -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+
+ src/Message/Parser.hs view
@@ -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 "<exact>" *>+ (Chars <$> manyTill anyChar (tstring "</exact>"))++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+
+ src/Message/Quasi.hs view
@@ -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)+
+ src/Message/Render.hs view
@@ -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+
src/Meta/THHelpers.hs view
@@ -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
src/Parser.hs view
@@ -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
src/Ppr.hs view
@@ -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 >+>, >?>
+ src/PprClass.hs view
@@ -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 >+>, >?>+
src/Prec.hs view
@@ -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,
src/Rename.hs view
@@ -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: <q>$show:a</q>. |] +-- | 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 <q>$show:a</q>+ 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.+ <indent>+ (It was bound at $show:loc, but a nested declaration+ cannot see type variables from its parent expression.)+ </indent>+ |] -- | Get a new name for a variable binding bindGeneric :: (Ord ident, Show ident, Antible ident) =>@@ -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)
src/Statics.hs view
@@ -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
+ src/Token.hs view
@@ -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)+
src/Util.hs view
@@ -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