packages feed

alms 0.4.12 → 0.5.0

raw patch · 29 files changed

+475/−278 lines, 29 filesdep ~parsec

Dependency ranges changed: parsec

Files

Makefile view
@@ -50,7 +50,7 @@ 	$(RM) html  -VERSION = 0.4.12+VERSION = 0.5.0 DISTDIR = alms-$(VERSION) TARBALL = $(DISTDIR).tar.gz
alms.cabal view
@@ -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
examples/echoServer.alms view
@@ -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
examples/ex03-poly-blame-error.alms view
@@ -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 *)
examples/ex27-focusing-and-adoption.alms view
@@ -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
examples/ex28-focusing-and-adoption.alms view
@@ -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
examples/ex63-popl-CapArray.alms view
@@ -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
lib/libbasis.alms view
@@ -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
src/Basis.hs view
@@ -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 ->
src/Basis/Channel/Haskell.hs view
@@ -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 -}
src/Coercion.hs view
@@ -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'
+ src/Compat.hs view
@@ -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 |]) |])++
src/ErrorST.hs view
@@ -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
src/Lexer.hs view
@@ -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.)
src/Makefile view
@@ -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)
src/Message/Quasi.hs view
@@ -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
src/Meta/Quasi.hs view
@@ -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 ->
src/Meta/THHelpers.hs view
@@ -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
src/Parser.hs view
@@ -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)
src/Ppr.hs view
@@ -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
src/Rename.hs view
@@ -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
src/Statics.hs view
@@ -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 @@                 <dt>in type:            <dd>$5:t0               </dl> |]     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:           <ul>             <li>$ti@@ -842,16 +851,15 @@         if or changed           then loop md'           else return (tcs, md')-   in do-     (tcs, md') <- loop stub-     forM_ tcs $ \tc -> do-       case tcNext tc of-         Nothing      -> return ()-         Just clauses -> forM_ clauses $ \(tps, rhs) ->-           tassert (rhs /= tyPatToType (TpApp tc {tcNext = Nothing} tps)) $-             "Recursive type synonym is not contractive:" !:: tc-     tell (replaceTyCons tcs md')-     return tds0+  (tcs, md') <- loop stub+  forM_ tcs $ \tc -> do+    case tcNext tc of+      Nothing      -> return ()+      Just clauses -> forM_ clauses $ \(tps, rhs) -> do+        tassert (rhs /= tyPatToType (TpApp tc {tcNext = Nothing} tps)) $+          "Recursive type synonym is not contractive:" !:: tc+  tell (replaceTyCons tcs md')+  return tds0   where     allocStub name params = do       ix <- newIndex@@ -1001,7 +1009,7 @@     _      -> S.empty   `S.union` S.unions (map tyConsOfType ts) tyConsOfType [$ty| '$_ |]              = S.empty-tyConsOfType [$ty| $t1 -[$_]> $t2 |]   =+tyConsOfType [$ty| $t1 -[$opt:_]> $t2 |]   =   tyConsOfType t1 `S.union` tyConsOfType t2 tyConsOfType [$ty| $quant:_ '$_. $t |] = tyConsOfType t tyConsOfType [$ty| mu '$_. $t |]       = tyConsOfType t@@ -1138,6 +1146,7 @@                </dl> |] (qRepresent (qualifier te))       return te   x' <- tcPatt t' x+  -- ioM (hPutStrLn stderr (show te))   return (x', Just (typeToStx' t'), e')  -- | Run a computation in the context of a module open declaration
src/Syntax/Decl.hs-boot view
@@ -10,12 +10,14 @@ import Syntax.Notable import Syntax.Ident (Id, Fv, Dv) -import Data.Data (Data)+import Data.Data (Data, Typeable1)  data DeclNote i data Decl' i type Decl i = N (DeclNote i) (Decl' i) +instance Typeable1 DeclNote+instance Typeable1 Decl' instance Id i => Data (DeclNote i) instance Id i => Data (Decl' i) instance Locatable (DeclNote i)
src/Syntax/Ident.hs-boot view
@@ -1,10 +1,12 @@ module Syntax.Ident where -import Data.Data (Data)+import Data.Data (Data, Typeable1)  class Id i  data TyVar i +instance Typeable1 TyVar instance Data i => Data (TyVar i) instance Id i   => Ord (TyVar i)+instance Id i   => Eq (TyVar i)
src/Syntax/POClass.hs view
@@ -5,6 +5,7 @@  import Util +import Control.Monad.Error import qualified Data.Set as S  -- | Partial orders.@@ -19,29 +20,29 @@   -- | Takes a boolean parameter, and does join if true   --   and meet if false.  This sometimes allows us to exploit duality   --   to define both at once.-  ifMJ :: Monad m => Bool -> a -> a -> m a+  ifMJ :: (Error e, MonadError e m) => Bool -> a -> a -> m a   ifMJ True  x y = return (x \/ y)   ifMJ False x y = return (x /\ y)    -- | Partial join returns in a monad, in case join DNE-  (\/?) :: Monad m => a -> a -> m a+  (\/?) :: (Error e, MonadError e m) => a -> a -> m a   (\/?)  = ifMJ True    -- | Partial meet returns in a monad, in case meet DNE-  (/\?) :: Monad m => a -> a -> m a+  (/\?) :: (Error e, MonadError e m) => a -> a -> m a   (/\?)  = ifMJ False    -- | Total join   (\/)  :: a -> a -> a   -- | Total meet   (/\)  :: a -> a -> a-  x \/ y = fromJust (x \/? y)-  x /\ y = fromJust (x /\? y)+  x \/ y = either error id (x \/? y)+  x /\ y = either error id (x /\? y)    -- | The order relation (derived)   (<:)  :: a -> a -> Bool-  x <: y = Just x == (x /\? y)-        || Just y == (x \/? y)+  x <: y = either (const False :: String -> Bool) ((==) x) (x /\? y)+        || either (const False :: String -> Bool) ((==) y) (x \/? y)    -- | The complement of the order relation (derived)   (/<:) :: a -> a -> Bool@@ -54,13 +55,13 @@ bigVee :: (Bounded a, PO a) => [a] -> a bigVee  = foldr (\/) minBound -bigVeeM :: (Monad m, Bounded a, PO a) => [a] -> m a+bigVeeM :: (Error e, MonadError e m, Bounded a, PO a) => [a] -> m a bigVeeM  = foldrM (\/?) minBound  bigWedge :: (Bounded a, PO a) => [a] -> a bigWedge  = foldr (/\) maxBound -bigWedgeM :: (Monad m, Bounded a, PO a) => [a] -> m a+bigWedgeM :: (Error e, MonadError e m, Bounded a, PO a) => [a] -> m a bigWedgeM  = foldrM (/\?) maxBound  instance Ord a => PO (S.Set a) where@@ -72,7 +73,7 @@   Nothing \/? b       = return b   a       \/? Nothing = return a -  Just a  /\? Just b  = return (a /\? b)+  Just a  /\? Just b  = liftM Just (a /\? b)   Nothing /\? _       = return Nothing   _       /\? Nothing = return Nothing
src/Syntax/Type.hs view
@@ -42,7 +42,7 @@ data Type' i   = TyApp  (QLid i) [Type i]   | TyVar  (TyVar i)-  | TyFun  (QExp i) (Type i) (Type i)+  | TyFun  (Maybe (QExp i)) (Type i) (Type i)   | TyQu   Quant (TyVar i) (Type i)   | TyMu   (TyVar i) (Type i)   | TyAnti Anti@@ -99,10 +99,10 @@ tyAf           = tyNulOp "A"  tyArr         :: Type i -> Type i -> Type i-tyArr          = tyFun minBound+tyArr          = tyFun Nothing  tyLol         :: Type i -> Type i -> Type i-tyLol          = tyFun maxBound+tyLol          = tyFun (Just maxBound)  infixr 8 `tyArr`, `tyLol` @@ -115,8 +115,10 @@       putStrLn $ show n ++ " {"       mapM_ (dumpType (i + 2)) ps       putStrLn (replicate i ' ' ++ "}")-    TyFun q dom cod -> do-      putStrLn $ "-[" ++ maybe "ANTI" show (qInterpretM q) ++ "]> {"+    TyFun mq dom cod -> do+      putStrLn $ case mq of+        Just q  -> "-[" ++ maybe "ANTI" show (qInterpretM q) ++ "]> {"+        Nothing -> "-> {"       dumpType (i + 2) dom       dumpType (i + 2) cod       putStrLn (replicate i ' ' ++ "}")
src/Type.hs view
@@ -1,6 +1,7 @@ -- | The internal representation of types, created by the type checker --   from the syntactic types in 'Syntax.Type'. {-# LANGUAGE+      CPP,       DeriveDataTypeable,       DeriveFunctor,       ViewPatterns,@@ -47,6 +48,8 @@   vtAppTc, isBotType,   -- ** Unfolds   vtFuns, vtQus,+  -- * Implicit arrow annotations+  CurrentImpArrRule, ImpArrRule(..),   -- * Re-exports   module Syntax.Ident,   module Syntax.Kind,@@ -692,24 +695,58 @@ typeToStx'  = typeToStx tyNames0  -- | Represent a type value as a syntactic type, for printing; renames---   so that scope is apparent, since internal renaming may result int+--   so that scope is apparent, since internal renaming may result in --   different identifiers that print the same typeToStx :: TyNames -> Type -> Stx.Type Renamed-typeToStx f = loop (S.empty, M.empty) where-  loop ren t0 = case t0 of+typeToStx tns = typeToStxRule tns (iaeInit :: CurrentImpArrPrintingRule)++#ifdef ANNOTATION_RULE+type CurrentImpArrRule = ANNOTATION_RULE+#else+type CurrentImpArrRule = Rule4+#endif++#ifdef ANNOTATION_PRINTING_RULE+type CurrentImpArrPrintingRule = ANNOTATION_PRINTING_RULE+#else+type CurrentImpArrPrintingRule = CurrentImpArrRule+#endif++class ImpArrRule a where+  iaeInit      :: a+  iaeLeft      :: a -> a+  iaeRight     :: a -> QDen (TyVar Renamed) -> Type -> a+  iaeImplied   :: a -> QDen (TyVar Renamed)+  iaeInterpret :: Monad m =>+                  a -> Maybe (QExp Renamed) -> m (QDen (TyVar Renamed))+  iaeRepresent :: a -> QDen (TyVar Renamed) -> Maybe (QExp Renamed)+  iaeUnder     :: a -> Variance -> a+  --+  iaeLeft _           = iaeInit+  iaeRight iae _ _    = iae+  iaeImplied _        = minBound+  iaeInterpret iae    = maybe (return (iaeImplied iae)) qInterpretM+  iaeRepresent iae actual+    | actual == iaeImplied iae = Nothing+    | otherwise                = Just (qRepresent actual)+  iaeUnder _ _        = iaeInit++-- | Turns annotated arrows into implicit arrows where possible+typeToStxRule :: ImpArrRule iae => TyNames -> iae -> Type -> Stx.Type Renamed+typeToStxRule f iae0 = loop (S.empty, M.empty) iae0 where+  loop ren iae t0 = case t0 of     TyVar tv      -> Stx.tyVar (maybe tv id (M.lookup tv (snd ren)))-    TyFun q t1 t2 -> Stx.tyFun (qRepresent q) (loop ren t1) (loop ren t2)-    TyApp tc ts _ -> Stx.tyApp (bestName f tc) (map (loop ren) ts)-    {--        (fmap (\ql -> lid ("[" ++ show (tcId tc) ++ "]" ++ unLid ql))-              (tcName tc)) -        (map (loop ren) ts)-    -}-    TyQu qu tv t1 -> Stx.tyQu qu tv' (loop ren' t1)+    TyFun q t1 t2 -> Stx.tyFun (iaeRepresent iae q)+                               (loop ren (iaeLeft iae) t1)+                               (loop ren (iaeRight iae q t1) t2)+    TyApp tc ts _ -> Stx.tyApp+                       (bestName f tc)+                       (zipWith (loop ren . iaeUnder iae) (tcArity tc) ts)+    TyQu qu tv t1 -> Stx.tyQu qu tv' (loop ren' iae t1)       where (tv', ren') = fresh tv ren-    TyMu tv t1    -> Stx.tyMu tv' (loop ren' t1)+    TyMu tv t1    -> Stx.tyMu tv' (loop ren' iae t1)       where (tv', ren') = fresh tv ren-  fresh tv (seen, remap) = +  fresh tv (seen, remap) =     let tv' = if S.member (unLid (tvname tv)) seen                 then freshTyVar tv $                        M.keysSet remap `S.union`@@ -718,6 +755,72 @@      in (tv', (S.insert (unLid (tvname tv')) seen,                M.insert tv tv' remap)) +-- | Print all arrow annotations explicitly+data Rule0 = Rule0++instance ImpArrRule Rule0 where+  iaeInit                = Rule0+  iaeRepresent _ actual  = Just (qRepresent actual)++-- | Annotation ‘U’ is implicit for unlabeled arrows.+data Rule1 = Rule1++instance ImpArrRule Rule1 where+  iaeInit        = Rule1++newtype Rule2 = Rule2 { unRule2 :: QDen (TyVar Renamed) }++-- | Implicit annotation is lub of qualifiers of prior curried+--   arguments.  Explicit annotations have no effect on subsequent+--   arrows.+instance ImpArrRule Rule2 where+  iaeInit      = Rule2 minBound+  iaeRight iae _ t = Rule2 (unRule2 iae \/ qualifier t)+  iaeImplied   = unRule2++-- | Like 'Rule2', but explicit annotations reset the qualifier to+--   themselves for subsequent arrows.+newtype Rule3 = Rule3 { unRule3 :: QDen (TyVar Renamed) }++instance ImpArrRule Rule3 where+  iaeInit      = Rule3 minBound+  iaeRight iae actual t+    | unRule3 iae == actual = Rule3 (unRule3 iae \/ qualifier t)+    | otherwise             = Rule3 (actual \/ qualifier t)+  iaeImplied   = unRule3++-- | Like 'Rule3', but we arrow the implicit qualifer into covariant+--   type constructors.+newtype Rule4 = Rule4 { unRule4 :: QDen (TyVar Renamed) }++instance ImpArrRule Rule4 where+  iaeInit      = Rule4 minBound+  iaeRight iae actual t+    | unRule4 iae == actual = Rule4 (unRule4 iae \/ qualifier t)+    | otherwise             = Rule4 (actual \/ qualifier t)+  iaeImplied   = unRule4+  iaeUnder iae Covariant    = iae+  iaeUnder _   _            = iaeInit++-- | Like 'Rule4', but we carry the implicit quantifier into ALL type+--   constructors and only use it when we arrive at an arrow in a+--   positive position wrt the surrounding arrow.+data Rule5+  = Rule5 {+      unRule5 :: !(QDen (TyVar Renamed)),+      r4Var   :: !Variance+    }++instance ImpArrRule Rule5 where+  iaeInit      = Rule5 minBound 1+  iaeRight iae actual t+    | unRule5 iae == actual = Rule5 (unRule5 iae \/ qualifier t) 1+    | otherwise             = Rule5 (actual \/ qualifier t) 1+  iaeImplied iae+    | r4Var iae == 1 = unRule5 iae+    | otherwise      = minBound+  iaeUnder iae var          = Rule5 (unRule5 iae) (var * r4Var iae)+ tyPatToStx' :: TyPat -> Stx.TyPat Renamed tyPatToStx'  = tyPatToStx tyNames0 @@ -957,6 +1060,7 @@                             ppr (qRepresent                                  (denumberQDen                                   (map qDenOfTyVar tvs) (tcQual tc)))+      ps :: Ppr a => [a] -> [Doc]       ps tvs = [ ppr var <> pprPrec (precApp + 1) tv                | tv <- tvs                | var <- tcArity tc ]
src/TypeRel.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE+      FlexibleContexts,       GeneralizedNewtypeDeriving,       ParallelListComp,       PatternGuards,@@ -27,6 +28,7 @@ import Viewable  import qualified Control.Monad.Reader as CMR+import Control.Monad.Error import Data.Generics (Data, everywhere, mkT, extT) import Data.Monoid import qualified Data.Map as M@@ -171,25 +173,21 @@ env1 = Field tcsEnv1 (\tcs e -> tcs { tcsEnv1 = e }) env2 = Field tcsEnv2 (\tcs e -> tcs { tcsEnv2 = e }) -lift :: (CMR.MonadTrans t, Monad m) => m a -> t m a-lift  = CMR.lift--runUT  :: forall s a m. Monad m =>+runUT  :: forall s a m. MonadError String m =>           (forall t. UT s t a) -> S.Set TyVarR -> m a runUT m set =-  either fail return $-    runST $ do-      seen   <- newTransSTRef M.empty-      supply <- newSTRef [ f | f <- tvalphabet-                         , f Qu `S.notMember` set-                         , f Qa `S.notMember` set ]-      CMR.runReaderT m TCS {-        tcsSeen   = seen,-        tcsSupply = supply,-        tcsLevel  = 1,-        tcsEnv1   = M.empty,-        tcsEnv2   = M.empty-      }+  runST $ do+    seen   <- newTransSTRef M.empty+    supply <- newSTRef [ f | f <- tvalphabet+                       , f Qu `S.notMember` set+                       , f Qa `S.notMember` set ]+    CMR.runReaderT m TCS {+      tcsSeen   = seen,+      tcsSupply = supply,+      tcsLevel  = 1,+      tcsEnv1   = M.empty,+      tcsEnv2   = M.empty+    }  getVar :: TyVarR -> Field s t -> UT s t (Maybe (UVar t)) getVar tv field = CMR.asks (M.lookup tv . get field)@@ -221,7 +219,7 @@             if isBotType lower               then if upper == tyUn || upper == tyAf then lower else upper               else lower-          else fail $+          else throwError $             "Unification cannot solve:\n" ++             show lower ++ " <: " ++ show upper     | (_, (_, ref)) <- refs ]@@ -292,7 +290,7 @@ -- pM = lift . unsafeIOToST . print -- pM = const $ return () -subtype :: Monad m =>+subtype :: MonadError String m =>            Int -> [TyVarR] -> Type -> [TyVarR] -> Type ->            m ([Type], [Type]) subtype limit uvars1 t1i uvars2 t2i =@@ -388,7 +386,7 @@       _ -> giveUp t u     --     giveUp t u = -      fail $+      throwError $         "Got type `" ++ show t ++ "' where type `" ++         show u ++ "' expected"     --@@ -406,6 +404,7 @@         | tj       <- ts         | uj       <- us ]     --+    -- XXX This is woefully insufficient     subkind qd1 qd2 orElse =       if qd1 <: qd2 then return () else do         (m1, m2) <- getUVars@@ -423,7 +422,7 @@             -> lowerBoundUVar ref (tyTop qlit)           _ -> orElse -jointype :: Monad m => Int -> Bool -> Type -> Type -> m Type+jointype :: MonadError String m => Int -> Bool -> Type -> Type -> m Type jointype limit b t1i t2i =   liftM clean $ runUT (cmp (b, True) t1i t2i) (alltv (t1i, t2i))   where@@ -485,7 +484,7 @@         cmp m t (tysubst tvu u u1)       -- Failure       _ ->-        fail $+        throwError $           "Could not " ++ (if direction then "join" else "meet") ++           " types `" ++ show t ++           "' and `" ++ show u ++ "'"@@ -499,7 +498,7 @@           -1 -> revCmp m tj uj           _  -> if tj == uj                   then return tj-                  else fail $+                  else throwError $                     "Could not unify types `" ++ show tj ++                     "' and `" ++ show uj ++ "'"       | var      <- arity@@ -546,7 +545,8 @@ instance PO Type where   t1 <: t2     = runEither (const False) (const True)                            (subtype 100 [] t1 [] t2)-  ifMJ b t1 t2 = jointype 100 b t1 t2+  ifMJ b t1 t2 = runEither (throwError . strMsg) return+                           (jointype 100 b t1 t2)  subtypeTests, joinTests, uvarsTests :: T.Test @@ -915,14 +915,14 @@   t1 \/! t2 = Left (t1, t2)   t1 /\! t2 = Right (t1, t2)   Left  (t1, t2) ==! t =-    T.assertEqual (show t1 ++ " \\/ " ++ show t2 ++ " = " ++ show t)-                  (Just t) (t1 \/? t2)+    tassertSuccess (show t1 ++ " \\/ " ++ show t2 ++ " = " ++ show t)+                   t (t1 \/? t2)   Right (t1, t2) ==! t =-    T.assertEqual (show t1 ++ " /\\ " ++ show t2 ++ " = " ++ show t)-                  (Just t) (t1 /\? t2)+    tassertSuccess (show t1 ++ " /\\ " ++ show t2 ++ " = " ++ show t)+                   t (t1 /\? t2)   t1 !/\ t2 =-    T.assertEqual (show t1 ++ " /\\ " ++ show t2 ++ " DNE")-                  Nothing (t1 /\? t2)+    tassertFailure (show t1 ++ " /\\ " ++ show t2 ++ " DNE")+                   (t1 /\? t2)   infix 2 ==!   infix 4 \/!, /\!, !/\   a = tvUn "a"; b = tvUn "b"; c = tvAf "c"; d = tvAf "d"@@ -997,8 +997,8 @@       ==! (noU, noU, TyVar e, noA)   , tyRecv (TyVar c) .*. tyRecv (TyVar c) !>:     tyRecv (TyVar e) .*. tyRecv (TyVar f)-  , T.assertEqual "'<c `supertype` '<d = ERROR"-      Nothing (subtype 100 [c] (TyVar c) [d] (TyVar d))+  , tassertFailure "'<c `supertype` '<d = ERROR"+                   (subtype 100 [c] (TyVar c) [d] (TyVar d))   , tyFollow (TyVar a) (TyVar b) >:!     tyFollow tyUnit (tyRecv tyInt .:.                      TyMu e (tyFollow tyUnit (tyRecv tyInt .:.@@ -1016,25 +1016,32 @@   t1 <:! t2 = Left (t1, t2)   t1 >:! t2 = Right (t1, t2)   Left (t1, t2) ==! (ta, tb, tc, td) =-    T.assertEqual (show t1 ++ " `subtype` " ++ show t2)-      (Right ([ta, tb, tc, td], []))-      (runEither Left Right $ subtype 100 set t1 [] t2)+    tassertSuccess (show t1 ++ " `subtype` " ++ show t2)+                   ([ta, tb, tc, td], [])+                   (subtype 100 set t1 [] t2)   Right (t1, t2) ==! (ta, tb, tc, td) =-    T.assertEqual (show t1 ++ " `supertype` " ++ show t2)-      (Right ([], [ta, tb, tc, td]))-      (runEither Left Right $ subtype 100 [] t2 set t1)+    tassertSuccess (show t1 ++ " `supertype` " ++ show t2)+                   ([], [ta, tb, tc, td])+                   (subtype 100 [] t2 set t1)   t1 !<: t2 =-    T.assertEqual (show t1 ++ " `subtype` " ++ show t2 ++ " = ERROR")-                  Nothing (subtype 100 set t1 [] t2)+    tassertFailure (show t1 ++ " `subtype` " ++ show t2 ++ " = ERROR")+                   (subtype 100 set t1 [] t2)   t1 !>: t2 =-    T.assertEqual (show t1 ++ " `supertype` " ++ show t2 ++ " = ERROR")-                  Nothing (subtype 100 [] t2 set t1)+    tassertFailure (show t1 ++ " `supertype` " ++ show t2 ++ " = ERROR")+                   (subtype 100 [] t2 set t1)   infix 2 ==!   infix 4 <:!, !<:, >:!, !>:   noU = tyBot; noA = tyBot   set = [a, b, c, d]   a   = tvUn "a"; b = tvUn "b"; c = tvAf "c"; d = tvAf "d"   e   = tvAf "e"; f = tvAf "f"++tassertSuccess :: (Eq a, Show a) =>+                  String -> a -> Either String a -> T.Assertion+tassertSuccess msg = T.assertEqual msg . Right++tassertFailure :: String -> Either String a -> T.Assertion+tassertFailure msg = either (\_ -> return ()) (\_ -> T.assertFailure msg)  tests :: IO () tests = do
src/Util.hs view
@@ -1,5 +1,8 @@ -- | Utility functions-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE+      CPP,+      FlexibleContexts+      #-} module Util (   -- * List combinators   -- ** Shallow mapping@@ -45,7 +48,16 @@ import Control.Arrow hiding (loop, (<+>)) import Control.Monad import Control.Applicative (Applicative(..), (<$>), (<$), (<**>))++#if PARSEC_VERSION == 2+ import Text.ParserCombinators.Parsec (GenParser)+-- | Parsec parsers are Applicatives, which lets us write slightly+--   more pleasant, non-monadic-looking parsers+instance Applicative (GenParser a b) where+  pure  = return+  (<*>) = ap+#endif  -- | Right-associative monadic fold foldrM :: Monad m => (a -> b -> m a) -> a -> [b] -> m a@@ -221,9 +233,3 @@ instance GSequence Maybe where   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