diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -50,7 +50,7 @@ $(RM) html -VERSION = 0.4.12 +VERSION = 0.5.0 DISTDIR = alms-$(VERSION) TARBALL = $(DISTDIR).tar.gz diff --git a/alms.cabal b/alms.cabal --- a/alms.cabal +++ b/alms.cabal @@ -1,5 +1,5 @@ Name: alms -Version: 0.4.12 +Version: 0.5.0 Copyright: 2010, Jesse A. Tov Cabal-Version: >= 1.8 License: BSD3 @@ -31,8 +31,10 @@ Flag editline Description: Enable line editing using the editline package - Default: True +Flag parsec3 + Description: Use version 3 of the parsec package + Flag readline Description: Enable line editing using the readline package Default: False @@ -47,7 +49,6 @@ syb >= 0.1, pretty >= 1, containers >= 0.1, - parsec == 2.*, mtl >= 1.1, filepath >= 1.1, network >= 2.2, @@ -69,6 +70,7 @@ Basis.Thread, BasisUtils, Coercion, + Compat, Dynamics, Env, ErrorMessage, @@ -121,4 +123,11 @@ if flag(editline) Build-Depends: editline >= 0.2.1 CPP-Options: -DUSE_READLINE=System.Console.Editline.Readline + + if flag(parsec3) + Build-Depends: parsec == 3.* + CPP-Options: -DPARSEC_VERSION=3 + else + Build-Depends: parsec == 2.* + CPP-Options: -DPARSEC_VERSION=2 diff --git a/examples/echoServer.alms b/examples/echoServer.alms --- a/examples/echoServer.alms +++ b/examples/echoServer.alms @@ -19,7 +19,7 @@ let rec acceptLoop['t] (sock: 't socket) (f: string -> string) (cap: 't listening) : unit = - let (Pack('s, clientsock, clientcap), cap) = accept sock cap in + let (('s, clientsock, clientcap), cap) = accept sock cap in putStrLn "Opened connection"; (Thread.fork :> (unit -o unit) -> Thread.thread) (fun () -> handleClient clientsock f clientcap; @@ -27,7 +27,7 @@ acceptLoop sock f cap let serve (port: int) (f: string -> string) = - let Pack('t, sock, cap) = socket () in + let ('t, sock, cap) = socket () in let cap = bind sock port cap in let cap = listen sock cap in acceptLoop sock f cap diff --git a/examples/ex03-poly-blame-error.alms b/examples/ex03-poly-blame-error.alms --- a/examples/ex03-poly-blame-error.alms +++ b/examples/ex03-poly-blame-error.alms @@ -5,7 +5,7 @@ let inc2 = fun y: int -> - let g = (ap :> all 'a 'b. ('a -o 'b) -> 'a -> 'b) + let g = (ap :> all 'a 'b. ('a -A> 'b) -> 'a -U> 'b) (fun z: int -> z + 1) in g (g y) (* g is used twice here *) diff --git a/examples/ex27-focusing-and-adoption.alms b/examples/ex27-focusing-and-adoption.alms --- a/examples/ex27-focusing-and-adoption.alms +++ b/examples/ex27-focusing-and-adoption.alms @@ -23,12 +23,12 @@ (n + 1, Cons (x, xs))) (0, Nil[`a]) xs -let snoc[`a] (x: `a) | (xs: `a list) : `a list = +let snoc[`a] (x: `a) |[a] (xs: `a list) : `a list = foldr (fun (x: `a) (xs: `a list) -> Cons (x, xs)) (Cons (x, Nil[`a])) xs let revAppN = - let rec loop[`a] (n: int) (xs: `a list) | (acc: `a list) + let rec loop[`a] (n: int) (xs: `a list) |[a] (acc: `a list) : `a list * `a list = match n with | 0 -> (acc, xs) @@ -41,55 +41,54 @@ let (_, acc) = revAppN (-1) xs Nil[`a] in acc -let swapN[`a] (ix: int) (y: `a) | (xs: `a list) +let swapN[`a] (ix: int) (y: `a) |[a] (xs: `a list) : `a * `a list = let (Cons(x, xs), acc) = revAppN ix xs Nil[`a] in let (xs, _) = revAppN (-1) acc (Cons (y, xs)) in (x, xs) -abstype ('t, `a) region qualifier A = Rgn of `a list - and ('t, `a) region1 qualifier A = Rgn1 of `a - and 't ptr qualifier U = Ptr of int -with - let newRgn[`a] () = - Pack[ex 't. ('t, `a) region] (unit, Rgn[unit] (Nil[`a])) - let freeRgn[`a,'t] (_: ('t, `a) region) = () +module Region : sig + type ('t, `a) region : A + type ('t, `a) region1 : A + type 't ptr - let mallocIn[`a,'t] (Rgn xs: ('t, `a) region) | (a: `a) - : 't ptr * ('t, `a) region = + val newRgn : unit -> ex 't. ('t,`a) region + val mallocIn : ('t,`a) region -> `a -o 't ptr * ('t,`a) region + val swap : ('t,`a) region -> 't ptr -o `a -o `a * ('t,`a) region + val malloc : unit -> ex 't. ('t,unit) region1 * 't ptr + val free : ('t,`a) region1 -> unit + val adopt : ('t1,`a) region -> ('t2,`a) region1 -o 't2 ptr -o + 't1 ptr * ('t1,`a) region + val focus : ('t,`a) region -> 't ptr -o + ex 't1. ('t1,`a) region1 * 't1 ptr * + (('t1,`a) region1 -o ('t,`a) region) +end = struct + type ('t, `a) region = `a list + type ('t, `a) region1 = `a + type 't ptr = int + + let newRgn () = Nil + + let freeRgn _ = () + + let mallocIn (xs: `a list) (a: `a) = let (ix, xs) = length xs in - (Ptr['t] ix, Rgn['t] (snoc a xs)) - let swap[`a,'t] (Rgn xs: ('t, `a) region) | - (Ptr ix: 't ptr) (x: `a) - : `a * ('t, `a) region = + (ix, snoc a xs) + + let swap (xs: `a list) (ix: 't ptr) (x: `a) = let (y, xs) = swapN ix x xs in - (y, Rgn['t] xs) + (y, xs) - let malloc () = - Pack[ex 't. ('t, unit) region1 * 't ptr] - (unit, Rgn1[unit] (), Ptr[unit] 0) - let swap1[`a,`b,'t] (Rgn1 x: ('t, `a) region1) | - (_: 't ptr) (y: `b) - : `a * ('t, `b) region1 = - (x, Rgn1['t] y) - let free[`a, 't] (_: ('t, `a) region1) = () + let malloc () = ((), 0) - let adopt[`a,'t1,'t2] (rgn: ('t1, `a) region) | - (Rgn1 x: ('t2, `a) region1) - (_: 't2 ptr) - : 't1 ptr * ('t1, `a) region = + let swap1 (x: `a) _ (y: `b) = (x, y) + + let free _ = () + + let adopt (rgn: `a list) (x: `a) _ = mallocIn rgn x - let focus[`a,'t] - (Rgn xs: ('t, `a) region) | - (Ptr ix: 't ptr) - : ex 't1. ('t1, `a) region1 * 't1 ptr * - (('t1, `a) region1 -o ('t, `a) region) = - let (Cons (x, xs), acc) = revAppN ix xs Nil[`a] in - Pack[ex 't1. ('t1, `a) region1 * 't1 ptr * - (('t1, `a) region1 -o ('t, `a) region)] - (unit, Rgn1[unit] x, Ptr[unit] 0, - fun (Rgn1 y: (unit, `a) region1) -> - let (xs, _) = revAppN (-1) acc (Cons (y, xs)) in - Rgn['t] xs) + let focus (xs: `a list) (ix: 't ptr) = + let (Cons (x, xs), acc) = revAppN ix xs Nil in + (x, 0, fun (y: `a) -> fst (revAppN (-1) acc (Cons (y, xs)))) end diff --git a/examples/ex28-focusing-and-adoption.alms b/examples/ex28-focusing-and-adoption.alms --- a/examples/ex28-focusing-and-adoption.alms +++ b/examples/ex28-focusing-and-adoption.alms @@ -11,7 +11,7 @@ (n + 1, Cons (x, xs))) (0, Nil[`a]) xs -let snoc[`a] (x: `a) | (xs: `a list) : `a list = +let snoc[`a] (x: `a) |[a] (xs: `a list) : `a list = foldr (fun (x: `a) (xs: `a list) -> Cons (x, xs)) (Cons (x, Nil[`a])) xs @@ -25,7 +25,7 @@ | xs -> (acc, xs) in loop -let swapN[`a] (ix: int) (y: `a) | (xs: `a list) +let swapN[`a] (ix: int) (y: `a) |[a] (xs: `a list) : `a * `a list = let (Cons(x, xs), acc) = revAppN ix xs Nil[`a] in let (xs, _) = revAppN (-1) acc (Cons (y, xs)) in diff --git a/examples/ex63-popl-CapArray.alms b/examples/ex63-popl-CapArray.alms --- a/examples/ex63-popl-CapArray.alms +++ b/examples/ex63-popl-CapArray.alms @@ -4,9 +4,9 @@ type ('a,'b) array type 'b cap : A - val new : int → 'a → ∃'b. ('a,'b) array * '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 get : ('a,'b) array → int → 'b cap → 'a × 'b cap val dirtyGet : ('a,'b) array → int → 'a val size : ('a,'b) array → int diff --git a/lib/libbasis.alms b/lib/libbasis.alms --- a/lib/libbasis.alms +++ b/lib/libbasis.alms @@ -142,6 +142,7 @@ | Some y -> Cons(y, xs') | None -> xs') Nil + xs let revApp[`c] (xs : `c list) (ys : `c list) = let cons (x : `c) (acc : `c list) = Cons (x, acc) in foldl cons ys xs diff --git a/src/Basis.hs b/src/Basis.hs --- a/src/Basis.hs +++ b/src/Basis.hs @@ -113,9 +113,9 @@ -= (read :: String -> Double), -- Strings - fun "explode" -: [$ty| string -> int list |] + fun "explode" -: [$ty| string -> char list |] -= map char2integer, - fun "implode" -: [$ty| int list -> string |] + fun "implode" -: [$ty| char list -> string |] -= map integer2char, fun "^" -: [$ty| string -> string -> string |] -= ((++) :: String -> String -> String), @@ -131,9 +131,9 @@ -= (print :: Value -> IO ()), -- I/O - fun "putChar" -: [$ty| int -> unit |] + fun "putChar" -: [$ty| char -> unit |] -= putChar . integer2char, - fun "getChar" -: [$ty| unit -> int |] + fun "getChar" -: [$ty| unit -> char |] -= \() -> fmap char2integer getChar, fun "flush" -: [$ty| unit -> unit |] -= \() -> IO.hFlush IO.stdout, @@ -168,7 +168,7 @@ -= (\r -> do v <- readIORef (unRef r) return (r, v)), - fun "<-" -: [$ty| all `a. `a ref -> `a -o `a |] + fun "<-" -: [$ty| all `a. `a ref -> `a -> `a |] -= (\r v -> do atomicModifyIORef (unRef r) (\v' -> (v, v'))), fun "<-!" -: [$ty| all `a `b. `a aref -> diff --git a/src/Basis/Channel/Haskell.hs b/src/Basis/Channel/Haskell.hs --- a/src/Basis/Channel/Haskell.hs +++ b/src/Basis/Channel/Haskell.hs @@ -6,7 +6,7 @@ -- -- Maintainer : tov@ccs.neu.edu -- Stability : experimental --- Portability : somewhat portable? +-- Portability : GHC 6-7 -- -- This module provides synchronous channels. Unlike the channels in -- 'Control.Concurrent.Chan', which are unbounded queues on which @@ -45,7 +45,7 @@ -- with another. In particular, we can write code like this: -- -- @ - -- 'Control.Exception.block' $ do + -- 'Control.Exception.mask_' $ do -- msg <- 'readChan' c -- 'writeIORef' r msg -- @ @@ -113,11 +113,13 @@ ) where import Control.Concurrent.MVar hiding ( modifyMVar ) -import Control.Exception import Control.Monad import Data.IORef import System.IO.Unsafe ( unsafeInterleaveIO ) +import Control.Exception ( finally, onException ) +import Compat ( mask ) + --- --- Amortized O(1) queues --- @@ -196,7 +198,7 @@ getWriters (WQ q) = dequeue empty q clear :: IO a -> IORef (Maybe b) -> IO a -clear io r = block $ io `finally` writeIORef r Nothing +clear io r = mask $ \_ -> io `finally` writeIORef r Nothing -- | Make a new channel. newChan :: IO (Chan a) @@ -355,7 +357,7 @@ Just a -> do r' <- newIORef (Just a') confirm' <- newEmptyMVar - _ <- block $ do + _ <- mask $ \_ -> do putMVar confirm () commit (WQ ((r', confirm') <| writers)) return $ do @@ -585,7 +587,7 @@ loop [] e = return (e, Success (Success (), [])) loop (a:as) e = do case getReaders e of - r :< readers -> block $ do + r :< readers -> mask $ \_ -> do maybereader <- readIORef r case maybereader of Just reader -> do @@ -609,64 +611,49 @@ --- Helpful MVar stuff --- -saveBlock :: IO (IO a -> IO a) -saveBlock = do - b <- blocked - case b of - True -> return block - False -> return unblock - modifyMVar :: MVar a -> (a -> IO (a, b)) -> IO b -modifyMVar m io = do - restore <- saveBlock - block $ do - a <- takeMVar m - (a',b) <- restore (io a) - `onException` putMVar m a - putMVar m a' - return b +modifyMVar m io = mask $ \restore -> do + a <- takeMVar m + (a',b) <- restore (io a) + `onException` putMVar m a + putMVar m a' + return b -- Control.Concurrent.MVar doesn't have this, but it's pretty useful -- for implementing non-blocking operations. tryModifyMVar :: MVar a -> (a -> IO (a, TryResult b)) -> IO (TryResult b) -tryModifyMVar m io = do - restore <- saveBlock - block $ do - maybea <- tryTakeMVar m - case maybea of - Just a -> do - (a',b) <- restore (io a) - `onException` putMVar m a - putMVar m a' - return b - Nothing -> - return WouldBlock +tryModifyMVar m io = mask $ \restore -> do + maybea <- tryTakeMVar m + case maybea of + Just a -> do + (a',b) <- restore (io a) + `onException` putMVar m a + putMVar m a' + return b + Nothing -> + return WouldBlock transactMVar :: MVar a -> (a -> (a -> IO ()) -> IO b) -> IO b -transactMVar m io = do - restore <- saveBlock - block $ do - a <- takeMVar m - r <- newIORef a - restore (io a (writeIORef r)) - `finally` (readIORef r >>= putMVar m) +transactMVar m io = mask $ \restore -> do + a <- takeMVar m + r <- newIORef a + restore (io a (writeIORef r)) + `finally` (readIORef r >>= putMVar m) {- tryTransactMVar :: MVar a -> (a -> (a -> IO ()) -> IO (TryResult b)) -> IO (TryResult b) -tryTransactMVar m io = do - restore <- saveBlock - block $ do - maybea <- tryTakeMVar m - case maybea of - Just a -> do - r <- newIORef a - restore (io a (writeIORef r)) - `finally` (readIORef r >>= putMVar m) - Nothing -> - return WouldBlock +tryTransactMVar m io = mask $ \restore -> do + maybea <- tryTakeMVar m + case maybea of + Just a -> do + r <- newIORef a + restore (io a (writeIORef r)) + `finally` (readIORef r >>= putMVar m) + Nothing -> + return WouldBlock -} diff --git a/src/Coercion.hs b/src/Coercion.hs --- a/src/Coercion.hs +++ b/src/Coercion.hs @@ -87,7 +87,7 @@ exBVar (lid "x") build b recs (view -> TyQu Exists tv t) (view -> TyQu Exists tv' t') = do let recs' = M.insert (tv, tv') Nothing (shadow [tv] [tv'] recs) - body <- build b recs' t t' >>! instContract + body <- instContract `liftM` build b recs' t t' let tv'' = freshTyVar tv (ftv (tv, tv')) tstx = typeToStx' t tstx' = typeToStx' t' diff --git a/src/Compat.hs b/src/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Compat.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE + TemplateHaskell #-} +-- | Compatibility layer for different GHC and library versions +module Compat ( + mask, newQuasi, +) where + +import Language.Haskell.TH + +import Language.Haskell.TH.Quote +import qualified Control.Exception + +mask :: ((IO a -> IO a) -> IO b) -> IO b +mask = $(do + let name s = mkName ("Control.Exception." ++ s) + var = varE . name + recover + [| \action -> do + b <- $(var "blocked") + let restore = if b then $(var "block") + else $(var "unblock") + $(var "block") (action restore) |] + (do reify (name "mask") + [| \action -> $(var "mask") (\restore -> action restore) |])) + +newQuasi :: String -> QuasiQuoter +newQuasi name = $(do + let quasiQuoter = conE 'QuasiQuoter + arity (AppT (AppT ArrowT _) t') = 1 + arity t' + arity _ = 0 :: Int + DataConI _ ty _ _ <- reify 'QuasiQuoter + [| let qf cat _ = fail $ "Quasiquoter ‘" ++ name ++ + "’ does not support " ++ cat + q2 = $quasiQuoter (qf "expressions") (qf "patterns") in + $(if arity ty == 4 + then [| q2 (qf "types") (qf "declarations") |] + else [| q2 |]) |]) + + diff --git a/src/ErrorST.hs b/src/ErrorST.hs --- a/src/ErrorST.hs +++ b/src/ErrorST.hs @@ -51,9 +51,10 @@ liftST_ newUndo unST (handler e) -runST :: Error e => (forall s. ST s e a) -> Either e a +runST :: (Error e, MonadError e m) => (forall s. ST s e a) -> m a runST block = - Super.runST (evalStateT (runErrorT (unST (transaction block))) (return ())) + either throwError return $ + Super.runST (evalStateT (runErrorT (unST (transaction block))) (return ())) -- | Run something directly in the underlying ST monad liftST :: Error e => Super.ST s a -> ST s e a diff --git a/src/Lexer.hs b/src/Lexer.hs --- a/src/Lexer.hs +++ b/src/Lexer.hs @@ -11,7 +11,7 @@ lolli, arrow, funbraces, lambda, forall, exists, mu, qualbox, - qualU, qualA, + qualU, qualA, qdisj, qconj, opP, -- * Token parsers from Parsec @@ -23,6 +23,7 @@ ) where import Prec +import Util import Data.Char import Text.ParserCombinators.Parsec @@ -182,16 +183,25 @@ arrow :: T.TokenEnd st => CharParser st () arrow = reservedOp "->" <|> reservedOp "→" --- | The left part of the $-[_]>$ operator +-- | The left part of the $-_>$ operator funbraceLeft :: T.TokenEnd st => CharParser st () -funbraceLeft = try (symbol "-[") >> return () +funbraceLeft = try (symbol "-") >> return () --- | The right part of the $-[_]>$ operator +-- | The right part of the $-_>$ operator funbraceRight :: T.TokenEnd st => CharParser st () -funbraceRight = try (symbol "]>") >> return () +funbraceRight = try (symbol ">") >> return () +-- | The left part of the $-[_]>$ operator +oldFunbraceLeft :: T.TokenEnd st => CharParser st () +oldFunbraceLeft = try (symbol "-[") >> return () + +-- | The right part of the $-[_]>$ operator +oldFunbraceRight :: T.TokenEnd st => CharParser st () +oldFunbraceRight = try (symbol "]>") >> return () + funbraces :: T.TokenEnd st => CharParser st a -> CharParser st a -funbraces = between funbraceLeft funbraceRight +funbraces = liftM2 (<|>) (between oldFunbraceLeft oldFunbraceRight) + (between funbraceLeft funbraceRight) -- | The left part of the $|[_]$ annotation qualboxLeft :: T.TokenEnd st => CharParser st () @@ -242,6 +252,14 @@ -- | Qualifier @A@ (not reserved) qualA :: T.TokenEnd st => CharParser st () qualA = reserved "A" + +-- | Infix operator for qualifier disjunction +qdisj :: T.TokenEnd st => CharParser st () +qdisj = reservedOp "," <|> reservedOp "\\/" <|> reservedOp "⋁" + +-- | Infix operator for qualifier conjunction +qconj :: T.TokenEnd st => CharParser st () +qconj = reservedOp "/\\" <|> reservedOp "⋀" -- | Is the string an uppercase identifier? (Special case: @true@ and -- @false@ are consider uppercase.) diff --git a/src/Makefile b/src/Makefile --- a/src/Makefile +++ b/src/Makefile @@ -9,8 +9,10 @@ Message/*.hs Meta/*.hs HSBOOT_SRC = Syntax/*.hs-boot -HCOPTS = -W -Wall -O0 $(EDITING) $(NOWARN) +HCOPTS = -W -Wall -O0 $(EDITING) $(PARSEC) $(NOWARN) $(IMPARR) EDITING = -DUSE_READLINE=System.Console.Editline.Readline +PARSEC = -DPARSEC_VERSION=3 +# IMPARR = -DANNOTATION_PRINTING_RULE=Rule0 NOWARN = -fno-warn-unused-do-bind -fno-warn-orphans $(EXE) $(EXE)-%: $(SRC) @@ -18,6 +20,7 @@ $(EXE)-%: GHC = ghc-$* $(EXE)-6.8.%: EDITING = -DUSE_READLINE=System.Console.Readline +$(EXE)-6.%: PARSEC = -DPARSEC_VERSION=2 clean: $(RM) $(HS_SRC:.hs=.hi) $(HS_SRC:.hs=.o) diff --git a/src/Message/Quasi.hs b/src/Message/Quasi.hs --- a/src/Message/Quasi.hs +++ b/src/Message/Quasi.hs @@ -12,6 +12,7 @@ import Message.AST import Message.Parser +import Meta.THHelpers import PprClass import Util @@ -21,9 +22,7 @@ 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" +msg = (newQuasi "msg") { quoteExp = parseMessageQ >=> msgAstToExpQ } msgAstToExpQ :: Message d -> ExpQ msgAstToExpQ msg0 = do diff --git a/src/Meta/Quasi.hs b/src/Meta/Quasi.hs --- a/src/Meta/Quasi.hs +++ b/src/Meta/Quasi.hs @@ -73,29 +73,31 @@ pa, ty, ex, dc, me, prQ, tdQ, atQ, caQ, bnQ, qeQ, tpQ, seQ, sgQ :: QuasiQuoter -ex = mkQuasi parseExpr -dc = mkQuasi parseDecl -ty = mkQuasi parseType -me = mkQuasi parseModExp -pa = mkQuasi parsePatt -prQ = mkQuasi parseProg -tdQ = mkQuasi parseTyDec -atQ = mkQuasi parseAbsTy -caQ = mkQuasi parseCaseAlt -bnQ = mkQuasi parseBinding -qeQ = mkQuasi parseQExp -tpQ = mkQuasi parseTyPat -seQ = mkQuasi parseSigExp -sgQ = mkQuasi parseSigItem +ex = mkQuasi "ex" parseExpr +dc = mkQuasi "dc" parseDecl +ty = mkQuasi "ty" parseType +me = mkQuasi "me" parseModExp +pa = mkQuasi "pa" parsePatt +prQ = mkQuasi "prQ" parseProg +tdQ = mkQuasi "tdQ" parseTyDec +atQ = mkQuasi "atQ" parseAbsTy +caQ = mkQuasi "caQ" parseCaseAlt +bnQ = mkQuasi "bnQ" parseBinding +qeQ = mkQuasi "qeQ" parseQExp +tpQ = mkQuasi "tpQ" parseTyPat +seQ = mkQuasi "seQ" parseSigExp +sgQ = mkQuasi "sgQ" parseSigItem mkQuasi :: forall stx note. (Data (note Raw), Data (stx Raw), LocAst (N (note Raw) (stx Raw)), Data (note Renamed), Data (stx Renamed), LocAst (N (note Renamed) (stx Renamed))) => + String -> (forall i. Id i => P (N (note i) (stx i))) -> QuasiQuoter -mkQuasi parser = QuasiQuoter qast qast where +mkQuasi name parser = (newQuasi name) { quoteExp = qast, quotePat = qast } + where qast s = join $ parseQuasi s $ \iflag lflag -> diff --git a/src/Meta/THHelpers.hs b/src/Meta/THHelpers.hs --- a/src/Meta/THHelpers.hs +++ b/src/Meta/THHelpers.hs @@ -1,4 +1,5 @@ {-# LANGUAGE + CPP, DeriveDataTypeable, RankNTypes, TemplateHaskell, @@ -6,6 +7,8 @@ module Meta.THHelpers ( -- * Simplified TH quasiquote th, + -- * For initializing quasiquoters + newQuasi, -- * Generic expression/pattern AST construction ToSyntax(..), -- * Miscellany @@ -14,6 +17,7 @@ import Lexer (lid, uid) import Util +import Compat (newQuasi) import Data.Generics (Typeable, Data, everything, mkQ) import Language.Haskell.TH @@ -36,9 +40,7 @@ -- | The quasiquoter for building TH expressions th :: QuasiQuoter -th = QuasiQuoter qexp qpat where - qexp s = parseHs s >>= hsToExpQ - qpat _ = fail "Quasiquoter `hs' does not support patterns" +th = (newQuasi "th") { quoteExp = parseHs >=> hsToExpQ } -- | Don't allow HsOr to the left of HsApp: hsApp :: HsAst -> HsAst -> HsAst diff --git a/src/Parser.hs b/src/Parser.hs --- a/src/Parser.hs +++ b/src/Parser.hs @@ -397,7 +397,7 @@ (choice [ tyArr <$ arrow, tyLol <$ lolli, - funbraces (tyFun <$> qExpp), + funbraces (tyFun <$> (antiblep <|> Just <$> qExpp)), tybinopp (Right precArr) ]) (typepP precStart) | p == precSemi @@ -801,8 +801,8 @@ qExpp :: Id i => P (QExp i) qExpp = "qualifier expression" @@ qexp where - qexp = addLoc $ qeDisj <$> sepBy1 qterm (reservedOp "\\/") - qterm = addLoc $ qeConj <$> sepBy1 qfact (reservedOp "/\\") + qexp = addLoc $ qeDisj <$> sepBy1 qterm qdisj + qterm = addLoc $ qeConj <$> sepBy1 qfact qconj qfact = addLoc $ parens qexp <|> qatom qatom = addLoc $ qeLit Qu <$ qualU @@ -1007,24 +1007,24 @@ -- Zero or more of (pat:typ, ...), (), or tyvar, recognizing '|' -- to introduce affine arrows afargsp :: Id i => P (Bool, Type i -> Type i, Expr i -> Expr i) -afargsp = loop tyArr where - loop arrcon0 = do - arrcon <- option arrcon0 $ choice - [ tyFun <$> qualbox qExpp, +afargsp = choice + [ do (tvt, tve) <- tyargp + (b, ft, fe) <- afargsp + return (b, tvt . ft, tve . fe), + do arrcon <- arrconp + (b, ft, fe) <- vargp arrcon + if b + then return (b, ft, fe) + else do + (b', fts, fes) <- afargsp + return (b', ft . fts, fe . fes), + return (False, id, id) ] + where + arrconp = option tyArr $ choice + [ tyFun . Just <$> qualbox qExpp, do reservedOp "|" return tyLol ] - choice - [ do (tvt, tve) <- tyargp - (b, ft, fe) <- loop arrcon - return (b, tvt . ft, tve . fe), - do (b, ft, fe) <- vargp arrcon - if b - then return (b, ft, fe) - else do - (b', fts, fes) <- loop arrcon - return (b', ft . fts, fe . fes), - return (False, id, id) ] -- One or more of (pat:typ, ...), (), tyvar argsp1 :: Id i => P (Bool, Expr i -> Expr i) diff --git a/src/Ppr.hs b/src/Ppr.hs --- a/src/Ppr.hs +++ b/src/Ppr.hs @@ -75,13 +75,13 @@ instance Ppr (Type i) where -- pprPrec p (TyFun q t1 t2) + ppr [$ty| $t1 -> $t2 |] + = prec precArr $ + sep [ ppr1 t1, text "->" <+> pprRight t2 ] ppr [$ty| $t1 -[$q]> $t2 |] = prec precArr $ sep [ ppr1 t1, - pprArr (view q) <+> pprRight t2 ] - where pprArr (QeLit Qu) = text "->" - pprArr (QeLit Qa) = text "-o" - pprArr _ = text "-[" <> ppr0 q <> text "]>" + text "-" <> ppr0 q <> text ">" <+> pprRight t2 ] ppr t@[$ty| ($list:ts) $qlid:n |] | Just doc <- pprInfix unfoldType t = doc @@ -131,8 +131,8 @@ [] -> ppr Qu [qe] -> ppr qe _ -> prec precPlus $ - fsep $ - intersperse (text "\\/") $ + hcat $ + intersperse (text ",") $ map ppr1 qes ppr [$qeQ| $qconj:qes |] = case qes of [] -> ppr Qa diff --git a/src/Rename.hs b/src/Rename.hs --- a/src/Rename.hs +++ b/src/Rename.hs @@ -80,6 +80,10 @@ m >>= k = R (unR m >>= unR . k) fail = renameError . [$msg| $words:1 |] +instance Applicative Renaming where + pure = return + (<*>) = ap + instance MonadWriter Module Renaming where listen = R . listen . unR tell = R . tell @@ -755,11 +759,11 @@ [$ty| '$tv |] -> do tv' <- getTyvar tv return [$ty|+ '$tv' |] - [$ty| $t1 -[$qe]> $t2 |] -> do - t1' <- renameType t1 - qe' <- renameQExp qe - t2' <- renameType t2 - return [$ty|+ $t1' -[$qe']> $t2' |] + [$ty| $t1 -[$opt:mqe]> $t2 |] -> do + t1' <- renameType t1 + mqe' <- gmapM renameQExp mqe + t2' <- renameType t2 + return [$ty|+ $t1' -[$opt:mqe']> $t2' |] [$ty| $quant:u '$tv. $t |] -> do (tv', md) <- steal $ bindTyvar tv t' <- inModule md $ renameType t @@ -902,8 +906,8 @@ ftvList t0 = case t0 of [$ty| ($list:ts) $qlid:_ |] -> ftvList ts [$ty| '$tv |] -> [tv] - [$ty| $t1 -[$qe]> $t2 |] -> - ftvList t1 `List.union` ftvList qe `List.union` ftvList t2 + [$ty| $t1 -[$opt:mqe]> $t2 |] -> + ftvList t1 `List.union` ftvList mqe `List.union` ftvList t2 [$ty| $quant:_ '$tv. $t |] -> List.delete tv (ftvList t) [$ty| mu '$tv. $t |] -> List.delete tv (ftvList t) [$ty| $anti:a |] -> $antierror diff --git a/src/Statics.hs b/src/Statics.hs --- a/src/Statics.hs +++ b/src/Statics.hs @@ -3,7 +3,6 @@ DeriveDataTypeable, FlexibleContexts, FlexibleInstances, - GeneralizedNewtypeDeriving, ImplicitParams, MultiParamTypeClasses, ParallelListComp, @@ -51,6 +50,7 @@ import Control.Monad.RWS as RWS import Control.Monad.Error as Error +import System.IO (hPutStrLn, stderr) import Data.Data (Typeable, Data) import Data.Generics (everywhere, mkT) import Data.List (transpose, tails) @@ -63,6 +63,8 @@ pP a b = unsafePerformIO (print a) `seq` b pM :: (Show a, Monad m) => a -> m () pM a = if pP a True then return () else fail "wibble" +ioM :: Monad m => IO a -> m () +ioM a = if unsafePerformIO a `seq` True then return () else fail "wibble" -- The kind of names we're using. type R = Renamed @@ -198,13 +200,16 @@ -- and keeps track of a gensym counter (currently unused). 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 . [$msg| $words:1 |] +instance Monad m => Functor (TC m) where + fmap = liftM + instance Monad m => Applicative (TC m) where pure = return (<*>) = ap @@ -395,17 +400,21 @@ -- | Check type for closed-ness and and defined-ness, and add info tcType :: (?loc :: Loc, Monad m) => Syntax.Type R -> TC m Type -tcType = tc where - tc :: Monad m => Syntax.Type R -> TC m Type - tc [$ty| '$tv |] = do +tcType stxtype0 = do + t <- tc iaeInit stxtype0 + return t + where + tc :: Monad m => CurrentImpArrRule -> Syntax.Type R -> TC m Type + tc iae [$ty| '$tv |] = do return (TyVar tv) - tc [$ty| $t1 -[$q]> $t2 |] = do - TyFun <$> qInterpretM q - <*> tcType t1 - <*> tcType t2 - tc [$ty| ($list:ts) $qlid:n |] = do - ts' <- mapM tc ts + tc iae [$ty| $t1 -[$opt:mq]> $t2 |] = do + qd <- iaeInterpret iae mq + t1' <- tc (iaeLeft iae) t1 + t2' <- tc (iaeRight iae qd t1') t2 + return (TyFun qd t1' t2') + tc iae [$ty| ($list:ts) $qlid:n |] = do tc' <- find n + ts' <- zipWithM (tc . iaeUnder iae) (tcArity tc') ts checkLength (length (tcArity tc')) checkBound (tcBounds tc') ts' return (tyApp tc' ts') @@ -422,14 +431,14 @@ qualifiers than permitted: |] ([$msg| $1 |] (map (qRepresent . qualifier) ts')) [$msg| $quals (or less) |] - tc [$ty| $quant:u '$tv . $t |] = - TyQu u tv <$> tc t - tc t0@[$ty| mu '$tv . $t |] = do + tc iae [$ty| $quant:u '$tv . $t |] = + TyQu u tv <$> tc iae t + tc iae t0@[$ty| mu '$tv . $t |] = do case unfoldTyMu t of (_, N _ (Syntax.TyVar tv')) | tv == tv' -> typeError [$msg| Recursive type is not contractive: $t0 |] _ -> return () - t' <- tc t + t' <- tc iae t let actqual = qualConst t' expqual = tvqual tv tassert (actqual == expqual) @@ -441,7 +450,7 @@
in type:
$5:t0 |] return (TyMu tv t') - tc [$ty| $anti:a |] = $antifail + tc _ [$ty| $anti:a |] = $antifail -- | Type check an A expression tcExpr :: Monad m => Expr R -> TC m (Type, Expr R) @@ -465,8 +474,8 @@ checkSharing "match or let" (caexpr ca) md return (ti, caClause xi' ei' <<@ note) tr <- foldM (\ti' ti -> case ti' \/? ti of - Just tr' -> return tr' - Nothing -> typeError [$msg| + Right tr' -> return tr' + Left (_ :: String) -> typeError [$msg| Mismatch in branches of match or let. Cannot unify: