diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -50,7 +50,7 @@ $(RM) html -VERSION = 0.4.10 +VERSION = 0.4.11 DISTDIR = alms-$(VERSION) TARBALL = $(DISTDIR).tar.gz diff --git a/alms.cabal b/alms.cabal --- a/alms.cabal +++ b/alms.cabal @@ -1,5 +1,5 @@ Name: alms -Version: 0.4.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, diff --git a/lib/libbasis.alms b/lib/libbasis.alms --- a/lib/libbasis.alms +++ b/lib/libbasis.alms @@ -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) diff --git a/src/Basis.hs b/src/Basis.hs --- a/src/Basis.hs +++ b/src/Basis.hs @@ -202,7 +202,7 @@ instance Valuable Ref where veq = (==) - vpprPrec _ _ = text "#" + vppr _ = text "#" -- | Built-in operations implemented in the object language srcBasis :: String diff --git a/src/Basis/Array.hs b/src/Basis/Array.hs --- a/src/Basis/Array.hs +++ b/src/Basis/Array.hs @@ -20,7 +20,7 @@ instance Valuable Array where veq = (==) - vpprPrec _ _ = text "#" + vppr _ = text "#" io :: IO a -> IO a io = id diff --git a/src/Basis/Channel.hs b/src/Basis/Channel.hs --- a/src/Basis/Channel.hs +++ b/src/Basis/Channel.hs @@ -19,7 +19,7 @@ instance Valuable Channel where veq = (==) - vpprPrec _ _ = text "#" + vppr _ = text "#" entries :: [Entry Raw] entries = [ diff --git a/src/Basis/Future.hs b/src/Basis/Future.hs --- a/src/Basis/Future.hs +++ b/src/Basis/Future.hs @@ -20,7 +20,7 @@ instance Valuable Future where veq = (==) - vpprPrec _ _ = text "#<(co)future>" + vppr _ = text "#<(co)future>" entries :: [Entry Raw] diff --git a/src/Basis/IO.hs b/src/Basis/IO.hs --- a/src/Basis/IO.hs +++ b/src/Basis/IO.hs @@ -19,11 +19,11 @@ instance Valuable IO.Handle where veq = (==) - vpprPrec _ _ = text "#" + vppr _ = text "#" instance Valuable IO.IOMode where veq = (==) - vpprPrec _ = text . show + vppr = text . show vinj = vinjData vprjM = vprjDataM deriving instance Typeable IO.IOMode diff --git a/src/Basis/MVar.hs b/src/Basis/MVar.hs --- a/src/Basis/MVar.hs +++ b/src/Basis/MVar.hs @@ -20,7 +20,7 @@ instance Valuable MVar where veq = (==) - vpprPrec _ _ = text "#" + vppr _ = text "#" entries :: [Entry Raw] entries = [ diff --git a/src/Basis/Socket.hs b/src/Basis/Socket.hs --- a/src/Basis/Socket.hs +++ b/src/Basis/Socket.hs @@ -20,11 +20,11 @@ instance Valuable S.Socket where veq = (==) - vpprPrec _ _ = text "#" + vppr _ = text "#" 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 diff --git a/src/Coercion.hs b/src/Coercion.hs --- a/src/Coercion.hs +++ b/src/Coercion.hs @@ -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| +
+
from type:
$t +
to type:
$t'. +
+ |] shadow :: [TyVarR] -> [TyVarR] -> M.Map (TyVarR, TyVarR) a -> M.Map (TyVarR, TyVarR) a diff --git a/src/Dynamics.hs b/src/Dynamics.hs --- a/src/Dynamics.hs +++ b/src/Dynamics.hs @@ -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 diff --git a/src/ErrorMessage.hs b/src/ErrorMessage.hs --- a/src/ErrorMessage.hs +++ b/src/ErrorMessage.hs @@ -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 . |] -(!::) :: Show a => String -> a -> Message d -msg0 !:: thing = [$msg| $words:msg0 $show:thing |] +(!::) :: Ppr a => String -> a -> Message d +msg0 !:: thing = [$msg| $words:msg0 $thing |] 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 + diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 $ diff --git a/src/Message/AST.hs b/src/Message/AST.hs --- a/src/Message/AST.hs +++ b/src/Message/AST.hs @@ -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 "" diff --git a/src/Message/Parser.hs b/src/Message/Parser.hs --- a/src/Message/Parser.hs +++ b/src/Message/Parser.hs @@ -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 diff --git a/src/Message/Quasi.hs b/src/Message/Quasi.hs --- a/src/Message/Quasi.hs +++ b/src/Message/Quasi.hs @@ -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) diff --git a/src/Message/Render.hs b/src/Message/Render.hs --- a/src/Message/Render.hs +++ b/src/Message/Render.hs @@ -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 diff --git a/src/Parser.hs b/src/Parser.hs --- a/src/Parser.hs +++ b/src/Parser.hs @@ -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 diff --git a/src/Ppr.hs b/src/Ppr.hs --- a/src/Ppr.hs +++ b/src/Ppr.hs @@ -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 diff --git a/src/PprClass.hs b/src/PprClass.hs --- a/src/PprClass.hs +++ b/src/PprClass.hs @@ -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 diff --git a/src/Prec.hs b/src/Prec.hs --- a/src/Prec.hs +++ b/src/Prec.hs @@ -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, diff --git a/src/PrettyPrint.hs b/src/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/src/PrettyPrint.hs @@ -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 diff --git a/src/Rename.hs b/src/Rename.hs --- a/src/Rename.hs +++ b/src/Rename.hs @@ -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: $show:a. |] + 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 $show:a + $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. - (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.) |] @@ -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) diff --git a/src/Statics.hs b/src/Statics.hs --- a/src/Statics.hs +++ b/src/Statics.hs @@ -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 +
+
actual:
$msg:2 +
expected:
$msg:3 +
+|] -- | 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: +
+
actual qualifier:
$actqual +
expected qualifier:
$expqual +
in type:
$5:t0 +
|] 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: +
    +
  • $ti +
  • $ti' +
