alms 0.4.10 → 0.4.11

raw patch · 28 files changed

+1012/−629 lines, 28 files

Files

• Makefile +1/−1
• alms.cabal +2/−1
• lib/libbasis.alms +1/−0
• src/Basis.hs +1/−1
• src/Basis/Array.hs +1/−1
• src/Basis/Channel.hs +1/−1
• src/Basis/Future.hs +1/−1
• src/Basis/IO.hs +2/−2
• src/Basis/MVar.hs +1/−1
• src/Basis/Socket.hs +8/−8
• src/Coercion.hs +9/−4
• src/Dynamics.hs +21/−8
• src/ErrorMessage.hs +6/−4
• src/Main.hs +3/−3
• src/Message/AST.hs +23/−11
• src/Message/Parser.hs +28/−26
• src/Message/Quasi.hs +13/−7
• src/Message/Render.hs +20/−24
• src/Parser.hs +2/−2
• src/Ppr.hs +210/−165
• src/PprClass.hs +160/−45
• src/Prec.hs +1/−1
• src/PrettyPrint.hs +180/−0
• src/Rename.hs +43/−36
• src/Statics.hs +237/−233
• src/Syntax/SyntaxTable.hs +1/−1
• src/Type.hs +6/−6
• src/Value.hs +30/−36

@@ -50,7 +50,7 @@ 	$(RM) html  -VERSION = 0.4.10+VERSION = 0.4.11 DISTDIR = alms-$(VERSION) TARBALL = $(DISTDIR).tar.gz 

@@ -1,5 +1,5 @@ Name:           alms-Version:        0.4.10+Version:        0.4.11 Copyright:      2010, Jesse A. Tov Cabal-Version:  >= 1.8 License:        BSD3@@ -90,6 +90,7 @@                         Ppr,                         PprClass,                         Prec,+                        PrettyPrint,                         Rename,                         Sigma,                         Statics,

@@ -6,6 +6,7 @@     exception IOError of string      exception Blame of string * string     exception PatternMatch of string * string list+    exception UninitializedLetRec of string      let failwith (msg: string) =       raise (Failure msg)

@@ -202,7 +202,7 @@  instance Valuable Ref where   veq = (==)-  vpprPrec _ _ = text "#<ref>"+  vppr _ = text "#<ref>"  -- | Built-in operations implemented in the object language srcBasis :: String

@@ -20,7 +20,7 @@  instance Valuable Array where   veq = (==)-  vpprPrec _ _ = text "#<array>"+  vppr _ = text "#<array>"  io :: IO a -> IO a io  = id

