diff --git a/Text/PrettyPrint/Mainland.hs b/Text/PrettyPrint/Mainland.hs --- a/Text/PrettyPrint/Mainland.hs +++ b/Text/PrettyPrint/Mainland.hs @@ -1,24 +1,25 @@ -- | -- Module : Text.PrettyPrint.Mainland --- Copyright : (c) Harvard University 2006-2011 --- (c) Geoffrey Mainland 2011-2012 +-- Copyright : (c) 2006-2011 Harvard University +-- (c) 2011-2012 Geoffrey Mainland +-- (c) 2015 Drexel University -- License : BSD-style -- Maintainer : mainland@eecs.harvard.edu -- -- Stability : provisional -- Portability : portable -- --- This module is based on /A Prettier Printer/ by Phil Wadler in /The Fun of --- Programming/, Jeremy Gibbons and Oege de Moor (eds) +-- This module is based on /A Prettier Printer/ by Phil Wadler in +-- /The Fun of Programming/, Jeremy Gibbons and Oege de Moor (eds) -- -- -- At the time it was originally written I didn't know about Daan Leijen's -- pretty printing module based on the same paper. I have since incorporated -- many of his improvements. This module is geared towards pretty printing --- source code; its main advantages over other libraries are a 'Pretty' class --- that handles precedence and the ability to automatically track the source --- locations associated with pretty printed values and output appropriate --- #line pragmas. +-- source code; its main advantages over other libraries are the ability to +-- automatically track the source locations associated with pretty printed +-- values and output appropriate #line pragmas and the use of +-- 'Data.Text.Lazy.Text' for output. {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} @@ -27,31 +28,39 @@ -- * The document type Doc, - -- * Basic combinators - empty, text, char, string, fromText, fromLazyText, - line, nest, srcloc, column, nesting, - softline, softbreak, group, - - -- * Operators - (<>), (<|>), (<+>), (), (<+/>), (), + -- * Constructing documents + -- ** Converting values into documents + text, bool, char, string, int, integer, float, double, rational, + strictText, lazyText, - -- * Character documents - backquote, colon, comma, dot, dquote, equals, semi, space, spaces, squote, - star, langle, rangle, lbrace, rbrace, lbracket, rbracket, lparen, rparen, + -- ** Simple documents documents + star, colon, comma, dot, equals, semi, space, spaces, + backquote, squote, dquote, + langle, rangle, lbrace, rbrace, lbracket, rbracket, lparen, rparen, - -- * Bracketing combinators - enclose, - angles, backquotes, braces, brackets, dquotes, parens, parensIf, squotes, + -- ** Basic document combinators + empty, + srcloc, line, softline, softbreak, + (<>), (<|>), (<+>), (), (<+/>), (), + group, - -- * Alignment and indentation - align, hang, indent, + -- ** Wrapping documents in delimiters + enclose, squotes, dquotes, angles, backquotes, braces, brackets, parens, + parensIf, -- * Combining lists of documents folddoc, spread, stack, cat, sep, punctuate, commasep, semisep, - encloseSep, - tuple, list, + enclosesep, tuple, list, + -- ** Alignment and indentation + align, hang, indent, + nest, column, nesting, + width, fill, fillbreak, + + -- ** Utilities + faildoc, errordoc, + -- * The rendered document type RDoc(..), @@ -63,12 +72,10 @@ displayPragmaLazyText, prettyPragmaLazyText, -- * Document output - putDoc, hPutDoc, + putDoc, putDocLn, hPutDoc, hPutDocLn, -- * The 'Pretty' type class for pretty printing - Pretty(..), - - faildoc, errordoc + Pretty(..) ) where import Data.Int @@ -85,6 +92,7 @@ import Data.Monoid (Monoid(..)) #endif /* !MIN_VERSION_base(4,5,0) */ import qualified Data.Set as Set +import Data.String (IsString(..)) import qualified Data.Text as T import qualified Data.Text.Lazy.IO as TIO import qualified Data.Text.Lazy as L @@ -93,30 +101,49 @@ import GHC.Real (Ratio(..)) import System.IO (Handle) -data Doc = Empty -- ^ The empty document - | Char Char -- ^ A single character - | String !Int String -- ^ 'String' with associated length (to avoid - -- recomputation) - | Text T.Text -- ^ 'T.Text' - | LazyText L.Text -- ^ 'L.Text' - | Line -- ^ Newline - | Nest !Int Doc -- ^ Indented document - | SrcLoc Loc -- ^ Tag output with source location - | Doc `Cat` Doc -- ^ Document concatenation - | Doc `Alt` Doc -- ^ Provide alternatives. Invariant: both - -- arguments must flatten to the same document. - | Column (Int -> Doc) -- ^ Calculate document based on current column - | Nesting (Int -> Doc) -- ^ Calculate document based on current nesting +-- | The abstract type of documents. +data Doc -- | The empty document + = Empty + -- | A single character + | Char {-# UNPACK #-} !Char + -- | 'String' with associated length (to avoid recomputation) + | String {-# UNPACK #-} !Int String + -- | 'T.Text' + | Text T.Text + -- | 'L.Text' + | LazyText L.Text + -- | Newline + | Line + -- | Indented document + | Nest {-# UNPACK #-} !Int Doc + -- | Tag output with source location + | SrcLoc Loc + -- | Document concatenation + | Doc `Cat` Doc + -- | Provide alternatives. Invariant: both arguments must flatten to + -- the same document. + | Doc `Alt` Doc + -- | Calculate document based on current column + | Column (Int -> Doc) + -- | Calculate document based on current nesting + | Nesting (Int -> Doc) --- | The empty document. -empty :: Doc -empty = Empty +instance Monoid Doc where + mempty = empty + mappend = Cat +instance IsString Doc where + fromString s = string s + -- | The document @'text' s@ consists of the string @s@, which should not -- contain any newlines. For a string that may include newlines, use 'string'. text :: String -> Doc text s = String (length s) s +-- | The document @bool b@ is equivalent to @text (show b)@. +bool :: Bool -> Doc +bool b = text (show b) + -- | The document @'char' c@ consists the single character @c@. char :: Char -> Doc char '\n' = line @@ -130,108 +157,40 @@ string s = case span (/= '\n') s of (xs, ys) -> text xs <> string ys --- | The document @'fromText' s@ consists of the 'T.Text' @s@, which should not --- contain any newlines. -fromText :: T.Text -> Doc -fromText = Text - --- | The document @'fromLazyText' s@ consists of the 'L.Text' @s@, which should --- not contain any newlines. -fromLazyText :: L.Text -> Doc -fromLazyText = LazyText - --- | The document @'line'@ advances to the next line and indents to the current --- indentation level. When undone by 'group', it behaves like 'space'. -line :: Doc -line = Line - --- | The document @'nest' i d@ renders the document @d@ with the current --- indentation level increased by @i@. -nest :: Int -> Doc -> Doc -nest i d = Nest i d - --- | The document @'srcloc' x@ tags the current line with @'locOf' x@. Only --- shown when running 'prettyPragma' and friends. -srcloc :: Located a => a -> Doc -srcloc x = SrcLoc (locOf x) - --- | The document @'column' f@ is produced by calling @f@ with the current colum. -column :: (Int -> Doc) -> Doc -column = Column - --- | The document @'column' f@ is produced by calling @f@ with the --- current nesting level. -nesting :: (Int -> Doc) -> Doc -nesting = Nesting - --- | Becomes 'space' if there is room, otherwise 'line'. --- --- > pretty 11 $ text "foo" <+/> text "bar" <+/> text "baz" =="foo bar baz" --- > pretty 7 $ text "foo" <+/> text "bar" <+/> text "baz" == "foo bar\nbaz" --- > pretty 6 $ text "foo" <+/> text "bar" <+/> text "baz" == "foo\nbar\nbaz" -softline :: Doc -softline = space `Alt` line - --- | Becomes 'empty' if there is room, otherwise 'line'. -softbreak :: Doc -softbreak = empty `Alt` line - --- | The document @'group' d@ will flatten @d@ to /one/ line if there is --- room for it, otherwise the original @d@. -group :: Doc -> Doc -group d = flatten d `Alt` d - -flatten :: Doc -> Doc -flatten Empty = Empty -flatten (Char c) = Char c -flatten (String l s) = String l s -flatten (Text s) = Text s -flatten (LazyText s) = LazyText s -flatten Line = Char ' ' -flatten (x `Cat` y) = flatten x `Cat` flatten y -flatten (Nest i x) = Nest i (flatten x) -flatten (x `Alt` _) = flatten x -flatten (SrcLoc loc) = SrcLoc loc -flatten (Column f) = Column (flatten . f) -flatten (Nesting f) = Nesting (flatten . f) - -#if !MIN_VERSION_base(4,5,0) -infixr 6 <> -#endif /* !MIN_VERSION_base(4,5,0) */ -infixr 6 <+> -infixr 5 , <+/>, -infixl 3 <|> +-- | The document @int i@ is equivalent to @text (show i)@. +int :: Int -> Doc +int i = text (show i) -#if !MIN_VERSION_base(4,5,0) --- | Concatenates two documents. -(<>) :: Doc -> Doc -> Doc -x <> y = x `Cat` y -#endif /* !MIN_VERSION_base(4,5,0) */ +-- | The document @integer i@ is equivalent to @text (show i)@. +-- 'text'. +integer :: Integer -> Doc +integer i = text (show i) --- | Concatenates two documents with a 'space' in between. -(<+>) :: Doc -> Doc -> Doc -x <+> y = x <> space <> y +-- | The document @float f@ is equivalent to @text (show f)@. +float :: Float -> Doc +float f = text (show f) --- | Concatenates two documents with a 'line' in between. -() :: Doc -> Doc -> Doc -x y = x <> line <> y +-- | The document @double d@ is equivalent to @text (show d)@. +double :: Double -> Doc +double d = text (show d) --- | Concatenates two documents with a 'softline' in between. -(<+/>) :: Doc -> Doc -> Doc -x <+/> y = x <> softline <> y +-- | The document @rational r@ is equivalent to @text (show r)@. +rational :: Rational -> Doc +rational r = text (show r) --- | Concatenates two documents with a 'softbreak' in between. -() :: Doc -> Doc -> Doc -x y = x <> softbreak <> y +-- | The document @'strictText' s@ consists of the 'T.Text' @s@, which should +-- not contain any newlines. +strictText :: T.Text -> Doc +strictText = Text --- | Provide alternative layouts of the same content. Invariant: both arguments must --- flatten to the same document. -(<|>) :: Doc -> Doc -> Doc -x <|> y = x `Alt` y +-- | The document @'lazyText' s@ consists of the 'L.Text' @s@, which should +-- not contain any newlines. +lazyText :: L.Text -> Doc +lazyText = LazyText --- | The document @backquote@ consists of a backquote, @\"`\"@. -backquote :: Doc -backquote = char '`' +-- | The document @star@ consists of an asterisk, @\"*\"@. +star :: Doc +star = char '*' -- | The document @colon@ consists of a colon, @\":\"@. colon :: Doc @@ -245,10 +204,6 @@ dot :: Doc dot = char '.' --- | The document @dquote@ consists of a double quote, @\"\\\"\"@. -dquote :: Doc -dquote = char '"' - -- | The document @equals@ consists of an equals sign, @\"=\"@. equals :: Doc equals = char '=' @@ -265,13 +220,17 @@ spaces :: Int -> Doc spaces n = text (replicate n ' ') +-- | The document @backquote@ consists of a backquote, @\"`\"@. +backquote :: Doc +backquote = char '`' + -- | The document @squote@ consists of a single quote, @\"\\'\"@. squote :: Doc squote = char '\'' --- | The document @star@ consists of an asterisk, @\"*\"@. -star :: Doc -star = char '*' +-- | The document @dquote@ consists of a double quote, @\"\\\"\"@. +dquote :: Doc +dquote = char '"' -- | The document @langle@ consists of a less-than sign, @\"<\"@. langle :: Doc @@ -305,6 +264,91 @@ rparen :: Doc rparen = char ')' +-- | The empty document. +empty :: Doc +empty = Empty + +-- | The document @'srcloc' x@ tags the current line with @'locOf' x@. Only +-- shown when running 'prettyPragma' and friends. +srcloc :: Located a => a -> Doc +srcloc x = SrcLoc (locOf x) + +-- | The document @'line'@ advances to the next line and indents to the current +-- indentation level. When undone by 'group', it behaves like 'space'. +line :: Doc +line = Line + +-- | Becomes 'space' if there is room, otherwise 'line'. +-- +-- > pretty 11 $ text "foo" <+/> text "bar" <+/> text "baz" =="foo bar baz" +-- > pretty 7 $ text "foo" <+/> text "bar" <+/> text "baz" == "foo bar\nbaz" +-- > pretty 6 $ text "foo" <+/> text "bar" <+/> text "baz" == "foo\nbar\nbaz" +softline :: Doc +softline = space `Alt` line + +-- | Becomes 'empty' if there is room, otherwise 'line'. +softbreak :: Doc +softbreak = empty `Alt` line + +#if !MIN_VERSION_base(4,5,0) +infixr 6 <> +#endif /* !MIN_VERSION_base(4,5,0) */ +infixr 6 <+> +infixr 5 , <+/>, +infixl 3 <|> + +#if !MIN_VERSION_base(4,5,0) +-- | Concatenates two documents. +(<>) :: Doc -> Doc -> Doc +x <> y = x `Cat` y +#endif /* !MIN_VERSION_base(4,5,0) */ + +-- | Concatenates two documents with a 'space' in between, with identity +-- 'empty'. +(<+>) :: Doc -> Doc -> Doc +Empty <+> y = y +x <+> Empty = x +x <+> y = x <> space <> y + +-- | Concatenates two documents with a 'line' in between. +() :: Doc -> Doc -> Doc +x y = x <> line <> y + +-- | Concatenates two documents with a 'softline' in between, with identity +-- 'empty'. +(<+/>) :: Doc -> Doc -> Doc +Empty <+/> y = y +x <+/> Empty = x +x <+/> y = x <> softline <> y + +-- | Concatenates two documents with a 'softbreak' in between. +() :: Doc -> Doc -> Doc +x y = x <> softbreak <> y + +-- | Provide alternative layouts of the same content. Invariant: both arguments +-- must flatten to the same document. +(<|>) :: Doc -> Doc -> Doc +x <|> y = x `Alt` y + +-- | The document @'group' d@ will flatten @d@ to /one/ line if there is +-- room for it, otherwise the original @d@. +group :: Doc -> Doc +group d = flatten d `Alt` d + +flatten :: Doc -> Doc +flatten Empty = Empty +flatten (Char c) = Char c +flatten (String l s) = String l s +flatten (Text s) = Text s +flatten (LazyText s) = LazyText s +flatten Line = Char ' ' +flatten (x `Cat` y) = flatten x `Cat` flatten y +flatten (Nest i x) = Nest i (flatten x) +flatten (x `Alt` _) = flatten x +flatten (SrcLoc loc) = SrcLoc loc +flatten (Column f) = Column (flatten . f) +flatten (Nesting f) = Nesting (flatten . f) + -- | The document @'enclose' l r d@ encloses the document @d@ between the -- documents @l@ and @r@ using @<>@. It obeys the law -- @@ -312,6 +356,14 @@ enclose :: Doc -> Doc -> Doc -> Doc enclose left right d = left <> d <> right +-- | The document @'squotes' d@ encloses the alinged document @d@ in \'...\'. +squotes :: Doc -> Doc +squotes = enclose squote squote . align + +-- | The document @'dquotes' d@ encloses the aligned document @d@ in "...". +dquotes :: Doc -> Doc +dquotes = enclose dquote dquote . align + -- | The document @'angles' d@ encloses the aligned document @d@ in \<...\>. angles :: Doc -> Doc angles = enclose langle rangle . align @@ -320,17 +372,13 @@ backquotes :: Doc -> Doc backquotes = enclose backquote backquote . align --- | The document @'brackets' d@ encloses the aligned document @d@ in [...]. -brackets :: Doc -> Doc -brackets = enclose lbracket rbracket . align - -- | The document @'braces' d@ encloses the aligned document @d@ in {...}. braces :: Doc -> Doc braces = enclose lbrace rbrace . align --- | The document @'dquotes' d@ encloses the aligned document @d@ in "...". -dquotes :: Doc -> Doc -dquotes = enclose dquote dquote . align +-- | The document @'brackets' d@ encloses the aligned document @d@ in [...]. +brackets :: Doc -> Doc +brackets = enclose lbracket rbracket . align -- | The document @'parens' d@ encloses the aligned document @d@ in (...). parens :: Doc -> Doc @@ -341,28 +389,6 @@ parensIf :: Bool -> Doc -> Doc parensIf True doc = parens doc parensIf False doc = doc - --- | The document @'squotes' d@ encloses the alinged document @d@ in \'...\'. -squotes :: Doc -> Doc -squotes = enclose squote squote . align - --- | The document @'align' d@ renders @d@ with a nesting level set to the current --- column. -align :: Doc -> Doc -align d = column $ \k -> - nesting $ \i -> - nest (k - i) d - --- | The document @'hang' i d@ renders @d@ with a nesting level set to the --- current column plus @i@, /not including/ the first line. -hang :: Int -> Doc -> Doc -hang i d = align (nest i d) - --- | The document @'indent' i d@ renders @d@ with a nesting level set to the --- current column plus @i@, /including/ the first line. -indent :: Int -> Doc -> Doc -indent i d = align (nest i (spaces i <> d)) - -- | The document @'folddoc' f ds@ obeys the laws: -- -- * @'folddoc' f [] = 'empty'@ @@ -408,14 +434,14 @@ semisep :: [Doc] -> Doc semisep = align . sep . punctuate semi --- | The document @'encloseSep' l r p ds@ separates @ds@ with the punctuation @p@ +-- | The document @'enclosesep' l r p ds@ separates @ds@ with the punctuation @p@ -- and encloses the result using @l@ and @r@. When wrapped, punctuation appears -- at the end of the line. The enclosed portion of the document is aligned one -- column to the right of the opening document. -- -- @ -- \> ws = map text (words \"The quick brown fox jumps over the lazy dog\") --- \> test = pretty 15 (encloseSep lparen rparen comma ws) +-- \> test = pretty 15 (enclosesep lparen rparen comma ws) -- @ -- -- will be layed out as: @@ -427,8 +453,8 @@ -- the, lazy, -- dog) -- @ -encloseSep :: Doc -> Doc -> Doc -> [Doc] -> Doc -encloseSep left right p ds = +enclosesep :: Doc -> Doc -> Doc -> [Doc] -> Doc +enclosesep left right p ds = case ds of [] -> left <> right [d] -> left <> d <> right @@ -437,25 +463,171 @@ -- | The document @'tuple' ds@ separates @ds@ with commas and encloses them with -- parentheses. tuple :: [Doc] -> Doc -tuple = encloseSep lparen rparen comma +tuple = enclosesep lparen rparen comma -- | The document @'list' ds@ separates @ds@ with commas and encloses them with -- brackets. list :: [Doc] -> Doc -list = encloseSep lbracket rbracket comma +list = enclosesep lbracket rbracket comma +-- | The document @'align' d@ renders @d@ with a nesting level set to the current +-- column. +align :: Doc -> Doc +align d = column $ \k -> + nesting $ \i -> + nest (k - i) d + +-- | The document @'hang' i d@ renders @d@ with a nesting level set to the +-- current column plus @i@, /not including/ the first line. +hang :: Int -> Doc -> Doc +hang i d = align (nest i d) + +-- | The document @'indent' i d@ renders @d@ with a nesting level set to the +-- current column plus @i@, /including/ the first line. +indent :: Int -> Doc -> Doc +indent i d = align (nest i (spaces i <> d)) + +-- | The document @'nest' i d@ renders the document @d@ with the current +-- indentation level increased by @i@. +nest :: Int -> Doc -> Doc +nest i d = Nest i d + +-- | The document @'column' f@ is produced by calling @f@ with the current +-- column. +column :: (Int -> Doc) -> Doc +column = Column + +-- | The document @'column' f@ is produced by calling @f@ with the +-- current nesting level. +nesting :: (Int -> Doc) -> Doc +nesting = Nesting + +-- | The document @'width' d f@ is produced by concatenating @d@ with the result +-- of calling @f@ with the width of the document @d@. +width :: Doc -> (Int -> Doc) -> Doc +width d f = column $ \k1 -> d <> (column $ \k2 -> f (k2 - k1)) + +-- | The document @'fill' i d@ renders document @x@, appending +-- @space@s until the width is equal to @i@. If the width of @d@ is already +-- greater than @i@, nothing is appended. +fill :: Int -> Doc -> Doc +fill f d = width d $ \w -> + if w >= f + then empty + else spaces (f - w) + +-- | The document @'fillbreak' i d@ renders document @d@, appending @'space'@s +-- until the width is equal to @i@. If the width of @d@ is already greater than +-- @i@, the nesting level is increased by @i@ and a @line@ is appended. +fillbreak :: Int -> Doc -> Doc +fillbreak f d = width d $ \w -> + if (w > f) + then nest f line + else spaces (f - w) + -- | Equivalent of 'fail', but with a document instead of a string. faildoc :: Monad m => Doc -> m a -faildoc = fail . show +faildoc = fail . pretty 80 -- | Equivalent of 'error', but with a document instead of a string. errordoc :: Doc -> a -errordoc = error . show +errordoc = error . pretty 80 +-- | A rendered document. +data RDoc -- | The empty document + = REmpty + -- | A single character + | RChar {-# UNPACK #-} !Char RDoc + -- | 'String' with associated length (to avoid recomputation) + | RString {-# UNPACK #-} !Int String RDoc + -- | 'T.Text' + | RText T.Text RDoc + -- | 'L.Text' + | RLazyText L.Text RDoc + -- | Tag output with source location + | RPos Pos RDoc + -- | A newline with the indentation of the subsequent line + | RLine {-# UNPACK #-} !Int RDoc + -- | Render a document given a maximum width. render :: Int -> Doc -> RDoc render w x = best w 0 x +type RDocS = RDoc -> RDoc + +data Docs -- | No document. + = Nil + -- | Indentation, document and tail + | Cons {-# UNPACK #-} !Int Doc Docs + +best :: Int -> Int -> Doc -> RDoc +best !w k x = be Nothing Nothing k id (Cons 0 x Nil) + where + be :: Maybe Pos -- ^ Previous source position + -> Maybe Pos -- ^ Current source position + -> Int -- ^ Current column + -> RDocS + -> Docs + -> RDoc + be _ _ !_ f Nil = f REmpty + be p p' !k f (Cons i d ds) = + case d of + Empty -> be p p' k f ds + Char c -> be p p' (k+1) (f . RChar c) ds + String l s -> be p p' (k+l) (f . RString l s) ds + Text s -> be p p' (k+T.length s) (f . RText s) ds + LazyText s -> be p p' (k+fromIntegral (L.length s)) (f . RLazyText s) ds + Line -> (f . pragma . RLine i) (be p'' Nothing i id ds) + x `Cat` y -> be p p' k f (Cons i x (Cons i y ds)) + Nest j x -> be p p' k f (Cons (i+j) x ds) + x `Alt` y -> better k f (be p p' k id (Cons i x ds)) + (be p p' k id (Cons i y ds)) + SrcLoc loc -> be p (merge p' loc) k f ds + Column g -> be p p' k f (Cons i (g k) ds) + Nesting g -> be p p' k f (Cons i (g i) ds) + where + (p'', pragma) = lineloc p p' + + better :: Int -> RDocS -> RDoc -> RDoc -> RDoc + better !k f x y | fits (w - k) x = f x + | otherwise = f y + + fits :: Int -> RDoc -> Bool + fits !w _ | w < 0 = False + fits !_ REmpty = True + fits !w (RChar _ x) = fits (w - 1) x + fits !w (RString l _ x) = fits (w - l) x + fits !w (RText s x) = fits (w - T.length s) x + fits !w (RLazyText s x) = fits (w - fromIntegral (L.length s)) x + fits !w (RPos _ x) = fits w x + fits !_ (RLine _ _) = True + + merge :: Maybe Pos -> Loc -> Maybe Pos + merge Nothing NoLoc = Nothing + merge Nothing (Loc p _) = Just p + merge (Just p) NoLoc = Just p + merge (Just p1) (Loc p2 _) = let p = min p1 p2 in p `seq` Just p + + lineloc :: Maybe Pos -- ^ Previous source position + -> Maybe Pos -- ^ Current source position + -> (Maybe Pos, RDocS) -- ^ Current source position and position to + -- output + lineloc Nothing Nothing = (Nothing, id) + lineloc Nothing (Just p) = (Just p, RPos p) + lineloc (Just p1) (Just p2) + | posFile p2 == posFile p1 && + posLine p2 == posLine p1 + 1 = (Just p2, id) + | otherwise = (Just p2, RPos p2) + lineloc (Just p1) Nothing + | posFile p2 == posFile p1 && + posLine p2 == posLine p1 + 1 = (Just p2, id) + | otherwise = (Just p2, RPos p2) + where + p2 = advance p1 + + advance :: Pos -> Pos + advance (Pos f l c coff) = Pos f (l+1) c coff + -- | Render a document without indentation on infinitely long lines. Since no -- \'pretty\' printing is involved, this renderer is fast. The resulting output -- contains fewer characters. @@ -579,106 +751,28 @@ prettyPragmaLazyText :: Int -> Doc -> L.Text prettyPragmaLazyText w x = displayPragmaLazyText (render w x) -merge :: Maybe Pos -> Loc -> Maybe Pos -merge Nothing NoLoc = Nothing -merge Nothing (Loc p _) = Just p -merge (Just p) NoLoc = Just p -merge (Just p1) (Loc p2 _) = let p = min p1 p2 in p `seq` Just p - -lineloc :: Maybe Pos -- ^ Previous source position - -> Maybe Pos -- ^ Current source position - -> (Maybe Pos, RDocS) -- ^ Current source position and position to - -- output -lineloc Nothing Nothing = (Nothing, id) -lineloc Nothing (Just p) = (Just p, RPos p) -lineloc (Just p1) (Just p2) - | posFile p2 == posFile p1 && - posLine p2 == posLine p1 + 1 = (Just p2, id) - | otherwise = (Just p2, RPos p2) -lineloc (Just p1) Nothing - | posFile p2 == posFile p1 && - posLine p2 == posLine p1 + 1 = (Just p2, id) - | otherwise = (Just p2, RPos p2) - where - p2 = advance p1 - - advance :: Pos -> Pos - advance (Pos f l c coff) = Pos f (l+1) c coff - --- | A rendered document. -data RDoc = REmpty -- ^ The empty document - | RChar Char RDoc -- ^ A single character - | RString !Int String RDoc -- ^ 'String' with associated length (to - -- avoid recomputation) - | RText T.Text RDoc -- ^ 'T.Text' - | RLazyText L.Text RDoc -- ^ 'L.Text' - | RPos Pos RDoc -- ^ Tag output with source location - | RLine !Int RDoc -- ^ A newline with the indentation of the - -- subsequent line - -type RDocS = RDoc -> RDoc - -data Docs = Nil -- ^ No document. - | Cons !Int Doc Docs -- ^ Indentation, document and tail - -best :: Int -> Int -> Doc -> RDoc -best !w k x = be Nothing Nothing k id (Cons 0 x Nil) - where - be :: Maybe Pos -- ^ Previous source position - -> Maybe Pos -- ^ Current source position - -> Int -- ^ Current column - -> RDocS - -> Docs - -> RDoc - be _ _ !_ f Nil = f REmpty - be p p' !k f (Cons i d ds) = - case d of - Empty -> be p p' k f ds - Char c -> be p p' (k+1) (f . RChar c) ds - String l s -> be p p' (k+l) (f . RString l s) ds - Text s -> be p p' (k+T.length s) (f . RText s) ds - LazyText s -> be p p' (k+fromIntegral (L.length s)) (f . RLazyText s) ds - Line -> (f . pragma . RLine i) (be p'' Nothing i id ds) - x `Cat` y -> be p p' k f (Cons i x (Cons i y ds)) - Nest j x -> be p p' k f (Cons (i+j) x ds) - x `Alt` y -> better k f (be p p' k id (Cons i x ds)) - (be p p' k id (Cons i y ds)) - SrcLoc loc -> be p (merge p' loc) k f ds - Column g -> be p p' k f (Cons i (g k) ds) - Nesting g -> be p p' k f (Cons i (g i) ds) - where - (p'', pragma) = lineloc p p' - - better :: Int -> RDocS -> RDoc -> RDoc -> RDoc - better !k f x y | fits (w - k) x = f x - | otherwise = f y - - fits :: Int -> RDoc -> Bool - fits !w _ | w < 0 = False - fits !_ REmpty = True - fits !w (RChar _ x) = fits (w - 1) x - fits !w (RString l _ x) = fits (w - l) x - fits !w (RText s x) = fits (w - T.length s) x - fits !w (RLazyText s x) = fits (w - fromIntegral (L.length s)) x - fits !w (RPos _ x) = fits w x - fits !_ (RLine _ _) = True - -- | Render a document with a width of 80 and print it to standard output. putDoc :: Doc -> IO () putDoc = TIO.putStr . prettyLazyText 80 +-- | Render a document with a width of 80 and print it to standard output, +-- followed by a newline. +putDocLn :: Doc -> IO () +putDocLn = TIO.putStrLn . prettyLazyText 80 + -- | Render a document with a width of 80 and print it to the specified handle. hPutDoc :: Handle -> Doc -> IO () hPutDoc h = TIO.hPutStr h . prettyLazyText 80 -instance Monoid Doc where - mempty = empty - mappend = Cat - -instance Show Doc where - showsPrec _ = prettyS 80 +-- | Render a document with a width of 80 and print it to the specified handle, +-- followed by a newline. +hPutDocLn :: Handle -> Doc -> IO () +hPutDocLn h = TIO.hPutStrLn h . prettyLazyText 80 class Pretty a where +#if __GLASGOW_HASKELL__ >= 708 + {-# MINIMAL pprPrec | ppr #-} +#endif ppr :: a -> Doc pprPrec :: Int -> a -> Doc pprList :: [a] -> Doc @@ -687,17 +781,31 @@ pprPrec _ = ppr pprList xs = list (map ppr xs) +instance Pretty a => Pretty [a] where + ppr = pprList + +instance Pretty a => Pretty (Maybe a) where + pprPrec _ Nothing = empty + pprPrec p (Just a) = pprPrec p a + +instance Pretty Bool where + ppr = bool + +instance Pretty Char where + ppr = char + pprList = string + instance Pretty Int where - ppr = text . show + ppr = int instance Pretty Integer where - ppr = text . show + ppr = integer instance Pretty Float where - ppr = text . show + ppr = float instance Pretty Double where - ppr = text . show + ppr = double ratioPrec, ratioPrec1 :: Int ratioPrec = 7 -- Precedence of ':%' constructor @@ -709,22 +817,65 @@ parensIf (p > ratioPrec) $ pprPrec ratioPrec1 x <+> char '%' <+> pprPrec ratioPrec1 y -instance Pretty Bool where +instance Pretty Word8 where ppr = text . show -instance Pretty Char where - ppr = text . show - pprList = text . show +instance Pretty Word16 where + ppr = text . show -instance Pretty T.Text where +instance Pretty Word32 where ppr = text . show -instance Pretty L.Text where +instance Pretty Word64 where ppr = text . show -instance Pretty a => Pretty [a] where - ppr = pprList +instance Pretty Int8 where + ppr = text . show +instance Pretty Int16 where + ppr = text . show + +instance Pretty Int32 where + ppr = text . show + +instance Pretty Int64 where + ppr = text . show + +instance Pretty T.Text where + ppr = strictText + +instance Pretty L.Text where + ppr = lazyText + +instance Pretty Pos where + ppr p@(Pos _ l c _) = + text (posFile p) <> colon <> ppr l <> colon <> ppr c + +instance Pretty Loc where + ppr NoLoc = text "" + + ppr (Loc p1@(Pos f1 l1 c1 _) p2@(Pos f2 l2 c2 _)) + | f1 == f2 = text (posFile p1) <> colon pprLineCol l1 c1 l2 c2 + | otherwise = ppr p1 <> text "-" <> ppr p2 + where + pprLineCol :: Int -> Int -> Int -> Int -> Doc + pprLineCol l1 c1 l2 c2 + | l1 == l2 && c1 == c2 = ppr l1 colon ppr c1 + | l1 == l2 && c1 /= c2 = ppr l1 colon + ppr c1 <> text "-" <> ppr c2 + | otherwise = ppr l1 colon ppr c1 + <> text "-" <> + ppr l2 colon ppr c2 + +instance Pretty x => Pretty (L x) where + pprPrec p (L _ x) = pprPrec p x + +instance (Pretty k, Pretty v) => Pretty (Map.Map k v) where + ppr = pprList . Map.toList + +instance Pretty a => Pretty (Set.Set a) where + ppr = pprList . Set.toList + instance Pretty () where ppr () = tuple [] @@ -828,60 +979,3 @@ tuple [ppr a, ppr b, ppr c, ppr d, ppr e, ppr f, ppr g, ppr h, ppr i, ppr j, ppr k, ppr l, ppr m, ppr n, ppr o] - -instance Pretty a => Pretty (Maybe a) where - pprPrec _ Nothing = empty - pprPrec p (Just a) = pprPrec p a - -instance Pretty Pos where - ppr p@(Pos _ l c _) = - text (posFile p) <> colon <> ppr l <> colon <> ppr c - -instance Pretty Loc where - ppr NoLoc = text "" - - ppr (Loc p1@(Pos f1 l1 c1 _) p2@(Pos f2 l2 c2 _)) - | f1 == f2 = text (posFile p1) <> colon pprLineCol l1 c1 l2 c2 - | otherwise = ppr p1 <> text "-" <> ppr p2 - where - pprLineCol :: Int -> Int -> Int -> Int -> Doc - pprLineCol l1 c1 l2 c2 - | l1 == l2 && c1 == c2 = ppr l1 colon ppr c1 - | l1 == l2 && c1 /= c2 = ppr l1 colon - ppr c1 <> text "-" <> ppr c2 - | otherwise = ppr l1 colon ppr c1 - <> text "-" <> - ppr l2 colon ppr c2 - -instance Pretty x => Pretty (L x) where - pprPrec p (L _ x) = pprPrec p x - -instance (Pretty k, Pretty v) => Pretty (Map.Map k v) where - ppr = pprList . Map.toList - -instance Pretty a => Pretty (Set.Set a) where - ppr = pprList . Set.toList - -instance Pretty Word8 where - ppr = text . show - -instance Pretty Word16 where - ppr = text . show - -instance Pretty Word32 where - ppr = text . show - -instance Pretty Word64 where - ppr = text . show - -instance Pretty Int8 where - ppr = text . show - -instance Pretty Int16 where - ppr = text . show - -instance Pretty Int32 where - ppr = text . show - -instance Pretty Int64 where - ppr = text . show diff --git a/mainland-pretty.cabal b/mainland-pretty.cabal --- a/mainland-pretty.cabal +++ b/mainland-pretty.cabal @@ -1,5 +1,5 @@ name: mainland-pretty -version: 0.3.0.0 +version: 0.4.0.0 cabal-version: >= 1.6 license: BSD3 license-file: LICENSE