+ |]) 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: +
+
concrete type:
$te +
hiding:
$t2 +
to get:
$t1' +
|] 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 +
+
from type:
$t1 +
to type:
$t2', +
+ 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: +
+
type variable:
$tv +
expected qualifier:
$1 +
type given:
$t2 +
actual qualifier:
$2 +
|] (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: +
+
actual:
$t' +
expected:
$te +
in pattern:
$x0 +
|] 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: +
+
type:
$t' +
pattern:
$x0 +
|] [$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: +
+
pattern type variable:
$tv +
expected qualifier:
$qexp +
actual type variable:
$tve +
actual qualifier:
$qact +
|] 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: +
+
actual:
$t' +
expected:
$t +
|] $ + 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: +
+
actual count:
$actlen +
expected count:
$explen +
for type:
$ql +
|] 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: +
+
actual:
$te +
expected:
$t' +
in pattern:
$x +
|] 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: +
+
type:
$te +
qualifier:
$1 +
in pattern:
$x +
|] (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: +
+
actual:
$what1 $qmsg:x1 +
expected:
$what2 $qmsg:x2 +
+ |] -- - 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: +
+
actual:
$which1 +
expected:
$which2 +
+ |] -- | 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. diff --git a/src/Syntax/SyntaxTable.hs b/src/Syntax/SyntaxTable.hs --- a/src/Syntax/SyntaxTable.hs +++ b/src/Syntax/SyntaxTable.hs @@ -49,7 +49,7 @@ & "stx" =: appFun (TH.mkName "typeToStx'") & "anti" =:< 'TyAnti tyPatAntis - = "typat" =: Nothing + = "typat" =:! Nothing & "antiP" =:< 'TpAnti quantAntis = "quant" =: Nothing diff --git a/src/Type.hs b/src/Type.hs --- a/src/Type.hs +++ b/src/Type.hs @@ -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 diff --git a/src/Value.hs b/src/Value.hs --- a/src/Value.hs +++ b/src/Value.hs @@ -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