@@ -19,7 +19,7 @@  instance Valuable Channel where   veq = (==)-  vpprPrec _ _ = text "#<channel>"+  vppr _ = text "#<channel>"  entries :: [Entry Raw] entries  = [

@@ -20,7 +20,7 @@  instance Valuable Future where   veq = (==)-  vpprPrec _ _ = text "#<(co)future>"+  vppr _ = text "#<(co)future>"   entries :: [Entry Raw]

@@ -19,11 +19,11 @@  instance Valuable IO.Handle where   veq = (==)-  vpprPrec _ _ = text "#<handle>"+  vppr _ = text "#<handle>"  instance Valuable IO.IOMode where   veq      = (==)-  vpprPrec _ = text . show+  vppr     = text . show   vinj     = vinjData   vprjM    = vprjDataM deriving instance Typeable IO.IOMode

@@ -20,7 +20,7 @@  instance Valuable MVar where   veq = (==)-  vpprPrec _ _ = text "#<mvar>"+  vppr _ = text "#<mvar>"  entries :: [Entry Raw] entries  = [

@@ -20,11 +20,11 @@  instance Valuable S.Socket where   veq = (==)-  vpprPrec _ _ = text "#<socket>"+  vppr _ = text "#<socket>"  instance Valuable S.Family where   veq      = (==)-  vpprPrec _ = text . show+  vppr     = text . show   vinj     = vinjData   vprjM    = vprjDataM deriving instance Typeable S.Family@@ -32,7 +32,7 @@  instance Valuable S.ShutdownCmd where   veq        = (==)-  vpprPrec _ = text . show+  vppr       = text . show   vinj       = vinjData   vprjM      = vprjDataM deriving instance Eq S.ShutdownCmd@@ -41,21 +41,21 @@  instance Valuable S.SocketType where   veq        = (==)-  vpprPrec _ = text . show+  vppr       = text . show   vinj       = vinjData   vprjM      = vprjDataM deriving instance Data S.SocketType  instance Valuable S.AddrInfoFlag where   veq        = (==)-  vpprPrec _ = text . show+  vppr       = text . show   vinj       = vinjData   vprjM      = vprjDataM deriving instance Data S.AddrInfoFlag  instance Valuable S.PortNumber where   veq        = (==)-  vpprPrec _ = text . show+  vppr       = text . show   vinj       = vinjData   vprjM      = vprjDataM @@ -88,14 +88,14 @@  instance Valuable S.SockAddr where   veq        = (==)-  vpprPrec _ = text . show+  vppr       = text . show   vinj       = vinjData   vprjM      = vprjDataM deriving instance Data S.SockAddr  instance Valuable S.AddrInfo where   veq        = (==)-  vpprPrec _ = text . show+  vppr       = text . show   vinj       = vinjData   vprjM      = vprjDataM deriving instance Data S.AddrInfo

@@ -19,6 +19,7 @@ import Type import TypeRel () import Util+import ErrorMessage  import qualified Data.Map as M import qualified Control.Monad.State as CMS@@ -45,7 +46,7 @@ translateDecls :: TEnv -> [Decl Renamed] -> (TEnv, [Decl Renamed]) translateDecls tenv decls = (tenv, decls) -coerceExpression :: Monad m =>+coerceExpression :: AlmsMonad m =>                     Expr Renamed -> Type -> Type -> m (Expr Renamed) coerceExpression e tfrom tto = do   prj <- CMS.evalStateT (build True M.empty tfrom tto) 0@@ -54,7 +55,7 @@   neg = "context at " ++ show (getLoc e)   pos = "value at " ++ show (getLoc e) -build :: Monad m =>+build :: AlmsMonad m =>          Bool -> M.Map (TyVarR, TyVarR) (Maybe (Lid Renamed)) ->          Type -> Type -> CMS.StateT Integer m (Expr Renamed) build b recs tfrom tto@@ -112,8 +113,12 @@ build _ _    t t' =   if t <: t'     then return [$ex|+ INTERNALS.Contract.any [$stx:t'] |]-    else fail $ "type error: no coercion from " ++ show t ++ " to " ++ show t'-      -- ++ "\n" ++ show recs+    else CMS.lift . throwAlms $ AlmsException StaticsPhase bogus [$msg|+        <dl>+          <dt>from type: <dd>$t+          <dt>to type:   <dd>$t'.+        </dl>+    |]  shadow :: [TyVarR] -> [TyVarR] ->           M.Map (TyVarR, TyVarR) a -> M.Map (TyVarR, TyVarR) a

@@ -25,6 +25,7 @@ import qualified Syntax.Patt import Env import Ppr (Ppr(..), Doc, text, precApp)+import ErrorMessage  import Data.IORef (newIORef, readIORef, writeIORef) import Control.Exception (throw)@@ -125,7 +126,8 @@ evalModExp [$me| $quid:n $list:_ |]      env = do   case env =..= n of     Just scope -> return scope-    Nothing    -> fail $ "BUG! Unknown module: " ++ show n+    Nothing    -> runtimeBug _loc "evalModExp" $+      "Unknown module: ‘" ++ show n ++ "’" evalModExp [$me| $me1 : $_ |]            env = do   evalModExp me1 env evalModExp [$me| $anti:a |]              _   = $antifail@@ -143,7 +145,8 @@   [$ex| $id:ident |] -> case view ident of     Left x     -> case env =..= x of       Just v     -> v-      Nothing    -> fail $ "BUG! unbound identifier: " ++ show x+      Nothing    -> runtimeBug _loc "valOf" $+        "unbound identifier: ‘" ++ show x ++ "’"     Right c    -> return (VaCon (jname c) Nothing)   [$ex| $str:s |]    -> return (vinj s)   [$ex| $int:z |]    -> return (vinj z)@@ -160,7 +163,7 @@     loop clauses   [$ex| let rec $list:bs in $e2 |] -> do     let extend (envI, rs) (N _ b) = do-          r <- newIORef (fail "Accessed let rec binding too early")+          r <- newIORef $ throwBadLetRec (unLid (bnvar b))           return (envI =+= bnvar b =:= join (readIORef r), r : rs)     (env', rev_rs) <- foldM extend (env, []) bs     zipWithM_@@ -186,8 +189,9 @@     case v1 of       VaFun n f -> f v2 >>! nameApp n (pprPrec (precApp + 1) v2)        VaCon c _ -> return (VaCon c (Just v2))-      _         -> fail $ "BUG! applied non-function " ++ show v1-                           ++ " to argument " ++ show v2+      _         -> runtimeBug _loc "valOf" $+        "applied non-function ‘" ++ show v1 +++        "’ to argument ‘" ++ show v2 ++ "’"   [$ex| fun '$_ -> $e1 |]         -> valOf e1 env   [$ex| $e1 [$_] |]               -> valOf e1 env   [$ex| Pack[$opt:_]($_, $e1) |]  -> valOf e1 env@@ -206,7 +210,7 @@        case (mx, v) of       (Nothing, VaCon u' Nothing)   | u == u' -> return env       (Just x,  VaCon u' (Just v')) | u == u' -> bindPatt x v' env-      _                                             -> perr+      _                                       -> perr   [$pa| ($x, $y) |]     -> case vprjM v of       Just (vx, vy) -> bindPatt x vx env >>= bindPatt y vy@@ -234,14 +238,23 @@   [$pa| $antiL:a |]     -> antifail "dynamics" a   where perr = fail $-                 "Pattern match failure: " ++ show x0 ++-                 " does not match " ++ show v+                 "BUG! In bindPat, pattern match failure should " +++                 "raise PatternMatch exception, but didn’t!"  throwPatternMatch :: Value -> [String] -> E -> IO a throwPatternMatch v ps _ =   throw VExn {     exnValue = VaCon (uid "PatternMatch") (Just (vinj (show v, ps)))   }++throwBadLetRec :: String -> IO a+throwBadLetRec v =+  throw VExn {+    exnValue = VaCon (uid "UninitializedLetRec") (Just (vinj v))+  }++runtimeBug :: Loc -> String -> String -> IO a+runtimeBug  = throwAlms <$$$> almsBug DynamicsPhase  --- --- helpful stuff

@@ -7,7 +7,8 @@ module ErrorMessage (   AlmsException(..), Phase(..), AlmsMonad(..),   almsBug, (!::),-  module Message.Quasi+  wordsMsg, quoteMsg, pprMsg, showMsg, emptyMsg,+  module Message.Quasi, ) where  import Loc@@ -66,8 +67,8 @@                   Please report to <exact><tov@ccs.neu.edu></exact>.                 |] -(!::) :: Show a => String -> a -> Message d-msg0 !:: thing = [$msg| $words:msg0 <q>$show:thing</q> |]+(!::) :: Ppr a => String -> a -> Message d+msg0 !:: thing = [$msg| $words:msg0 <q>$thing</q> |] infix 1 !::  ---@@ -113,4 +114,5 @@ instance Exception AlmsException  instance Error AlmsException where-  strMsg = AlmsException (OtherError "Error") bogus . Block . Words+  strMsg = AlmsException (OtherError "Error") bogus . Words+

@@ -175,7 +175,7 @@                      bogus                      (Msg.Table [                         ("in program:", Msg.Exact prog),-                        ("exception:", Msg.Printable (vppr e))+                        ("exception:", Msg.Printable (-1) (vppr e))                      ]),       Exn.Handler continue,       Exn.Handler $ \err ->@@ -301,7 +301,7 @@  printInfo :: ReplState -> Ident Raw -> IO () printInfo st ident = case getRenamingInfo ident (rsRenaming st) of-    []  -> putStrLn $ "not bound: `" ++ show ident ++ "'"+    []  -> putStrLn $ "Not bound: ‘" ++ show ident ++ "’"     ris -> mapM_ each ris   where     each (SigAt      loc x') =@@ -338,7 +338,7 @@                      if isBogus loc                        then text "  -- built-in"                        else text "  -- defined at" <+> text (show loc)-      where (>?>) = if Ppr.isEmpty who then (<+>) else (Ppr.>?>)+      where a >?> b = Ppr.ifEmpty who (a <+> b) (a Ppr.>?> b)  printPrec :: String -> IO () printPrec oper = printDoc $

@@ -4,8 +4,8 @@       #-} module Message.AST (   Message(..),-  V, H, MessageV, MessageH,-  StackStyle(..)+  H, V, StackStyle(..),+  wordsMsg, quoteMsg, pprMsg, showMsg, emptyMsg, ) where  import PprClass@@ -17,22 +17,15 @@   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+  Printable :: Ppr a => Int -> 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+data V  -- | Types of lists data StackStyle@@ -40,4 +33,23 @@   | Bulleted   | Separated   | Broken++--+-- Public AST builders+--++wordsMsg :: String -> Message d+wordsMsg  = Words++quoteMsg :: Message d -> Message d+quoteMsg  = Quote++pprMsg   :: Ppr a => a -> Message d+pprMsg    = Printable (-1)++showMsg  :: Show a => a -> Message d+showMsg   = Showable++emptyMsg :: Message d+emptyMsg  = Words "" 

@@ -13,7 +13,7 @@ -- | 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 :: String -> Q (Message V) parseMessageQ str0 = do   loc  <- location   toks <- either (fail . show) return $@@ -63,12 +63,16 @@  antiT :: CharParser () Token antiT = char '$' *> (inner <|> between (char '<') (char '>') inner)-  where inner = combine <$> many1 alphaNum-                        <*> optionMaybe (char ':' *> many1 alphaNum)-            <|> AntiTok "" <$> (char ':' *> many1 alphaNum)+  where inner = combine <$> ident+                        <*> optionMaybe (char ':' *> ident)+            <|> AntiTok "" <$> (char ':' *> ident)         combine name Nothing     = AntiTok "" name         combine tag  (Just name) = AntiTok tag name +ident :: CharParser () String+ident  = many1 digit+     <|> lower |:| many (alphaNum <|> oneOf "'_")+ tstring :: String -> CharParser () String tstring  = try . string @@ -111,12 +115,17 @@  anti :: Bool -> P (String, String) anti v = tsatisfy check where-  check (AntiTok tag name) -    | elem tag vtags == v = Just (tag, name)-  check _                  = Nothing+  check (AntiTok tag name)+    | isDTag v tag  = Just (tag, name)+  check _           = Nothing -vtags :: [String]-vtags  = ["ol", "ul", "br", "p", "dl", "indent"]+isDTag :: Bool -> String -> Bool+isDTag _ "msg"     = True+isDTag v ('v':_)   = v+isDTag v ('h':_)   = not v+isDTag v ('q':tag) = isDTag v tag+isDTag v tag       = v == elem tag vtags+  where vtags = ["ol", "ul", "br", "p", "dl", "indent"]  intag     :: String -> P a -> P a intag s    = between (btag s) (etag s)@@ -131,47 +140,43 @@ -- Parser -- -messageP :: P MessageV+messageP :: P (Message V) messageP  = ws *> parseV <* eof  -- | Vertical-mode message-parseV  :: P MessageV+parseV  :: P (Message V) parseV   = option emptyMsg parse1V  -- | Vertical-mode message, non-empty-parse1V :: P MessageV+parse1V :: P (Message V) parse1V  = wrapMany (Stack Separated) <$> many1skip paragraphV (btag "p" *> ws) -paragraphV :: P MessageV+paragraphV :: P (Message V) paragraphV  = wrapMany (Stack Broken) <$> many1skip lineV (btag "br" *> ws) -lineV      :: P MessageV+lineV      :: P (Message V) lineV       = antiV-          <|> blockV           <|> indentV           <|> quoteV           <|> listV           <|> tableV           <|> parse1H -antiV      :: P MessageV+antiV      :: P (Message V) antiV       = uncurry AntiMsg <$> anti True <* ws -blockV     :: P MessageV-blockV      = Block <$> intagV "block" parseH--indentV    :: P MessageV+indentV    :: P (Message V) indentV     = Indent <$> intagV "indent" parseV -quoteV     :: P MessageV+quoteV     :: P (Message V) quoteV      = Quote <$> intagV "qq" parseV -listV      :: P MessageV+listV      :: P (Message V) listV       = Stack Numbered <$> intagV "ol" items           <|> Stack Bulleted <$> intagV "ul" items   where items = many1skip parse1V (btag "li" *> ws) -tableV     :: P MessageV+tableV     :: P (Message V) tableV      = (Indent . Table) <$> intagV "dl" items   where items = many $            (unwords <$> pretag "dt" (manyskip word whitespace))@@ -210,9 +215,6 @@ wrapMany :: ([a] -> a) -> [a] -> a wrapMany _ [x] = x wrapMany w xs  = w xs--emptyMsg :: Message d-emptyMsg  = Exact ""  -- -- Auxiliary

@@ -3,10 +3,11 @@       GADTs,       GeneralizedNewtypeDeriving,       MultiParamTypeClasses,+      PatternGuards,       TemplateHaskell       #-} module Message.Quasi (-  msg, Message(), MessageV, MessageH+  msg, Message(), H, V, ) where  import Message.AST@@ -39,11 +40,10 @@     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+    Printable _ _     -> 0     Showable _        -> 0     AntiMsg _ name    -> case readsPrec 0 name of       (z,""):_          -> z@@ -59,7 +59,6 @@       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)) |]@@ -70,13 +69,13 @@       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))) |]+      Printable d a+                  -> [| Exact $(lift (show (PprClass.pprDepth d 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 |]@@ -85,6 +84,13 @@         "dl"      -> [| Table $var |]         "indent"  -> [| Indent $var |]         "show"    -> [| Showable $var |]-        _         -> [| Printable $var |]+        'v':tag'  -> [| $(loop (AntiMsg tag' name)) :: Message V |]+        'h':tag'  -> [| $(loop (AntiMsg tag' name)) :: Message H |]+        'q':tag'  -> [| Quote $(loop (AntiMsg tag' name)) |]+        ""        -> [| Printable 0 $var |]+        _ | [(d,"")] <- (reads tag :: [(Int,String)])+                  -> [| Printable d $var |]+        _         -> fail $+          "Unknown message antiquote tag: ‘" ++ tag ++ "’"         where var = varE (M.findWithDefault (mkName name) name namemap) 

@@ -14,13 +14,14 @@ -- | Context for message rendering data RenderContext   = RenderContext {+      rcDetail  :: Int,       rcQtLevel :: Int,       rcLeft    :: Doc,       rcRight   :: Doc     }  rc0 :: RenderContext-rc0  = RenderContext 0 empty empty+rc0  = RenderContext (-1) 0 empty empty  getQuotes :: RenderContext -> (String, String) getQuotes cxt =@@ -60,51 +61,46 @@   Quote msg'  -> renderMessageH cxt' (Surround s e msg')     where (s, e) = getQuotes cxt           cxt'   = incQuotes cxt-  Printable a -> [addQuotes cxt (ppr a)]+  Printable d a -> [addQuotes cxt (pprDepth d' a)]+    where d' = if d == 0 then rcDetail cxt else d   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))+renderMessage :: RenderContext -> Message d -> Doc+renderMessage cxt msg0 = case msg0 of+  Words s     -> fsep $ renderMessageH cxt (Words s)+  Flow s      -> fsep $ renderMessageH cxt (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')+              -> text s <> renderMessage cxt msg' <> text e+  Quote msg'  -> renderMessage 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')+                        nest (dent + 2) (renderMessage cxt msg')                       | msg' <- msgs                       | i    <- [ 1 .. ] ]       where len  = length msgs             dent = length (show len)-    Bulleted  -> vcat [ text " •" <+> nest 3 (renderMessageV cxt msg')+    Bulleted  -> vcat [ text " •" <+> nest 3 (renderMessage cxt msg')                       | msg' <- msgs ]     Separated -> vcat (punctuate (char '\n')-                                 (map (renderMessageV cxt) msgs))-    Broken    -> vcat (map (renderMessageV cxt) msgs)+                                 (map (renderMessage cxt) msgs))+    Broken    -> vcat (map (renderMessage cxt) msgs)   Table rows  -> vcat [ text label <+>                         text (replicate (dent - length label) ' ') <>-                        nest (dent + 1) (renderMessageV cxt msg')+                        nest (dent + 1) (renderMessage cxt msg')                       | (label, msg') <- rows ]     where dent = maximum (map (length . fst) rows)   Indent msg' -> text "    " <>-                 nest 4 (renderMessageV cxt msg')-  Printable a -> ppr a+                 nest 4 (renderMessage cxt msg')+  Printable d a -> pprDepth d' a+    where d' = if d == 0 then rcDetail cxt else d   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+instance Ppr (Message d)  where ppr = renderMessage rc0+instance Show (Message d) where showsPrec = showFromPpr 

@@ -120,7 +120,7 @@       ]     unlist  = case unexpects of       []  -> []-      s:_ -> [("unexpected:", Msg.Block (Msg.Words s))]+      s:_ -> [("unexpected:", Msg.Words s)]     explist = case expects of       []  -> []       _   -> [("expected:", flow "," expects)]@@ -128,7 +128,7 @@     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+    flow c         = Msg.Flow . map Msg.Words . punct c . L.nub     punct _ []     = []     punct _ [s]    = [s]     punct c (s:ss) = (s++c) : punct c ss

@@ -30,95 +30,113 @@   isInfix [$ty| $_ -[$_]> $_ |]    = True   isInfix _                        = False --- | To pretty print the application of a type constructor to---   generic parameters-pprTyApp :: (Ppr a) => Int -> QLid i -> [a] -> Doc-pprTyApp _ ql       []   = ppr ql-pprTyApp p (J [] l) [t1]-  | isOperator l, precOp (unLid l) == Right precBang-    = parensIf (p > precBang) $-        text (unLid l) <> pprPrec (precBang + 1) t1-pprTyApp p (J [] l) [t1, t2]-  -- print @ without space around it:-  | isOperator l, '@':_ <- unLid l, Right prec <- precOp (unLid l)-    = parensIf (p > prec) $-        pprPrec (prec + 1) t1 <> text (unLid l) <> pprPrec prec t2-  | isOperator l, Left prec <- precOp (unLid l)-    = parensIf (p > prec) $-        sep [ pprPrec prec t1,-              text (unLid l) <+> pprPrec (prec + 1) t2 ]-  | isOperator l, Right prec <- precOp (unLid l)-    = parensIf (p > prec) $-        sep [ pprPrec (prec + 1) t1,-              text (unLid l) <+> pprPrec prec t2]-pprTyApp p ql ts = parensIf (p > precApp) $-                     sep [ pprPrec precApp ts,-                           ppr ql ]+-- | For printing infix expressions.  Given a splitter function that+--   splits expressions into a left operand, operator name, and right+--   operand (if possible), and an expression to print, pretty-prints+--   the expression, but only if there is one level of infix to be+--   done.+pprInfix :: Ppr a =>+            (a -> Maybe (a, String, Maybe a)) ->+            a -> Maybe Doc+pprInfix inspect x0+  | Just (x1, op, Nothing) <- inspect x0+  , precOp op == Right precBang+    = Just (prec precBang (text op <+> ppr x1))+  | Just (_, op, Just _) <- inspect x0+  , isOperator (lid op :: Lid Raw)+  , p <- precOp op+  , p /= Right precBang+    = Just $+        prec (id|||id $ p) $+          fcat $ mapTail (nest 2) $ loop p empty x0+  | otherwise+    = Nothing+  where+  loop p suf x+    | Just (x1, op, Just x2) <- inspect x+    , precOp op == p+    = case precOp op of+        Left _  -> loop p (oper op) x1 ++ [ppr1 x2 <> suf]+        Right _ -> ppr1 x1 <> oper op : loop p suf x2+  loop _ suf x = [ ppr x <> suf ]+  oper s = case s of+    '@':_ -> text s+    ';':_ -> text s <> space+    _     -> space <> text s <> space  instance Ppr (Type i) where-  -- Print sugar for infix type constructors:-  pprPrec p [$ty| $t1 ; $t2 |]-                  = parensIf (p > precSemi) $-                      sep [ pprPrec (precSemi + 1) t1 <> text ";",-                            pprPrec precSemi t2 ]   -- pprPrec p (TyFun q t1 t2)-  pprPrec p [$ty| $t1 -[$q]> $t2 |]-                  = parensIf (p > precArr) $-                    sep [ pprPrec (precArr + 1) t1,-                          pprArr (view q) <+> pprRight precArr 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 "-[" <> pprPrec precStart q <> text "]>"-  pprPrec p [$ty| ($list:ts) $qlid:n |]-                          = pprTyApp p n ts+          pprArr _          = text "-[" <> ppr0 q <> text "]>"+  ppr t@[$ty| ($list:ts) $qlid:n |]+    | Just doc <- pprInfix unfoldType t+                    = doc+    | null ts       = ppr n+    | otherwise     = prec precApp $ sep [ ppr ts, ppr n ]     -- debugging: <> text (show (ttId (unsafeCoerce tag :: TyTag)))-  pprPrec p [$ty| '$x |]  = pprPrec p x-  pprPrec p [$ty| $quant:qu '$x. $t |]-                          = parensIf (p > precDot) $-                              ppr qu <+>-                              fsep (map (pprPrec (precDot + 1))-                                        tvs) <>-                              char '.'-                                >+> pprPrec precDot body+  ppr [$ty| '$x |]  = ppr x+  ppr [$ty| $quant:qu '$x. $t |]+                    = prec precDot $+                        ppr qu <+>+                        fsep (map ppr1 tvs) <>+                        char '.'+                          >+> ppr body       where (tvs, body) = unfoldTyQu qu [$ty| $quant:qu '$x. $t |]-  pprPrec p [$ty| mu '$x. $t |]-                          = parensIf (p > precDot) $-                              text "mu" <+>-                              pprPrec (precDot + 1) x <>-                              char '.'-                                >+> pprPrec precDot t-  pprPrec p [$ty| $anti:a |] = pprPrec p a+  ppr [$ty| mu '$x. $t |]+                    = prec precDot $+                        text "mu" <+>+                        ppr1 x <>+                        char '.'+                          >+> ppr t+  ppr [$ty| $anti:a |] = ppr a +unfoldType :: Type i -> Maybe (Type i, String, Maybe (Type i))+unfoldType [$ty| ($t1, $t2) $name:n |] = Just (t1, n, Just t2)+unfoldType [$ty| $t1 $name:n |]        = Just (t1, n, Nothing)+unfoldType _                           = Nothing+ instance Ppr (TyPat i) where-  pprPrec p tp0 = case tp0 of+  ppr tp0 = case tp0 of+    _ | Just doc <- pprInfix unfoldTyPat tp0+                       -> doc     N _ (TpVar tv var) -> pprParamV var tv     [$tpQ| ($list:tps) $qlid:ql |]-                       -> pprTyApp p ql tps+                       -> ppr tps <+> ppr ql     [$tpQ| $antiP:a |] -> ppr a +unfoldTyPat :: TyPat i -> Maybe (TyPat i, String, Maybe (TyPat i))+unfoldTyPat [$tpQ| ($t1, $t2) $name:n |] = Just (t1, n, Just t2)+unfoldTyPat [$tpQ| $t1 $name:n |]        = Just (t1, n, Nothing)+unfoldTyPat _                            = Nothing+ instance Ppr (QExp i) where-  pprPrec p [$qeQ| $qlit:qu |] = pprPrec p qu-  pprPrec p [$qeQ| $qvar:v |]  = pprPrec p (tvname v)-  pprPrec p [$qeQ| $qdisj:qes |] = case qes of-    []    -> pprPrec p Qu-    [qe]  -> pprPrec p qe-    _     -> parensIf (p > precPlus) $+  ppr [$qeQ| $qlit:qu |] = ppr qu+  ppr [$qeQ| $qvar:v |]  = ppr (tvname v)+  ppr [$qeQ| $qdisj:qes |] = case qes of+    []    -> ppr Qu+    [qe]  -> ppr qe+    _     -> prec precPlus $                fsep $                  intersperse (text "\\/") $-                   map (pprPrec (precPlus + 1)) qes-  pprPrec p [$qeQ| $qconj:qes |] = case qes of-    []    -> pprPrec p Qa-    [qe]  -> pprPrec p qe-    _     -> parensIf (p > precStar) $+                   map ppr1 qes+  ppr [$qeQ| $qconj:qes |] = case qes of+    []    -> ppr Qa+    [qe]  -> ppr qe+    _     -> prec precStar $                hcat $                  intersperse (text "/\\") $-                   map (pprPrec (precStar + 1)) qes-  pprPrec p [$qeQ| $anti:a |] = pprPrec p a+                   map ppr1 qes+  ppr [$qeQ| $anti:a |] = ppr a  instance Ppr (Prog i) where-  ppr [$prQ| $list:ms |]       = vcat (map ppr ms)+  ppr [$prQ| $list:ms |]       = vcat (map ppr0 ms)   ppr [$prQ| $expr:e |]        = ppr e-  ppr [$prQ| $list:ms in $e |] = vcat (map ppr ms) $+$+  ppr [$prQ| $list:ms in $e |] = vcat (map ppr0 ms) $+$                                  (text "in" >+> ppr e)  instance Ppr (Decl i) where@@ -230,7 +248,7 @@     brackets (fsep (punctuate comma (map ppr qls)))   [$me| struct $list:ds end |] ->     add (text "struct")-    $$ nest 2 (vcat (map ppr ds))+    $$ nest 2 (vcat (map ppr0 ds))     $$ text "end"   [$me| $me1 : $se2 |] ->     pprSigExp (pprModExp add me1 <+> colon <+>) se2@@ -246,16 +264,16 @@       brackets (fsep (punctuate comma (map ppr qls)))     [$seQ| sig $list:sgs end |] ->       add (text "sig")-      $$ nest 2 (vcat (map ppr sgs))+      $$ nest 2 (vcat (map ppr0 sgs))       $$ text "end"     [$seQ| $_ with type $list:_ $qlid:_ = $_ |] ->       error "BUG! can't happen in pprSigExp"     [$seQ| $anti:a |] -> add (ppr a)   withs      =-    sep $+    atPrec 0 $ sep $       mapHead (text "with type" <+>) $         mapTail ((nest 6) . (text "and" <+>)) $-          [ pprTyApp 0 tc tvs <+> equals <+> ppr t+          [ pprTyApp tc tvs <+> equals <+> ppr t           | (tc, tvs, t) <- wts ]  instance Ppr (SigItem i) where@@ -278,113 +296,110 @@       ppr a  instance Ppr (Expr i) where-  pprPrec p e0 = case e0 of-    [$ex| $id:x |]   -> pprPrec p x-    [$ex| $lit:lt |] -> pprPrec p lt+  ppr e0 = case e0 of+    _ | Just doc <- pprInfix unfoldExpr e0+                     -> doc+    [$ex| $id:x |]   -> ppr x+    [$ex| $lit:lt |] -> ppr lt     [$ex| if $ec then $et else $ef |] ->-      parensIf (p > precDot) $+      prec precDot $         sep [ text "if" <+> ppr ec,-              nest 2 $ text "then" <+> ppr et,-              nest 2 $ text "else" <+> pprPrec precDot ef ]-    [$ex| $e1; $e2 |] ->-      parensIf (p > precSemi) $-        sep [ pprPrec (precSemi + 1) e1 <> semi,-              ppr e2 ]+              nest 2 $ text "then" <+> ppr0 et,+              nest 2 $ text "else" <+> ppr ef ]+    [$ex| $_; $_ |] ->+      prec precDot $+        sep (unfold e0)+      where unfold [$ex| $e1; $e2 |] = ppr1 e1 <> semi : unfold e2+            unfold e                 = [ ppr0 e ]     [$ex| let $x = $e1 in $e2 |] ->-      pprLet p (ppr x) e1 e2+      pprLet (ppr x) e1 e2     [$ex| match $e1 with $list:clauses |] ->-      parensIf (p > precDot) $+      prec precDot $         vcat (sep [ text "match",-                    nest 2 $ ppr e1,+                    nest 2 $ ppr0 e1,                     text "with" ] : map alt clauses)       where         alt (N _ (CaClause xi ei)) =-          hang (char '|' <+> pprPrec precDot xi <+> text "->")+          hang (char '|' <+> ppr xi <+> text "->")                 4-                (pprPrec precDot ei)+                (ppr ei)         alt (N _ (CaAnti a))      = char '|' <+> ppr a     [$ex| let rec $list:bs in $e2 |] ->-      text "let" <+>-      vcat (zipWith each ("rec" : repeat "and") bs) $$-      text "in" <+> pprPrec precDot e2-        where-          each kw (N _ (BnBind x t e)) =-            -- This could be better by pulling some args out.-            hang (hang (text kw <+> ppr x)-                       6-                       (colon <+> ppr t <+> equals))-                 2-                 (ppr e)-          each kw (N _ (BnAnti a)) = text kw <+> ppr a+      prec precDot $+        text "let" <+>+        vcat (zipWith each ("rec" : repeat "and") bs) $$+        text "in" <+> ppr e2+          where+            each kw (N _ (BnBind x t e)) =+              -- This could be better by pulling some args out.+              hang (hang (text kw <+> ppr x)+                         6+                         (colon <+> ppr t <+> equals))+                   2+                   (ppr e)+            each kw (N _ (BnAnti a)) = text kw <+> ppr a     [$ex| let $decl:d in $e2 |] ->-      text "let" <+> ppr d $$-      (text "in" >+> pprPrec precDot e2)+      prec precDot $+        text "let" <+> ppr0 d $$+        (text "in" >+> ppr e2)     [$ex| ($e1, $e2) |] ->-      parensIf (p > precCom) $-        sep [ pprPrec precCom e1 <> comma,-              pprPrec (precCom + 1) e2 ]-    [$ex| fun $_ : $_ -> $_ |] -> pprAbs p e0-    [$ex| $name:x $e2 |]-      | Right p' <- precOp x,-        p' == 10-          -> parensIf (p > p') $-               text x <+> pprPrec p' e2-    [$ex| ($name:x $e12) $e2 |] -      | (dl, dr, p') <- either ((,,) 0 1) ((,,) 1 0) (precOp x),-        p' < 9-          -> parensIf (p > p') $-               sep [ pprPrec (p' + dl) e12,-                     text x,-                     pprPrec (p' + dr) e2 ]+      prec precCom $+        sep [ ppr e1 <> comma, ppr1 e2 ]+    [$ex| fun $_ : $_ -> $_ |] -> pprAbs e0     [$ex| $e1 $e2 |]-          -> parensIf (p > precApp) $-               sep [ pprPrec precApp e1,-                     pprPrec (precApp + 1) e2 ]-    [$ex| fun '$_ -> $_ |] -> pprAbs p e0+          -> prec precApp $+               sep [ ppr e1, ppr1 e2 ]+    [$ex| fun '$_ -> $_ |] -> pprAbs e0     [$ex| $_ [$_] |] ->-      parensIf (p > precTApp) $-        cat [ pprPrec precTApp op,+      prec precTApp $+        cat [ ppr op,               brackets . fsep . punctuate comma $                 map (pprPrec precCom) args ]       where          (args, op) = unfoldExTApp e0     [$ex| Pack[$opt:t1]($t2, $e) |] ->-      parensIf (p > precApp) $-        text "Pack" <> maybe empty (brackets . ppr) t1 <+>-        parens (sep [ pprPrec (precCom + 1) t2 <> comma,-                      pprPrec precCom e ])+      prec precApp $+        text "Pack" <> maybe empty (brackets . ppr0) t1 <+>+        prec precCom (sep [ ppr1 t2 <> comma, ppr e ])     [$ex| ( $e : $t1 :> $t2 ) |] ->-      parensIf (p > precCast) $-         sep [ pprPrec (precCast + 2) e,-               colon     <+> pprPrec (precCast + 2) t1,-               text ":>" <+> pprPrec (precCast + 2) t2 ]+      prec precCast $+        atPrec (precCast + 2) $+          sep [ ppr e,+                colon     <+> ppr t1,+                text ":>" <+> ppr t2 ]     [$ex| ( $e : $t1 ) |] ->-      parensIf (p > precCast) $-         sep [ pprPrec (precCast + 2) e,-               colon     <+> pprPrec (precCast + 2) t1 ]+      prec precCast $+        atPrec (precCast + 2) $+          sep [ ppr e,+                colon <+> ppr t1 ]     [$ex| ( $e :> $t1 ) |] ->-      parensIf (p > precCast) $-         sep [ pprPrec (precCast + 2) e,-               text ":>" <+> pprPrec (precCast + 2) t1 ]-    [$ex| $anti:a |] -> pprPrec p a+      prec precCast $+        atPrec (precCast + 2) $+          sep [ ppr e,+                text ":>" <+> ppr t1 ]+    [$ex| $anti:a |] -> ppr a+    where+    unfoldExpr [$ex| ($name:x $e1) $e2 |] = Just (e1, x, Just e2)+    unfoldExpr [$ex| $name:x $e1 |]       = Just (e1, x, Nothing)+    unfoldExpr _                          = Nothing -pprLet :: Int -> Doc -> Expr i -> Expr i -> Doc-pprLet p pat e1 e2 = parensIf (p > precDot) $+pprLet :: Doc -> Expr i -> Expr i -> Doc+pprLet pat e1 e2 = prec precDot $   hang (text "let" <+> pat <+> pprArgList args <+> equals           >+> ppr body <+> text "in")        (if isLet (view e2)           then 0           else 2)-       (pprPrec precDot e2)+       (ppr e2)   where     (args, body) = unfoldExAbs e1     isLet (ExCase _ [_]) = True     isLet _              = False -pprAbs :: Int -> Expr i -> Doc-pprAbs p e = parensIf (p > precDot) $+pprAbs :: Expr i -> Doc+pprAbs e = prec precDot $     text "fun" <+> argsDoc <+> text "->"-      >+> pprPrec precDot body+      >+> ppr body   where (args, body)   = unfoldExAbs e         argsDoc = case args of           [Left ([$pa| _ |], [$ty|@! unit |])]@@ -397,13 +412,13 @@   eachArg (Left ([$pa| _ |], [$ty|@! unit |]))                           = parens empty   eachArg (Left (x, t))   = parens $-                              ppr x-                                >+> colon <+> ppr t+                              ppr0 x+                                >+> colon <+> ppr0 t   eachArg (Right tvs)     = brackets .                               sep .                                 punctuate comma $                                   map ppr tvs-+  --   combine :: [Either a b] -> [Either a [b]]   combine  = foldr each [] where     each (Right b) (Right bs : es) = Right (b : bs) : es@@ -411,24 +426,20 @@     each (Left a)  es              = Left a : es  instance Ppr (Patt i) where-  pprPrec _ [$pa| _ |]             = text "_"-  pprPrec _ [$pa| $lid:l |]        = ppr l-  pprPrec _ [$pa| $quid:qu |]      = ppr qu-  pprPrec p [$pa| $quid:qu $x |]   = parensIf (p > precApp) $-                                       pprPrec precApp qu <+>-                                       pprPrec (precApp + 1) x-  pprPrec p [$pa| ($x, $y) |]      = parensIf (p > precCom) $-                                       pprPrec precCom x <> comma <+>-                                       pprPrec (precCom + 1) y-  pprPrec p [$pa| $lit:lt |]       = pprPrec p lt-  pprPrec p [$pa| $x as $lid:l |]  = parensIf (p > precDot) $-                                       pprPrec (precDot + 1) x <+>-                                       text "as" <+> ppr l-  pprPrec p [$pa| Pack('$tv,$x) |] = parensIf (p > precApp) $-                                       text "Pack" <+> parens (sep pair)-    where pair = [ pprPrec (precCom + 1) tv <> comma,-                   pprPrec precCom x ]-  pprPrec p [$pa| $anti:a |]       = pprPrec p a+  ppr [$pa| _ |]             = text "_"+  ppr [$pa| $lid:l |]        = ppr l+  ppr [$pa| $quid:qu |]      = ppr qu+  ppr [$pa| $quid:qu $x |]   = prec precApp $+                                 ppr qu <+> ppr1 x+  ppr [$pa| ($x, $y) |]      = prec precCom $+                                 ppr x <> comma <+> ppr1 y+  ppr [$pa| $lit:lt |]       = ppr lt+  ppr [$pa| $x as $lid:l |]  = prec precDot $+                                 ppr1 x <+> text "as" <+> ppr l+  ppr [$pa| Pack('$tv,$x) |] = prec precApp $+                                 text "Pack" <+> pprPrec precCom (sep pair)+    where pair = [ ppr1 tv <> comma, ppr x ]+  ppr [$pa| $anti:a |]       = ppr a  instance Ppr Lit where   ppr (LtInt i)   = integer i@@ -436,6 +447,39 @@   ppr (LtStr s)   = text (show s)   ppr (LtAnti a)  = ppr a +--+-- Helper for pretty-printing type-like things -- doesn't require+-- underlying types, but does need to see the operator name.+--++data PprTyAppHelper i a+  = PTAHBranch (QLid i) [a]+  | PTAHLeaf   a++instance Ppr a => Ppr (PprTyAppHelper i a) where+  ppr (PTAHLeaf a) = ppr a+  ppr _            = error "BUG! in PprTyAppHelper.ppr"++unfoldPTAH :: PprTyAppHelper i a ->+              Maybe (PprTyAppHelper i a, String, Maybe (PprTyAppHelper i a))+unfoldPTAH (PTAHBranch (J [] l) [a, b])+  = Just (PTAHLeaf a, unLid l, Just (PTAHLeaf b))+unfoldPTAH (PTAHBranch (J [] l) [a])+  = Just (PTAHLeaf a, unLid l, Nothing)+unfoldPTAH _+  = Nothing++pprTyApp :: Ppr a => QLid i -> [a] -> Doc+pprTyApp ql ts+  | Just doc <- pprInfix unfoldPTAH (PTAHBranch ql ts)+               = doc+pprTyApp ql [] = ppr ql+pprTyApp ql ts = prec precApp $ sep [ ppr ts, ppr ql ]++--+-- Instances+--+ instance Show (Prog i)   where showsPrec = showFromPpr instance Show (Decl i)   where showsPrec = showFromPpr instance Show (TyDec i)  where showsPrec = showFromPpr@@ -447,6 +491,7 @@ instance Show (QExp i)   where showsPrec = showFromPpr instance Show (SigItem i)where showsPrec = showFromPpr +instance Ppr Loc       where pprPrec = pprFromShow instance Ppr QLit      where pprPrec = pprFromShow instance Ppr Variance  where pprPrec = pprFromShow instance Ppr Quant     where pprPrec = pprFromShow

@@ -1,18 +1,54 @@+{-# LANGUAGE+      FlexibleInstances+      #-} module PprClass (+  -- * Documents+  Doc,   -- * Pretty-printing class-  Ppr(..), IsInfix(..),+  Ppr(..), IsInfix(..), ListStyle(..),+  -- ** Helpers+  ppr0, ppr1, pprDepth,+  -- ** Context operations+  prec, prec1, descend, atPrec, atDepth,+  askPrec, askDepth,+  trimList, trimCat,   -- * Pretty-printing combinators-  parensIf, (>+>), (>?>),+  (>+>), (>?>), ifEmpty,+  vcat, sep, cat, fsep, fcat,   -- * Renderers   render, renderS, printDoc, printPpr,   -- ** Instance helpers   showFromPpr, pprFromShow,   -- * Re-exports-  module Text.PrettyPrint+  module PrettyPrint ) where -import Text.PrettyPrint hiding (render)+import PrettyPrint hiding (Doc(..), render, vcat, sep, cat, fsep, fcat)+import qualified PrettyPrint as P +-- | Context for pretty-printing.+data PprContext+  = PprContext {+      pcPrec  :: !Int,+      pcDepth :: !Int+  }++-- | Default context+pprContext0 :: PprContext+pprContext0  = PprContext {+  pcPrec  = 0,+  pcDepth = -1+}++type Doc = P.Doc PprContext++data ListStyle +  = ListStyle {+    listStyleBegin, listStyleEnd, listStylePunct :: Doc,+    listStyleDelimitEmpty, listStyleDelimitSingleton :: Bool,+    listStyleJoiner :: [Doc] -> Doc+  }+ -- | Class for pretty-printing at different types -- -- Minimal complete definition is one of:@@ -21,36 +57,35 @@ -- -- * 'ppr' class Ppr p where+  -- | Print current precedence+  ppr     :: p -> Doc   -- | 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+  -- | Print a list in the default style+  pprList :: [p] -> Doc+  -- | Print a list in the specified style+  pprStyleList :: ListStyle -> [p] -> Doc   -- | Style for printing lists   listStyle   :: [p] -> ListStyle   ---  ppr         = pprPrec 0-  pprPrec _   = ppr-  pprPrecStyleList _ st [] =+  --+  ppr         = asksD pcPrec . flip pprPrec+  pprPrec p   = prec p . ppr+  pprList xs  = pprStyleList (listStyle xs) xs+  --+  pprStyleList st [] =     if listStyleDelimitEmpty st       then listStyleBegin st <> listStyleEnd st       else empty-  pprPrecStyleList p st [x] =+  pprStyleList st [x] =     if listStyleDelimitSingleton st       then listStyleBegin st <> ppr x <> listStyleEnd st-      else pprPrec p x-  pprPrecStyleList _ st xs  =+      else ppr x+  pprStyleList 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,@@ -60,41 +95,111 @@     listStyleJoiner           = fsep   } -data ListStyle = ListStyle {-  listStyleBegin, listStyleEnd, listStylePunct :: Doc,-  listStyleDelimitEmpty, listStyleDelimitSingleton :: Bool,-  listStyleJoiner :: [Doc] -> Doc-}+-- | Print at top level.+ppr0      :: Ppr p => p -> Doc+ppr0       = atPrec 0 . ppr --- | Conditionally add parens around the given 'Doc'-parensIf :: Bool -> Doc -> Doc-parensIf True  doc = parens doc-parensIf False doc = doc+-- | Print at next level.+ppr1      :: Ppr p => p -> Doc+ppr1       = prec1 . ppr +-- | Print to the given depth.+pprDepth  :: Ppr p => Int -> p -> Doc+pprDepth d = atDepth d . ppr++-- | Enter the given precedence level, drawing parentheses if necessary,+--   and count it as a descent in depth as well.+prec :: Int -> Doc -> Doc+prec p doc = asksD pcPrec $ \p' ->+  if p' > p+    then descend $ parens (atPrec (min p 0) doc)+    else atPrec p doc++-- | Go to the next (tigher) precedence level.+prec1 :: Doc -> Doc+prec1  = mapD (\e -> e { pcPrec = pcPrec e + 1 })++-- | Descend a level, elliding if the level counter runs out+descend :: Doc -> Doc+descend doc = askD $ \e ->+  case pcDepth e of+    -1 -> doc+    0  -> text "..."+    k  -> localD e { pcDepth = k - 1 } doc++-- | Set the precedence, but check or draw parentheses+atPrec   :: Int -> Doc -> Doc+atPrec p  = mapD (\e -> e { pcPrec = p })++-- | Set the precedence, but check or draw parentheses+atDepth  :: Int -> Doc -> Doc+atDepth k = mapD (\e -> e { pcDepth = k })++-- | Find out the precedence+askPrec :: (Int -> Doc) -> Doc+askPrec  = asksD pcPrec++-- | Find out the depth+askDepth :: (Int -> Doc) -> Doc+askDepth  = asksD pcDepth++-- | Trim a list to (about) the given number of elements, with+--   "..." in the middle.+trimList :: Int -> [Doc] -> [Doc]+trimList (-1) ds = ds+trimList n2   ds = if k <= 2 * n+                     then ds+                     else take n ds ++ text "... " : drop (k - n) ds+  where+    n = (n2 + 1) `div` 2+    k = length ds++-- | Lift a concatenation function to respect depth.+trimCat :: ([Doc] -> Doc) -> [Doc] -> Doc+trimCat xcat docs = asksD pcDepth $ \d -> case d of+  -1 -> xcat docs+  _  -> atDepth ((d + 1) `div` 2) (xcat (trimList d docs))++vcat, sep, cat, fsep, fcat :: [Doc] -> Doc+vcat = trimCat P.vcat+sep  = trimCat P.sep+cat  = trimCat P.cat+fsep = trimCat P.fsep+fcat = trimCat P.fcat+ instance Ppr a => Ppr [a] where-  pprPrec = pprPrecList+  ppr = pprList  instance Ppr a => Ppr (Maybe a) where   pprPrec _ Nothing  = empty   pprPrec p (Just a) = pprPrec p a +-- | Class to check if a particular thing will print infix.  Adds+--   an operation to print at the given precedence only if the given+--   thing is infix.  (We use this for printing arrows without too+--   many parens.) class Ppr a => IsInfix a where   isInfix  :: a -> Bool-  pprRight :: Int -> a -> Doc-  pprRight p a =+  pprRight :: a -> Doc+  pprRight a =     if isInfix a-      then pprPrec p a-      else ppr a+      then ppr a+      else ppr0 a -instance Ppr Doc where-  ppr = id+instance Ppr Int       where ppr = int+instance Ppr Integer   where ppr = integer+instance Ppr Double    where ppr = double -instance Ppr Int where-  ppr = int+instance Ppr Char where+  ppr            = text . show+  pprStyleList _ = text +instance Ppr (P.Doc PprContext)  where ppr = id+instance Show (P.Doc PprContext) where showsPrec = showFromPpr+ -- Render a document in the preferred style, given a string continuation renderS :: Doc -> ShowS-renderS doc rest = fullRender PageMode 80 1.1 each rest doc+renderS doc rest = fullRenderIn pprContext0 PageMode 80 1.1 each rest doc   where each (Chr c) s'  = c:s'         each (Str s) s'  = s++s'         each (PStr s) s' = s++s'@@ -105,7 +210,7 @@  -- Render and display a document in the preferred style printDoc :: Doc -> IO ()-printDoc = fullRender PageMode 80 1.1 each (putChar '\n')+printDoc = fullRenderIn pprContext0 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@@ -120,11 +225,21 @@ pprFromShow :: Show a => Int -> a -> Doc pprFromShow p t = text (showsPrec p t "") +--+-- Some indentation operations+--+ liftEmpty :: (Doc -> Doc -> Doc) -> Doc -> Doc -> Doc-liftEmpty joiner d1 d2-  | isEmpty d1 = d2-  | isEmpty d2 = d1-  | otherwise  = joiner d1 d2+liftEmpty joiner d1 d2 = askD f where+  f e | isEmptyIn e d1 = d2+      | isEmptyIn e d2 = d1+      | otherwise      = joiner d1 d2++ifEmpty :: Doc -> Doc -> Doc -> Doc+ifEmpty dc dt df = askD $ \e ->+  if isEmptyIn e dc+    then dt+    else df  (>+>) :: Doc -> Doc -> Doc (>+>) = flip hang 2

@@ -38,7 +38,7 @@       OtherSymbol           -> Left precPlus       ConnectorPunctuation  -> Right precCaret       OtherPunctuation      -> Right precAt-      _                     -> Left precEq -- defaulty+      _                     -> Left precApp -- defaulty precOp ""             = Left precApp  precMin, precStart, precMax,

@@ -0,0 +1,180 @@+{- | A layer over 'P.Doc' for propagating context information.  (I think+     Template Haskell has a version of this. -}+module PrettyPrint (+  -- * Environment-parameterized pretty-printing document+  Doc(..),+  -- ** Environment operations+  mapD, askD, asksD, localD,+  -- * Document combinators+  -- ** Binary operations+  ($$), ($+$), (<+>), (<>),+  -- ** Unary operations+  braces, brackets, doubleQuotes, quotes, parens,+  -- ** List operations+  cat, fcat, fsep, hcat, hsep, sep, vcat,+  -- ** Miscellaneous operations+  nest, hang, punctuate,+  -- ** Nullary operations (documents)+  colon, comma, empty, equals, lbrace, lbrack,+  lparen, rbrace, rbrack, rparen, semi, space,+  -- *** Unary functions returning documents+  char, double, float, int, integer, ptext, rational, text, zeroWidthText,+  -- * Rendering and queries+  toDocIn, isEmptyIn, renderIn, renderStyleIn, fullRenderIn,+  toDoc, isEmpty, render, renderStyle, fullRender,+  -- ** Rendering constants+  P.Mode(..), P.Style(..), P.TextDetails(..), P.style+) where++import qualified Text.PrettyPrint as P+import Control.Applicative hiding (empty)+import Data.Monoid++-- Document parameterized by type @e@.+newtype Doc e = Doc { unDoc :: e -> P.Doc }++--+-- Environment manipulation+--++mapD     :: (e' -> e) -> Doc e -> Doc e'+mapD f d  = Doc (unDoc d . f)++askD     :: (e -> Doc e) -> Doc e+askD f    = Doc (unDoc <$> f <*> id)++asksD    :: (e -> a) -> (a -> Doc e) -> Doc e+asksD g f = askD (f . g)++localD   :: e' -> Doc e' -> Doc e+localD    = mapD . const++--+-- Lifts+--++liftD0   :: P.Doc -> Doc e+liftD0    = Doc . const++liftD    :: (P.Doc -> P.Doc) -> Doc e -> Doc e+liftD f d = Doc (f <$> unDoc d)++liftD2 :: (P.Doc -> P.Doc -> P.Doc) ->+            Doc e -> Doc e -> Doc e+liftD2 f d1 d2 = Doc (f <$> unDoc d1 <*> unDoc d2)++liftDList :: ([P.Doc] -> P.Doc) -> [Doc e] -> Doc e+liftDList f ds = Doc (\e -> f [ d e | Doc d <- ds ])++--+-- Pretty-printing combinators+--++($$), ($+$), (<+>), (<>) :: Doc e -> Doc e -> Doc e+($$)   = liftD2 (P.$$)+($+$)  = liftD2 (P.$+$)+(<+>)  = liftD2 (P.<+>)+(<>)   = liftD2 (P.<>)++braces, brackets, doubleQuotes, parens, quotes :: Doc e -> Doc e+braces       = liftD P.braces+brackets     = liftD P.brackets+doubleQuotes = liftD P.doubleQuotes+quotes       = liftD P.quotes+parens       = liftD P.parens++nest      :: Int -> Doc e -> Doc e+nest         = liftD . P.nest++hang      :: Doc e -> Int -> Doc e -> Doc e+hang d1 n    = liftD2 (flip P.hang n) d1++punctuate :: Doc e -> [Doc e] -> [Doc e]+punctuate _  []     = []+punctuate _  [d]    = [d]+punctuate d1 (d:ds) = d<>d1 : punctuate d1 ds++cat, fcat, fsep, hcat, hsep, sep, vcat :: [Doc e] -> Doc e+cat   = liftDList P.cat+fcat  = liftDList P.fcat+fsep  = liftDList P.fsep+hcat  = liftDList P.hcat+hsep  = liftDList P.hsep+sep   = liftDList P.sep+vcat  = liftDList P.vcat++char            :: Char -> Doc e+double          :: Double -> Doc e+float           :: Float -> Doc e+int             :: Int -> Doc e+integer         :: Integer -> Doc e+ptext           :: String -> Doc e+rational        :: Rational -> Doc e+text            :: String -> Doc e+zeroWidthText   :: String -> Doc e++char             = liftD0 . P.char+double           = liftD0 . P.double+float            = liftD0 . P.float+int              = liftD0 . P.int+integer          = liftD0 . P.integer+ptext            = liftD0 . P.ptext+rational         = liftD0 . P.rational+text             = liftD0 . P.text+zeroWidthText    = liftD0 . P.zeroWidthText++colon, comma, empty, equals, lbrace, lbrack, lparen, rbrace,+  rbrack, rparen, semi, space :: Doc e+colon   = liftD0 P.colon+comma   = liftD0 P.comma+empty   = liftD0 P.empty+equals  = liftD0 P.equals+lbrace  = liftD0 P.lbrace+lbrack  = liftD0 P.lbrack+lparen  = liftD0 P.lparen+rbrace  = liftD0 P.rbrace+rbrack  = liftD0 P.rbrack+rparen  = liftD0 P.rparen+semi    = liftD0 P.semi+space   = liftD0 P.space++--+-- Rendering and queries+--++toDocIn :: e -> Doc e -> P.Doc+toDocIn  = flip unDoc++isEmptyIn :: e -> Doc e -> Bool+isEmptyIn e = P.isEmpty . toDocIn e++renderIn :: e -> Doc e -> String+renderIn e  = P.render . toDocIn e++renderStyleIn :: e -> P.Style -> Doc e -> String+renderStyleIn e sty = P.renderStyle sty . toDocIn e++fullRenderIn :: e ->+                P.Mode -> Int -> Float ->+                (P.TextDetails -> a -> a) -> a ->+                Doc e -> a+fullRenderIn e mode cols ribbon f z =+  P.fullRender mode cols ribbon f z . toDocIn e++toDoc    :: Monoid e => Doc e -> P.Doc+toDoc     = toDocIn mempty++isEmpty :: Monoid e => Doc e -> Bool+isEmpty  = isEmptyIn mempty++render :: Monoid e => Doc e -> String+render  = renderIn mempty++renderStyle :: Monoid e => P.Style -> Doc e -> String+renderStyle = renderStyleIn mempty++fullRender :: Monoid e =>+              P.Mode -> Int -> Float ->+              (P.TextDetails -> a -> a) -> a ->+              Doc e -> a+fullRender = fullRenderIn mempty

@@ -32,6 +32,7 @@ import qualified Syntax.Notable import qualified Syntax.Patt import Util+import Ppr (Ppr(..))  import qualified Data.List as List import Data.Monoid@@ -57,7 +58,7 @@ }  -- | Generate a renamer error.-renameError :: MessageV -> R a+renameError :: Message V -> R a renameError msg0 = do   loc <- R (asks location)   throwAlms (AlmsException RenamerPhase loc msg0)@@ -202,25 +203,25 @@ don'tAllocate = R . local (\cxt -> cxt { allocate = False }) . unR  -- | Generate an unbound name error-unbound :: Show a => String -> a -> R b+unbound :: Ppr a => String -> a -> R b unbound ns a =-  renameError [$msg| $words:ns not in scope: <q>$show:a</q>. |]+  renameError [$msg| $words:ns not in scope: $q:a |]  -- | Generate an error about a name declared twice-repeated :: Show a => String -> a -> String -> [Loc] -> R b+repeated :: Ppr a => String -> a -> String -> [Loc] -> R b repeated what a inwhat locs =   renameError [$msg|-    $words:what <q>$show:a</q>+    $words:what $q:a     repeated $words:times in $words:inwhat $words:at     $ul:slocs   |]   where     times = case length locs of-          0 -> ""-          1 -> ""-          2 -> "twice"-          3 -> "thrice"-          _ -> show (length locs) ++ " times"+      0 -> ""+      1 -> ""+      2 -> "twice"+      3 -> "thrice"+      _ -> show (length locs) ++ " times"     at    = if length locs > 1 then "at:" else ""     slocs = map [$msg| $show:1 |] locs @@ -319,9 +320,9 @@     Nothing              -> unbound "Type variable" tv     Just (tv', _, True)  -> return tv'     Just (_, loc, False) -> renameError [$msg|-      Type variable $show:tv not in scope.+      Type variable $tv not in scope.       <indent>-         (It was bound at $show:loc, but a nested declaration+         (It was bound at $loc, but a nested declaration           cannot see type variables from its parent expression.)       </indent>       |]@@ -416,7 +417,7 @@     case unique fst llocs of       Nothing -> return ()       Just ((l, loc1), (_, loc2)) ->-        repeated "Type" l "abstype group" [loc1, loc2]+        repeated "Type declaration for" l "abstype group" [loc1, loc2]     (ats', mdD) <-       steal $         inModule mdT $@@ -465,7 +466,7 @@   case unique fst llocs of     Nothing -> return ()     Just ((l, loc1), (_, loc2)) ->-      repeated "Type" l "type group" [loc1, loc2]+      repeated "Type declaration for" l "type group" [loc1, loc2]   inModule md $ mapM (liftM snd . renameTyDec Nothing) tds  renameTyDec :: Maybe (QExp Raw) -> TyDec Raw ->@@ -570,43 +571,49 @@           repeated kind which "signature" []  sealWith :: Module -> R ()-sealWith md = case md of+sealWith = loop Nothing where+  loop b md = case md of     MdNil              -> return ()-    MdApp md1 md2      -> do sealWith md1; sealWith md2+    MdApp md1 md2      -> do loop b md1; loop b md2     MdTycon   _ l _   -> do-      (l', loc, _) <- find "type constructor" tycons l+      (l', loc, _) <- find b "type constructor" tycons l       tell (MdTycon loc l l')     MdVar     _ l _   -> do-      (l', loc, _) <- find "variable" vars l+      (l', loc, _) <- find b "variable" vars l       tell (MdVar loc l l')     MdDatacon _ u _   -> do-      (u', loc, _) <- find "data constructor" datacons u+      (u', loc, _) <- find b "data constructor" datacons u       tell (MdDatacon loc u u')     MdModule  _ u _ md2 -> do-      (u', loc, (md1, _)) <- find "module" modules u-      ((), md1') <- steal $ onlyInModule md1 $ sealWith md2+      (u', loc, (md1, _)) <- find b "module" modules u+      ((), md1') <- steal $ onlyInModule md1 $ loop b md2       tell (MdModule loc u u' md1')     MdSig     _ u _ md2 -> do-      (u', loc, (md1, _)) <- find "module type" sigs u-      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+      (u', loc, (md1, _)) <- find b "module type" sigs u+      ((), _   ) <- steal $ onlyInModule md2 $ loop (Just (Left u)) md1+      ((), md1') <- steal $ onlyInModule md1 $ loop (Just (Right u)) md2       tell (MdSig loc u u' md1')     MdTyvar   _ _ _   ->       renameBug "sealWith" "signature can’t declare type variable"-  where-    find what prj ident = do-      m <- asks prj-      case M.lookup ident m of-        Just ident' -> return ident'-        Nothing     -> renameError $-          [$msg|+  find b what prj ident = do+    m <- asks prj+    case M.lookup ident m of+      Just ident' -> return ident'+      Nothing     -> renameError $+        case b of+          Nothing -> [$msg|             In signature matching, structure is missing-            $words:what $qshow:ident,+            $words:what $q:ident,             which is present in ascribed signature.           |]+          Just (Left u) -> [$msg|+            In exact signature matching (for nested signature $u)+            found unexpected $words:what $q:ident.+          |]+          Just (Right u) -> [$msg|+            In exact signature matching (for nested signature $u)+            missing expected $words:what $q:ident.+          |]  -- | Rename a signature item and return the environment --   that they bind@@ -724,7 +731,7 @@   case unique (\(_,x,_,_) -> x) lxtes of     Nothing          -> return ()     Just ((l1,x,_,_),(l2,_,_,_)) ->-      repeated "Variable" x "let-rec" [l1, l2]+      repeated "Variable binding for" x "let-rec" [l1, l2]   let bindEach rest (l,x,t,e) = withLoc l $ do         x' <- bindVar x         return ((l,x',t,e):rest)

@@ -41,7 +41,7 @@                       TyPat, TyPat'(..)) import Loc import Env as Env-import Ppr ()+import Ppr (Ppr) import Type import TypeRel import Coercion (coerceExpression)@@ -57,11 +57,13 @@ import qualified Data.Map as M import qualified Data.Set as S +{- import System.IO.Unsafe (unsafePerformIO) pP :: Show a => a -> b -> b pP a b = unsafePerformIO (print a) `seq` b pM :: (Show a, Monad m) => a -> m () pM a = if pP a True then return () else fail "wibble"+-}  -- The kind of names we're using. type R = Renamed@@ -202,7 +204,7 @@ 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+  fail    = let ?loc = bogus in typeError . [$msg| $words:1 |]  instance Monad m => Applicative (TC m) where   pure  = return@@ -227,12 +229,12 @@   catchAlms = catchError  -- | Generate a type error.-typeError :: (AlmsMonad m, ?loc :: Loc) => MessageV -> m a-typeError msg = throwAlms (AlmsException RenamerPhase ?loc msg)+typeError :: (AlmsMonad m, ?loc :: Loc) => Message V -> m a+typeError msg0 = throwAlms (AlmsException StaticsPhase ?loc msg0)  -- | Indicate a type checker bug. typeBug :: AlmsMonad m => String -> String -> m a-typeBug culprit msg = throwAlms (almsBug RenamerPhase bogus culprit msg)+typeBug culprit msg0 = throwAlms (almsBug RenamerPhase bogus culprit msg0)  -- | Like 'ask', but monadic asksM :: MonadReader r m => (r -> m a) -> m a@@ -346,78 +348,42 @@ --- Type errors --- --- | Raise a type error, with the dynamically-bound source location-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, AlmsMonad m) =>-           Bool -> String -> m ()+            Bool -> Message V -> 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+tassert False m = typeError m  -- | A common form of type error: A got B where C expected-tgot :: (?loc :: Loc, AlmsMonad m) =>+terrgot :: (?loc :: Loc, AlmsMonad m) =>         String -> Type -> String -> m a-tgot who got expected = typeError $-  Flow [-    Words who,-    Words "got",-    Quote (Printable got),-    Words "where",-    Words expected,-    Words "expected."-  ]+terrgot who got expected = typeError+  [$msg| $words:who got $q:got where $words:expected expected. |] --- | Combination of 'tassert' and 'tgot'+-- | Combination of 'tassert and 'terrgot' tassgot :: (?loc :: Loc, AlmsMonad m) =>            Bool -> String -> Type -> String -> m ()-tassgot False = tgot+tassgot False = terrgot 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)]+           Message V -> Message V -> Message V -> m a+terrexp  = typeError <$$$> [$msg|+  $msg:1+  <dl>+    <dt>actual:   <dd>$msg:2+    <dt>expected: <dd>$msg:3+  </dl>+|]  -- | Common message pattern, actual vs. expected tassexp :: (?loc :: Loc, AlmsMonad m) =>-           Bool -> [MessageH] -> [MessageH] -> [MessageH] -> m ()+           Bool -> Message V -> Message V -> Message V -> 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, AlmsMonad m) => Maybe a -> String -> m a-m |! s = case m of-  Just r  -> return r-  _       -> terr s-infix 1 |!- -- | Conveniently weak-head normalize a type hnT :: Monad m => Type -> m Type hnT  = headNormalizeTypeM 100@@ -440,37 +406,36 @@     checkBound (tcBounds tc') ts'     return (tyApp tc' ts')     where+      actualLen = length ts       checkLength len =-        tassexp (length ts == len)-          [ Words "Type constructor",-            Quote (Showable n),-            Words "got wrong number of parameters:" ]-          [Showable (length ts)]-          [Showable len]+        tassexp (actualLen == len)+          [$msg| Type constructor $q:n got wrong number of parameters: |]+          [$msg| $actualLen |]+          [$msg| $len |]       checkBound quals ts' =         tassexp (all2 (\qlit t -> qualConst t <: qlit) quals ts')-          [ Words "Type constructor",-            Quote (Showable n),-            Words "used on higher qualifiers than permitted:" ]-          [Showable (map (qRepresent . qualifier) ts')]-          [Showable quals, Words "(or less)"]+          [$msg| Type constructor $q:n used on higher+                 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 [$ty| mu '$tv . $t |] = do+  tc t0@[$ty| mu '$tv . $t |] = do     case unfoldTyMu t of       (_, N _ (Syntax.TyVar tv')) | tv == tv' ->-        typeError $-          "Recursive type is not contractive:" !:: Syntax.tyMu tv t+        typeError [$msg| Recursive type is not contractive: $t0 |]       _ -> return ()     t' <- tc t-    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."-      ]+    let actqual = qualConst t'+        expqual = tvqual tv+    tassert (actqual == expqual)+       [$msg| Recursive type has qualifier that does+              not match its own bound type variable:+              <dl>+                <dt>actual qualifier:   <dd>$actqual+                <dt>expected qualifier: <dd>$expqual+                <dt>in type:            <dd>$5:t0+              </dl> |]     return (TyMu tv t')   tc [$ty| $anti:a |] = $antifail @@ -495,16 +460,21 @@         (ti, ei') <- inModule md $ tc (caexpr ca)         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 ++-                          " and " ++ show ti')-            t1 ts+      tr <- foldM (\ti' ti -> case ti' \/? ti of+        Just tr' -> return tr'+        Nothing  -> typeError [$msg|+          Mismatch in branches of match or let.  Cannot unify:+          <ul>+            <li>$ti+            <li>$ti'+          </ul>+        |]) t1 ts       return (tr, [$ex|+ match $e' with $list:clauses' |])     [$ex| let rec $list:bsN in $e2 |] -> do       let bs = map dataOf bsN       (tfs, md) <- steal $ forM bs $ \b -> do         t' <- tcType (bntype b)-        tassert' (syntacticValue (bnexpr b)) $+        tassert (syntacticValue (bnexpr b)) $           "Not a syntactic value in let rec:" !:: bnexpr b         tassgot (qualConst t' <: Qu)           "Let rec binding" t' "unlimited type"@@ -513,10 +483,10 @@       (tas, e's) <- liftM unzip $ inModule md $ mapM (tc . bnexpr) bs       zipWithM_ (\tf ta ->                    tassexp (ta <: tf)-                      [Words "In let rec, actual type does not",-                       Words "agree with declared type:"]-                      [Showable ta]-                      [Showable tf])+                      [$msg| In let rec, actual type does not+                             agree with declared type: |]+                      [$msg| $ta |]+                      [$msg| $tf |])                 tfs tas       (t2, e2') <- inModule md $ tc e2       let b's =@@ -542,7 +512,7 @@     [$ex| $_ $_ |] -> do       tcExApp tc e0     [$ex| fun '$tv -> $e |] -> do-      tassert' (syntacticValue e) $+      tassert (syntacticValue e) $         "Not a syntactic value under type abstraction:" !:: show e0       (t, e') <- tc e       return (tyAll tv t, [$ex|+ fun '$tv -> $e' |])@@ -560,27 +530,39 @@       case t1' of         TyQu Exists tv t11' -> do           te' <- tapply (tyAll tv t11') t2'-          tasstab (te <: te')-            [ Words "Could not pack existential:" ]-            [ ("concrete type:", [Showable te]),-              ("hiding:", [Showable t2]),-              ("to get:", [Showable t1']) ]+          tassert (te <: te')+            [$msg| Could not pack existential:+                   <dl>+                     <dt>concrete type: <dd>$te+                     <dt>hiding:        <dd>$t2+                     <dt>to get:        <dd>$t1'+                   </dl> |]           return (t1', [$ex| Pack[$stx:t1']($stx:t2', $e') |])-        _ -> tgot "Pack[-]" t1' "existential type"+        _ -> terrgot "Pack[-]" t1' "existential type"     [$ex| ( $e1 : $t2 ) |] -> do       (t1, e1') <- tc e1       t2'       <- tcType t2       tassexp (t1 <: t2')-        [Words "Type ascription mismatch:"]-        [Showable t1]-        [Showable t2']+        [$msg| Type ascription mismatch: |]+        [$msg| $t1 |]+        [$msg| $t2' |]       return (t2', e1')     [$ex| ( $e1 :> $t2 ) |] -> do       (t1, e1') <- tc e1       t2'       <- tcType t2       tassgot (castableType t2')-        "cast (:>)" t1 "function type"+        "Coercion (:>)" t1 "function type"       e1'' <- coerceExpression (e1' <<@ e0) t1 t2'+        `catchAlms` \AlmsException { exnMessage = m } ->+          typeError [$msg|+            Cannot constructor coercion+            <dl>+              <dt>from type: <dd>$t1+              <dt>to type:   <dd>$t2',+            </dl>+            because there is no coercion available+            $vmsg:m+          |]       -- tcExpr e1'' -- re-type check the coerced expression       return (t2', e1'')     [$ex| $anti:a |]    -> $antifail@@ -593,15 +575,9 @@     loop md0 = case md0 of       MdApp md1 md2     -> do loop md1; loop md2       MdValue (Var l) t ->-          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 ++ ".")-            ]+          tassert (qualConst t <: usage (J [] l) e)+            [$msg| Affine variable $q:l of type $q:t+                   duplicated in $words:name. |]       _                 -> return ()   --   -- | What is the join of the qualifiers of all free variables@@ -649,16 +625,16 @@       arrows (view -> TyFun _ ta tr) (t:ts) = do         b <- unifies [] t ta         tassexp b-          [Words "In application, operand type not in operator’s domain:"]-          [Showable t]-          [Showable ta]+          [$msg| In application, operand type not in operator’s domain: |]+          [$msg| $t |]+          [$msg| $ta |]         arrows tr ts       arrows (view -> TyMu tv t') ts = arrows (tysubst tv (TyMu tv t') t') ts       arrows t' (t:_) =         terrexp-          [Words "In application, operator is not a function:"]-          [Showable t']-          [Showable t, Words "-[...]> ..."]+          [$msg| In application, operator is not a function: |]+          [$msg| $t' |]+          [$msg| $t -[...]> ... |]       unifies tvs ta tf = do           ts <- tryUnify tvs ta tf           ta' <- foldM tapply (foldr tyAll ta tvs) ts@@ -681,14 +657,16 @@ tapply :: (?loc :: Loc, AlmsMonad m) =>           Type -> Type -> m Type tapply (view -> TyQu Forall tv t1') t2 = do-  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)])]+  tassert (qualConst t2 <: tvqual tv) $+    [$msg| Type application cannot instantiate type variable:+           <dl>+             <dt>type variable:     <dd>$tv+             <dt>expected qualifier:<dd>$1+             <dt>type given:        <dd>$t2+             <dt>actual qualifier:  <dd>$2+           </dl> |] (tvqual tv) (qRepresent (qualifier t2))   return (tysubst tv t2 t1')-tapply t1 _ = tgot "Type application" t1 "forall type"+tapply t1 _ = terrgot "Type application" t1 "forall type"  -- Given the type of thing to match and a pattern, return -- the type environment bound by that pattern.@@ -708,11 +686,13 @@           (params, res)             -> return (params, Nothing, res)         let te = tysubsts params ts res-        tasstab (t' <: te)-          [Words "Pattern got wrong type:"]-          [("actual:",     [Showable t']),-           ("expected:",   [Showable te]),-           ("in pattern:", [Showable x0])]+        tassert (t' <: te)+          [$msg| Pattern got wrong type:+                 <dl>+                   <dt>actual:     <dd>$t'+                   <dt>expected:   <dd>$te+                   <dt>in pattern: <dd>$x0+                 </dl> |]         case (mt, mx) of           (Nothing, Nothing) ->             return [$pa|+ $quid:u |]@@ -728,10 +708,11 @@             Nothing -> return x0             Just x  -> tcPatt tyBot x         | otherwise ->-            terrtab-              [Words "Pattern got wrong type:"]-              [("type:",    [Showable t']),-               ("pattern:", [Showable x0])]+            typeError [$msg| Pattern got wrong type:+                             <dl>+                               <dt>type:    <dd>$t'+                               <dt>pattern: <dd>$x0+                             </dl> |]   [$pa| ($x, $y) |] -> do     t' <- hnT t >>! mapBottom (tyApp tcTuple . replicate 2)     case t' of@@ -739,7 +720,7 @@         x' <- tcPatt xt x         y' <- tcPatt yt y         return [$pa| ($x', $y') |]-      _ -> tgot "Pattern " t' "pair type"+      _ -> terrgot "Pattern " t' "pair type"   [$pa| $str:_ |] -> do       tassgot (t <: tyString)         "Pattern" t "string"@@ -760,17 +741,21 @@     t' <- hnT t >>! mapBottom (tyEx tv)     case t' of       TyQu Exists tve te -> do-        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 qexp = tvqual tv+            qact = tvqual tve+        tassert (qact <: qexp)+          [$msg| Existential unpacking pattern cannot+                 instantiate type variable:+                 <dl>+                   <dt>pattern type variable: <dd>$tv+                   <dt>expected qualifier:    <dd>$qexp+                   <dt>actual type variable:  <dd>$tve+                   <dt>actual qualifier:      <dd>$qact+                 </dl> |]         let te' = tysubst tve (TyVar tv) te         x' <- tcPatt te' x         return [$pa| Pack('$tv, $x') |]-      _ -> tgot "Pattern" t' "existential type"+      _ -> terrgot "Pattern" t' "existential type"   [$pa| $antiL:a |] -> $antifail   [$pa| $anti:a |]  -> $antifail @@ -793,24 +778,17 @@     Right (_, ts)  -> return ts   where   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)-      ]-    ]+    [$msg| In application, cannot find substitution for type+           $msg:1 to unify types:+           <dl>+             <dt>actual:  <dd>$t'+             <dt>expected:<dd>$t+           </dl> |] $+      case tvs of+        [tv]      -> [$msg| variable $tv |]+        [tv1,tv2] -> [$msg| variables $tv1 and $tv2 |]+        _         -> [$msg| variables $flow:1 |]+                     (map [$msg| $1 |] tvs)  -- | Convert qualset representations from a list of all tyvars and --   list of qualifier-significant tyvars to a set of type parameter@@ -820,8 +798,9 @@ indexQuals name tvs qexp = do   qden <- qInterpretM qexp   numberQDenM unbound tvs qden where-  unbound tv = typeError $-    "unbound tyvar " ++ show tv ++ " in qualifier list for type" !:: name+  unbound tv = typeError+    [$msg| Unbound type variable $tv in qualifier list+           for type $q:name. |]  -- BEGIN type decl checking @@ -860,7 +839,7 @@        case tcNext tc of          Nothing      -> return ()          Just clauses -> forM_ clauses $ \(tps, rhs) ->-           tassert' (rhs /= tyPatToType (TpApp tc {tcNext = Nothing} tps)) $+           tassert (rhs /= tyPatToType (TpApp tc {tcNext = Nothing} tps)) $              "Recursive type synonym is not contractive:" !:: tc      tell (replaceTyCons tcs md')      return tds0@@ -900,11 +879,9 @@   TdSyn name cs -> do     tc   <- find (J [] name :: QLid R)     let nparams = length (fst (head cs))-    tassert' (all ((==) nparams . length . fst) cs) $-      Flow [-        Words "Not all type operator clauses have",-        Words "the same number of parameters."-      ]+    tassert (all ((==) nparams . length . fst) cs) $+      [$msg| In definition of type operator $q:name, not all+             clauses have the same number of parameters. |]     (cs', quals, vqs) <- liftM unzip3 $ forM cs $ \(tps, rhs) -> do       rhs' <- tcType rhs       let vs1 = ftvVs rhs'@@ -975,7 +952,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, AlmsMonad m, Ord node, Show node) =>+           (?loc :: Loc, AlmsMonad m, Ord node, Ppr node) =>            (a -> (node, S.Set node)) -> [a] -> m [a] topSort getEdge edges = do   (_, w) <- RWS.execRWST visitAll S.empty S.empty@@ -987,7 +964,7 @@     visit node = do       stack <- RWS.ask       lift $-        tassert' (not (node `S.member` stack)) $+        tassert (not (node `S.member` stack)) $           "Unproductive cycle in type definitions via type" !:: node       seen <- RWS.get       if node `S.member` seen@@ -1024,14 +1001,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 ++-    "has a variance annotation:" !:: var+  tassert (var == Invariant)+    [$msg| Type pattern variable $tv has a variance annotation+           $q:var.  Variances may not be specified for parameters+           of type operators, but are inferred. |]   return (TpVar tv) tcTyPat tp@[$tpQ| ($list:tps) $qlid:qu |] = do   let ?loc = _loc   tc <- find qu-  tassert' (isNothing (tcNext tc)) $+  tassert (isNothing (tcNext tc)) $     "Type operator pattern is also a type operator:" !:: tp   TpApp tc <$> mapM tcTyPat tps tcTyPat [$tpQ| $antiP:a |]             = $antifail@@ -1059,15 +1037,19 @@            [TyVar R] -> QLid R -> Type -> Module -> TC m () fibrate tvs ql t md = do     let Just tc = findTycon ql md-    tassert' (isAbstractTyCon 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 actlen = length tvs+        explen = length (tcArity tc)+    tassert (actlen == explen)+      [$msg| In signature fibration (with type), wrong number of+             parameters to type:+             <dl>+               <dt>actual count:   <dd>$actlen+               <dt>expected count: <dd>$explen+               <dt>for type:       <dd>$ql+             </dl> |]     let amap   = ftvVs t         arity  = map (\tv -> fromJust (M.lookup tv amap)) tvs         bounds = map tvqual tvs@@ -1121,26 +1103,30 @@          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)) $+  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 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])]+      tassert (qualConst t' == Qu) $+        [$msg| Declared type of let declaration of $q:x is not unlimited |]+      tassert (te <: t')+        [$msg| Mismatch in declared type for let declaration:+               <dl>+                 <dt>actual:     <dd>$te+                 <dt>expected:   <dd>$t'+                 <dt>in pattern: <dd>$x+               </dl> |]       return t'     Nothing -> do-      tasstab (qualConst te == Qu)-        [Words "Type of top-level binding is not unlimited:"]-        [("type:",       [Showable te]),-         ("qualifier:",  [Showable (qualifier te)]),-         ("in pattern:", [Showable x])]+      tassert (qualConst te == Qu) $+        [$msg| Type of let declaration binding is not unlimited:+               <dl>+                 <dt>type:       <dd>$te+                 <dt>qualifier:  <dd>$1+                 <dt>in pattern: <dd>$x+               </dl> |] (qRepresent (qualifier te))       return te   x' <- tcPatt t' x   return (x', Just (typeToStx t'), e')@@ -1293,18 +1279,18 @@         "in abstype declaration " ++ show (length params) ++         " parameters given for type " ++ show name ++         " which has " ++ show (length (tcArity 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]+      let actualArity = tcArity tc+          actualQual  = tcQual tc+      tassexp (all2 (<:) actualArity arity)+        [$msg| In abstype declaration, declared parameter variance for+               type $q:name is more permissive than actual variance: |]+        (pprMsg actualArity)+        (pprMsg arity)+      tassexp (actualQual <: qualSet)+        [$msg| In abstype declaration, declared qualifier for+               type $q:name is more permissive than actual qualifier: |]+        (showMsg actualQual)+        (showMsg qualSet)       return $ abstractTyCon tc {         tcQual  = qualSet,         tcArity = arity,@@ -1482,24 +1468,20 @@     MdValue x t    -> do       t' <- find (J [] x :: Ident R)       tassexp (t' <: t)-        [Words "In signature matching, type mismatch for",-         Quote (Showable x)]-        [Showable t']-        [Showable t]+        [$msg| In signature matching, type mismatch for $q:x: |]+        [$msg| $t' |]+        [$msg| $t |]     MdTycon x tc   -> do       tc' <- find (J [] x :: QLid R)       case varietyOf tc of         AbstractType -> do           let sigass assertion thing getter =                 tassexp assertion-                [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)]+                  ([$msg| In signature matching, cannot match the+                          definition for type $q:1 because the+                          $words:thing does not match: |] (tcName tc))+                  (showMsg (getter tc'))+                  (showMsg (getter tc))           sigass (length (tcArity tc') == length (tcArity tc))             "number of type parameters" (length . tcArity)           sigass (all2 (<:) (tcArity tc') (tcArity tc))@@ -1518,6 +1500,7 @@       matchSigs md2 md1  -- | Check that two signatures match EXACTLY.+--   First signature is what we have, and second is what we want. matchSigs :: (?loc :: Loc, Monad m) =>              Module -> Module -> TC m () matchSigs md10 md20 = loop (linearize md10 []) (linearize md20 []) where@@ -1537,18 +1520,32 @@       matchSigs md1 md2       loop sgs1 sgs2   loop [] (sg : _)          = do-    terr $ "cannot match signature item: " ++ name sg+    (x, what) <- whatIs sg+    typeError [$msg|+      In exact signature matching, missing expected $what $qmsg:x.+    |]   loop (sg : _) []          = do-    terr $ "cannot match signature item: " ++ name sg+    (x, what) <- whatIs sg+    typeError [$msg|+      In exact signature matching, found unexpected $what $qmsg:x.+    |]   loop (sg1 : _) (sg2 : _)  = do-    terr $ "cannot match signature items: " ++ name sg1 ++-           " and " ++ name sg2+    (x1, what1) <- whatIs sg1+    (x2, what2) <- whatIs sg2+    typeError [$msg|+      In exact signature matching (for signatures as entries in+      signatures being matched), got signature items didn’t match:+      <dl>+        <dt>actual:   <dd>$what1 $qmsg:x1+        <dt>expected: <dd>$what2 $qmsg:x2+      </dl>+    |]   ---  name (MdValue x _)  = "value " ++ show x-  name (MdTycon x _)  = "type " ++ show x-  name (MdModule x _) = "module " ++ show x-  name (MdSig x _)    = "module type " ++ show x-  name _              = error "BUG! in Statics.matchSigs"+  whatIs (MdValue x _)  = return (pprMsg x, "value")+  whatIs (MdTycon x _)  = return (pprMsg x, "type")+  whatIs (MdModule x _) = return (pprMsg x, "module")+  whatIs (MdSig x _)    = return (pprMsg x, "module type")+  whatIs _              = typeBug "matchSigs" "weird signature item"  -- | Extensional equality for type constructors tyconExtEq :: TyCon -> TyCon -> Bool@@ -1563,9 +1560,10 @@ matchTycons tc1 tc2 = case (varietyOf tc1, varietyOf tc2) of   (AbstractType, AbstractType) -> do     tassert (tcArity tc1 == tcArity tc2) $-      estr "the arity" (show (tcArity tc1)) (show (tcArity tc2))+      estr "the arity or variance"+           (show (tcArity tc1)) (show (tcArity tc2))     tassert (tcBounds tc1 == tcBounds tc2) $-      estr "parameter bounds" (show (tcBounds tc1)) (show (tcBounds tc2))+      estr "parameter bound" (show (tcBounds tc1)) (show (tcBounds tc2))     tassert (tcQual tc1 == tcQual tc2) $       estr "qualifier" (show (tcQual tc1)) (show (tcQual tc2))   (DataType, DataType) -> do@@ -1580,7 +1578,7 @@     forM_ (Env.toList rhs1') $ \(k, t1) ->       let Just t2 = rhs2' =..= k        in tassert (t1 == t2) $ estr-            ("constructor `" ++ show k ++ "'")+            ("constructor ‘" ++ show k ++ "’")             (maybe "nothing" show t1)             (maybe "nothing" show t2)   (OperatorType, _)            | tyconExtEq tc1 tc2 -> return ()@@ -1603,12 +1601,17 @@         tassert (t1' == t2') $           estr ("type operator right-hand sides in clause " ++ show ix)                (show t1') (show t2')-  (v1, v2) -> terr $ estr "kind of definition" (show v1) (show v2)+  (v1, v2) -> typeError $ estr "kind of definition" (show v1) (show v2)   where     estr what which1 which2 =-      "in signature matching, cannot match type definition for " ++-      show (tcName tc1) ++ " because the " ++ what ++-      " does not match (`" ++ which1 ++ "' vs. `" ++ which2 ++ "')"+      [$msg|+        In signature matching, cannot match definition for type+        $q:tc1 because the $words:what does not match:+        <dl>+          <dt>actual:   <dd>$which1+          <dt>expected: <dd>$which2+        </dl>+      |]  -- | Check that two type patterns match, and return the pairs of --   type variables that line up and thus need renaming.@@ -1620,8 +1623,9 @@   | tc1 == tc2   = mconcat `liftM` zipWithM matchTypats tvs1 tvs2 matchTypats tp1 tp2-  = terr $ "in signature matching, cannot match type patterns `" ++-           show tp1 ++ "' and `" ++ show tp2 ++ "'"+  = terrexp+      [$msg| In signature matching, cannot match type patterns: |]+      (pprMsg tp1) (pprMsg tp2)  -- | To flatten all the 'MdNil' and 'MdApp' constructors in a module --   into an ordinary list.

@@ -49,7 +49,7 @@   & "stx"    =:  appFun (TH.mkName "typeToStx'")   & "anti"   =:< 'TyAnti tyPatAntis-  = "typat"  =:  Nothing+  = "typat"  =:! Nothing   & "antiP"  =:< 'TpAnti quantAntis   = "quant"  =:  Nothing

@@ -129,9 +129,9 @@ instance Ord TyCon where   compare tc tc'  = compare (tcName tc) (tcName tc') -instance Ppr Type   where pprPrec p = pprPrec p . typeToStx+instance Ppr Type   where ppr = ppr . typeToStx instance Show Type  where showsPrec = showFromPpr-instance Ppr TyPat  where pprPrec p = pprPrec p . tyPatToStx+instance Ppr TyPat  where ppr = ppr . tyPatToStx instance Show TyPat where showsPrec = showFromPpr  -- | The different varieties of type definitions@@ -899,10 +899,10 @@         CMW.tell (replicate i ' ' ++ "}\n")  instance Ppr TyCon where-  ppr tc =+  ppr tc = atPrec 0 $     -- brackets (text (show (tcId tc))) <>     case tcNext tc of-      Just [(tps,t)] -> pprTyApp 0 (tcName tc) (ps (map snd tvs))+      Just [(tps,t)] -> pprTyApp (tcName tc) (ps (map snd tvs))                           >?> qe (map fst tvs)                             >?> char '=' <+> ppr t         where@@ -917,7 +917,7 @@                  | qlit <- tcBounds tc                  | i <- [ 1 :: Integer .. ] ]       ---      Just next -> pprTyApp 0 (tcName tc) (ps tvs)+      Just next -> pprTyApp (tcName tc) (ps tvs)                      >?> (qe tvs <+> text "with"                           $$ vcat (map alt next))         where@@ -927,7 +927,7 @@           alt (tps,t) = char '|' <+> pprPrec precApp tps <+> ppr (tcName tc)                           >?> char '=' <+> ppr t       ---      Nothing -> pprTyApp 0 (tcName tc) (ps tvs)+      Nothing -> pprTyApp (tcName tc) (ps tvs)                    >?> qe tvs                      >?> alts         where

@@ -31,7 +31,7 @@ import Util import Syntax (Uid(..), Type, Renamed, uid) import Ppr (Doc, text, Ppr(..), hang, sep, char, (<>), (<+>),-            parensIf, precCom, precApp)+            prec, prec1, ppr1, atPrec, precCom, precApp)  import qualified Control.Exception as Exn @@ -68,13 +68,9 @@   veqDyn       :: Valuable b => a -> b -> Bool   veqDyn a b    = maybe False (veq a) (vcast b) -  -- | Pretty-print a value at the given precedence-  vpprPrec     :: Int -> a -> Doc-  vpprPrec _ _  = text "#<->"--  -- | Pretty-print a value at top-level precedence+  -- | Pretty-print a value at current precedence   vppr         :: a -> Doc-  vppr          = vpprPrec 0+  vppr _        = text "#<->"    -- | Inject a Haskell value into the 'Value' type   vinj         :: a -> Value@@ -93,13 +89,12 @@   -- | Pretty-print a list of values.  (This is the same hack used   --   by 'Show' for printing 'String's differently than other   --   lists.)-  vpprPrecList :: Int -> [a] -> Doc-  vpprPrecList _ []     = text "nil"-  vpprPrecList p (x:xs) = parensIf (p > precApp) $-                            hang (text "cons" <+>-                                  vpprPrec (precApp + 1) x)-                                 1-                                 (vpprPrecList (precApp + 1) xs)+  vpprList :: [a] -> Doc+  vpprList []     = text "nil"+  vpprList (x:xs) = prec precApp $ prec1 $+                      hang (text "cons" <+> vppr x)+                           1+                           (vpprList xs)    -- | Inject a list.  As with the above, this lets us special-case   --   lists at some types (e.g. we inject Haskell 'String' as object@@ -154,7 +149,8 @@                   sep (funNameDocs fn) <> char '>'  instance Ppr Value where-  pprPrec = vpprPrec+  ppr     = vppr+  pprList = vpprList  instance Eq Value where   (==)    = veq@@ -164,41 +160,41 @@  instance Valuable a => Valuable [a] where   veq a b  = length a == length b && all2 veq a b-  vpprPrec = vpprPrecList+  vppr     = vpprList   vinj     = vinjList   vprjM    = vprjListM  instance Valuable Int where   veq        = (==)-  vpprPrec _ = text . show+  vppr       = ppr   vinj       = vinj . toInteger   vprjM v    = vprjM v >>= \z -> return (fromIntegral (z :: Integer))  instance Valuable Word16 where   veq        = (==)-  vpprPrec _ = text . show+  vppr       = vppr . toInteger   vinj       = vinj . toInteger   vprjM v    = vprjM v >>= \z -> return (fromIntegral (z :: Integer))  instance Valuable Word32 where   veq        = (==)-  vpprPrec _ = text . show+  vppr       = vppr . toInteger   vinj       = vinj . toInteger   vprjM v    = vprjM v >>= \z -> return (fromIntegral (z :: Integer))  instance Valuable CInt where   veq        = (==)-  vpprPrec _ = text . show+  vppr       = vppr . toInteger   vinj       = vinj . toInteger   vprjM v    = vprjM v >>= \z -> return (fromIntegral (z :: Integer))  instance Valuable Integer where   veq        = (==)-  vpprPrec _ = text . show+  vppr       = ppr  instance Valuable Double where   veq = (==)-  vpprPrec _ = text . show+  vppr = ppr  instance Valuable () where   veq        = (==)@@ -219,12 +215,11 @@   veq (VaCon c v) (VaCon d w) = c == d && v == w   veq (VaDyn a)   b           = veqDyn a b   veq _           _           = False-  vpprPrec p (VaFun n _)        = pprPrec p n-  vpprPrec p (VaCon c Nothing)  = pprPrec p c-  vpprPrec p (VaCon c (Just v)) = parensIf (p > precApp) $-                                    pprPrec precApp c <+>-                                    vpprPrec (precApp + 1) v-  vpprPrec p (VaDyn v)          = vpprPrec p v+  vppr (VaFun n _)            = ppr n+  vppr (VaCon c Nothing)      = ppr c+  vppr (VaCon c (Just v))     = prec precApp $+                                  ppr c <+> ppr1 v+  vppr (VaDyn v)              = vppr v   -- for value debugging:   {-   vpprPrec p (VaCon c Nothing)  = char '[' <> pprPrec p c <> char ']'@@ -236,16 +231,15 @@  instance Valuable Char where   veq            = (==)-  vpprPrec _     = text . show-  vpprPrecList _ = text . show+  vppr           = text . show+  vpprList       = text . show   vinjList       = VaDyn   vprjListM      = vcast  instance (Valuable a, Valuable b) => Valuable (a, b) where   veq (a, b) (a', b') = veq a a' && veq b b'-  vpprPrec p (a, b)   = parensIf (p > precCom) $-                          sep [vpprPrec precCom a <> char ',',-                               vpprPrec (precCom + 1) b]+  vppr (a, b)         = prec precCom $+                          sep [vppr a <> char ',', prec1 (vppr b)]   vinj (a, b) = VaDyn (vinj a, vinj b)   vprjM v = case vcast v of     Just (a, b) -> do@@ -283,7 +277,7 @@  instance (Eq a, Show a, Data a) => Valuable (Vinj a) where   veq        = (==)-  vpprPrec _ = text . show+  vppr       = text . show  instance Show a => Show (Vinj a) where   showsPrec p = showsPrec p . unVinj@@ -298,10 +292,10 @@  instance Valuable VExn where   veq        = (==)-  vpprPrec p = vpprPrec p . exnValue+  vppr       = vppr . exnValue  instance Show VExn where-  showsPrec p e = (show (vpprPrec p e) ++)+  showsPrec p e = (show (atPrec p (vppr e)) ++)  instance Exn.Exception VExn