diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,12 @@ # Pretty library change log +## 1.1.2.0 -- 25th December, 2014 + +* Merge in prettyclass package -- new Text.PrettyPrint.HughesPHClass. +* Add in 'maybe\*' variants of various bracket functins. +* Add Generic instances for appropriate data types. +* Fix compilation under GHC 7.10 + ## 1.1.1.3 -- 21st December, 2014 * Remove upper bound on `deepseq` package to fix build issues with @@ -13,19 +20,6 @@ * Update pretty cabal file and readme. * Fix tests to work with latest quickcheck. - -## Version 4.0, 24 August 2011 - -* Big change to the structure of the library. Now we don't have a fixed - TextDetails data type for storing the various String types that we - support. Instead we have changed that to be a type class that just - provides a way to convert String and Chars to an arbitary type. This - arbitary type is now provided by the user of the library so that they - can implement support very easily for any String type they want. - - This new code lives in Text.PrettyPrint.Core and the Text.PrettyPrint - module uses it to implement the old API. The Text.PrettyPrint.HughesPJ - module has been left unchanged for a compatability module but deprecated. ## Version 3.0, 28 May 1987 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -11,7 +11,6 @@ Programming, 1995. It can be found [here](http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.38.8777). - ## Licensing This library is BSD-licensed. @@ -19,23 +18,25 @@ ## Building The library uses the Cabal build system, so building is simply a -matter of running +matter of running: ``` +cabal sandbox init +cabal install "QuickCheck >= 2.5 && < 3" +cabal install --only-dependencies cabal configure --enable-tests cabal build +cabal test ``` -## Branches - -Usually two branches are maintained for Pretty development: - - * master: This branch is generally kept in a stable state and is - where release are pulled and made from. The reason for this is GHC - includes the pretty library and tracks the master branch by default - so we don't want experimental code being pulled into GHC at times. +We have to install `QuickCheck` manually as otherwise Cabal currently +throws an error due to the cyclic dependency between `pretty` and +`QuickCheck`. - * next: This branch is the general development branch. +*If `cabal test` freezes*, then run +`cabal test --show-details=streaming` instead. This is due to a +[bug](https://github.com/haskell/cabal/issues/1810) in certain +versions of Cabal. ## Get involved! diff --git a/pretty.cabal b/pretty.cabal --- a/pretty.cabal +++ b/pretty.cabal @@ -1,5 +1,5 @@ name: pretty -version: 1.1.1.3 +version: 1.1.2.0 synopsis: Pretty-printing library description: This package contains a pretty-printing library, a set of API's @@ -30,9 +30,11 @@ exposed-modules: Text.PrettyPrint Text.PrettyPrint.HughesPJ + Text.PrettyPrint.HughesPJClass build-depends: base >= 3 && < 5, - deepseq >= 1.1 - extensions: CPP, BangPatterns + deepseq >= 1.1, + ghc-prim + extensions: CPP, BangPatterns, DeriveGeneric ghc-options: -Wall -fwarn-tabs Test-Suite test-pretty @@ -41,12 +43,15 @@ src build-depends: base >= 3 && < 5, deepseq >= 1.1, + ghc-prim, QuickCheck >= 2.5 && <3 main-is: Test.hs other-modules: TestGenerators TestStructures - extensions: CPP, BangPatterns + UnitPP1 + UnitT3911 + extensions: CPP, BangPatterns, DeriveGeneric include-dirs: src/Text/PrettyPrint -- Executable Bench1 diff --git a/src/Text/PrettyPrint.hs b/src/Text/PrettyPrint.hs --- a/src/Text/PrettyPrint.hs +++ b/src/Text/PrettyPrint.hs @@ -7,12 +7,13 @@ -- Copyright : (c) The University of Glasgow 2001 -- License : BSD-style (see the file LICENSE) -- --- Maintainer : David Terei +-- Maintainer : David Terei -- Stability : stable -- Portability : portable -- --- The default interface to the pretty-printing library. Provides a collection --- of pretty printer combinators. +-- Provides a collection of pretty printer combinators, a set of API's +-- that provides a way to easily print out text in a consistent format +-- of your choosing. -- -- This module should be used as opposed to the "Text.PrettyPrint.HughesPJ" -- module. Both are equivalent though as this module simply re-exports the diff --git a/src/Text/PrettyPrint/HughesPJ.hs b/src/Text/PrettyPrint/HughesPJ.hs --- a/src/Text/PrettyPrint/HughesPJ.hs +++ b/src/Text/PrettyPrint/HughesPJ.hs @@ -2,6 +2,7 @@ {-# LANGUAGE BangPatterns #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Safe #-} +{-# LANGUAGE DeriveGeneric #-} #endif ----------------------------------------------------------------------------- @@ -10,7 +11,7 @@ -- Copyright : (c) The University of Glasgow 2001 -- License : BSD-style (see the file LICENSE) -- --- Maintainer : David Terei +-- Maintainer : David Terei -- Stability : stable -- Portability : portable -- @@ -41,6 +42,7 @@ -- ** Wrapping documents in delimiters parens, brackets, braces, quotes, doubleQuotes, + maybeParens, maybeBrackets, maybeBraces, maybeQuotes, maybeDoubleQuotes, -- ** Combining documents empty, @@ -77,9 +79,13 @@ import Control.DeepSeq ( NFData(rnf) ) import Data.Function ( on ) -import Data.Monoid ( Monoid(mempty, mappend) ) +#if __GLASGOW_HASKELL__ < 709 +import Data.Monoid ( Monoid(mempty, mappend) ) +#endif import Data.String ( IsString(fromString) ) +import GHC.Generics + -- --------------------------------------------------------------------------- -- The Doc calculus @@ -177,6 +183,9 @@ | NoDoc -- The empty set of documents | Beside Doc Bool Doc -- True <=> space between | Above Doc Bool Doc -- True <=> never overlap +#if __GLASGOW_HASKELL__ >= 701 + deriving (Generic) +#endif {- Here are the invariants: @@ -224,6 +233,9 @@ | PStr String -- ^ Used to represent a Fast String fragment -- but now deprecated and identical to the -- Str constructor. +#if __GLASGOW_HASKELL__ >= 701 + deriving (Show, Eq, Generic) +#endif -- Combining @Doc@ values instance Monoid Doc where @@ -359,9 +371,9 @@ lbrace = char '{' rbrace = char '}' -space_text, nl_text :: TextDetails -space_text = Chr ' ' -nl_text = Chr '\n' +spaceText, nlText :: TextDetails +spaceText = Chr ' ' +nlText = Chr '\n' int :: Int -> Doc -- ^ @int n = text (show n)@ integer :: Integer -> Doc -- ^ @integer n = text (show n)@ @@ -385,7 +397,31 @@ brackets p = char '[' <> p <> char ']' braces p = char '{' <> p <> char '}' +-- | Apply 'parens' to 'Doc' if boolean is true. +maybeParens :: Bool -> Doc -> Doc +maybeParens False = id +maybeParens True = parens +-- | Apply 'brackets' to 'Doc' if boolean is true. +maybeBrackets :: Bool -> Doc -> Doc +maybeBrackets False = id +maybeBrackets True = brackets + +-- | Apply 'braces' to 'Doc' if boolean is true. +maybeBraces :: Bool -> Doc -> Doc +maybeBraces False = id +maybeBraces True = braces + +-- | Apply 'quotes' to 'Doc' if boolean is true. +maybeQuotes :: Bool -> Doc -> Doc +maybeQuotes False = id +maybeQuotes True = quotes + +-- | Apply 'doubleQuotes' to 'Doc' if boolean is true. +maybeDoubleQuotes :: Bool -> Doc -> Doc +maybeDoubleQuotes False = id +maybeDoubleQuotes True = doubleQuotes + -- --------------------------------------------------------------------------- -- Structural operations on GDocs @@ -466,17 +502,17 @@ reduceAB doc = doc nilAbove_ :: RDoc -> RDoc -nilAbove_ p = NilAbove p +nilAbove_ = NilAbove -- Arg of a TextBeside is always an RDoc textBeside_ :: TextDetails -> Int -> RDoc -> RDoc -textBeside_ s sl p = TextBeside s sl p +textBeside_ = TextBeside nest_ :: Int -> RDoc -> RDoc -nest_ k p = Nest k p +nest_ = Nest union_ :: RDoc -> RDoc -> RDoc -union_ p q = Union p q +union_ = Union -- --------------------------------------------------------------------------- @@ -516,7 +552,7 @@ above :: Doc -> Bool -> RDoc -> RDoc above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2) -above p@(Beside _ _ _) g q = aboveNest (reduceDoc p) g 0 (reduceDoc q) +above p@(Beside{}) g q = aboveNest (reduceDoc p) g 0 (reduceDoc q) above p g q = aboveNest p g 0 (reduceDoc q) -- Specfication: aboveNest p g k q = p $g$ (nest k q) @@ -584,7 +620,7 @@ beside p@(Beside p1 g1 q1) g2 q2 | g1 == g2 = beside p1 g1 $! beside q1 g2 q2 | otherwise = beside (reduceDoc p) g2 q2 -beside p@(Above _ _ _) g q = let !d = reduceDoc p in beside d g q +beside p@(Above{}) g q = let !d = reduceDoc p in beside d g q beside (NilAbove p) g q = nilAbove_ $! beside p g q beside (TextBeside s sl p) g q = textBeside_ s sl $! rest where @@ -597,7 +633,7 @@ nilBeside :: Bool -> RDoc -> RDoc nilBeside _ Empty = Empty -- Hence the text "" in the spec nilBeside g (Nest _ p) = nilBeside g p -nilBeside g p | g = textBeside_ space_text 1 p +nilBeside g p | g = textBeside_ spaceText 1 p | otherwise = p @@ -728,8 +764,7 @@ -> Int -- Ribbon length -> RDoc -> RDoc -- No unions in here! -best w0 r p0 - = get w0 p0 +best w0 r = get w0 where get w _ | w == 0 && False = undefined get _ Empty = Empty @@ -753,7 +788,7 @@ get1 _ _ (Beside {}) = error "best get1 Beside" nicest :: Int -> Int -> Doc -> Doc -> Doc -nicest !w !r p q = nicest1 w r 0 p q +nicest !w !r = nicest1 w r 0 nicest1 :: Int -> Int -> Int -> Doc -> Doc -> Doc nicest1 !w !r !sl p q | fits ((w `min` r) - sl) p = p @@ -808,6 +843,9 @@ , lineLength :: Int -- ^ Length of line, in chars , ribbonsPerLine :: Float -- ^ Ratio of line length to ribbon length } +#if __GLASGOW_HASKELL__ >= 701 + deriving (Show, Eq, Generic) +#endif -- | The default style (@mode=PageMode, lineLength=100, ribbonsPerLine=1.5@). style :: Style @@ -818,16 +856,19 @@ | ZigZagMode -- ^ With zig-zag cuts | LeftMode -- ^ No indentation, infinitely long lines | OneLineMode -- ^ All on one line +#if __GLASGOW_HASKELL__ >= 701 + deriving (Show, Eq, Generic) +#endif -- | Render the @Doc@ to a String using the default @Style@. render :: Doc -> String -render doc = fullRender (mode style) (lineLength style) (ribbonsPerLine style) - txtPrinter "" doc +render = fullRender (mode style) (lineLength style) (ribbonsPerLine style) + txtPrinter "" -- | Render the @Doc@ to a String using the given @Style@. renderStyle :: Style -> Doc -> String -renderStyle s doc = fullRender (mode s) (lineLength s) (ribbonsPerLine s) - txtPrinter "" doc +renderStyle s = fullRender (mode s) (lineLength s) (ribbonsPerLine s) + txtPrinter "" -- | Default TextDetails printer txtPrinter :: TextDetails -> String -> String @@ -844,9 +885,9 @@ -> Doc -- ^ The document -> a -- ^ Result fullRender OneLineMode _ _ txt end doc - = easy_display space_text (\_ y -> y) txt end (reduceDoc doc) + = easyDisplay spaceText (\_ y -> y) txt end (reduceDoc doc) fullRender LeftMode _ _ txt end doc - = easy_display nl_text first txt end (reduceDoc doc) + = easyDisplay nlText first txt end (reduceDoc doc) fullRender m lineLen ribbons txt rest doc = display m lineLen ribbonLen txt rest doc' @@ -859,23 +900,23 @@ ZigZagMode -> maxBound _ -> lineLen -easy_display :: TextDetails +easyDisplay :: TextDetails -> (Doc -> Doc -> Doc) -> (TextDetails -> a -> a) -> a -> Doc -> a -easy_display nl_space_text choose txt end doc - = lay doc +easyDisplay nlSpaceText choose txt end + = lay where - lay NoDoc = error "easy_display: NoDoc" + lay NoDoc = error "easyDisplay: NoDoc" lay (Union p q) = lay (choose p q) lay (Nest _ p) = lay p lay Empty = end - lay (NilAbove p) = nl_space_text `txt` lay p + lay (NilAbove p) = nlSpaceText `txt` lay p lay (TextBeside s _ p) = s `txt` lay p - lay (Above {}) = error "easy_display Above" - lay (Beside {}) = error "easy_display Beside" + lay (Above {}) = error "easyDisplay Above" + lay (Beside {}) = error "easyDisplay Beside" display :: Mode -> Int -> Int -> (TextDetails -> a -> a) -> a -> Doc -> a display m !page_width !ribbon_width txt end doc @@ -885,19 +926,19 @@ lay k _ | k `seq` False = undefined lay k (Nest k1 p) = lay (k + k1) p lay _ Empty = end - lay k (NilAbove p) = nl_text `txt` lay k p + lay k (NilAbove p) = nlText `txt` lay k p lay k (TextBeside s sl p) = case m of ZigZagMode | k >= gap_width - -> nl_text `txt` ( + -> nlText `txt` ( Str (replicate shift '/') `txt` ( - nl_text `txt` + nlText `txt` lay1 (k - shift) s sl p )) | k < 0 - -> nl_text `txt` ( + -> nlText `txt` ( Str (replicate shift '\\') `txt` ( - nl_text `txt` + nlText `txt` lay1 (k + shift) s sl p )) _ -> lay1 k s sl p @@ -910,7 +951,7 @@ in Str (indent k) `txt` (s `txt` lay2 r p) lay2 k _ | k `seq` False = undefined - lay2 k (NilAbove p) = nl_text `txt` lay k p + lay2 k (NilAbove p) = nlText `txt` lay k p lay2 k (TextBeside s sl p) = s `txt` lay2 (k + sl) p lay2 k (Nest _ p) = lay2 k p lay2 _ Empty = end diff --git a/src/Text/PrettyPrint/HughesPJClass.hs b/src/Text/PrettyPrint/HughesPJClass.hs new file mode 100644 --- /dev/null +++ b/src/Text/PrettyPrint/HughesPJClass.hs @@ -0,0 +1,146 @@ +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Safe #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : Text.PrettyPrint.HughesPJClass +-- Copyright : (c) Lennart Augustsson 2014 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : David Terei +-- Stability : stable +-- Portability : portable +-- +-- Pretty printing class, simlar to 'Show' but nicer looking. +-- +-- Note that the precedence level is a 'Rational' so there is an unlimited +-- number of levels. This module re-exports 'Text.PrettyPrint.HughesPJ'. +-- +----------------------------------------------------------------------------- + +module Text.PrettyPrint.HughesPJClass ( + -- * Pretty typeclass + Pretty(..), + + PrettyLevel(..), prettyNormal, + prettyShow, prettyParen, + + -- re-export HughesPJ + module Text.PrettyPrint.HughesPJ + ) where + +import Text.PrettyPrint.HughesPJ + +-- | Level of detail in the pretty printed output. +-- Level 0 is the least detail. +newtype PrettyLevel = PrettyLevel Int + deriving (Eq, Ord, Show) + +-- | The "normal" (Level 0) of detail. +prettyNormal :: PrettyLevel +prettyNormal = PrettyLevel 0 + +-- | Pretty printing class. The precedence level is used in a similar way as in +-- the 'Show' class. Minimal complete definition is either 'pPrintPrec' or +-- 'pPrint'. +class Pretty a where + pPrintPrec :: PrettyLevel -> Rational -> a -> Doc + pPrintPrec _ _ = pPrint + + pPrint :: a -> Doc + pPrint = pPrintPrec prettyNormal 0 + + pPrintList :: PrettyLevel -> [a] -> Doc + pPrintList l = brackets . fsep . punctuate comma . map (pPrintPrec l 0) + +#if __GLASGOW_HASKELL__ >= 708 + {-# MINIMAL pPrintPrec | pPrint #-} +#endif + +-- | Pretty print a value with the 'prettyNormal' level. +prettyShow :: (Pretty a) => a -> String +prettyShow = render . pPrint + +pPrint0 :: (Pretty a) => PrettyLevel -> a -> Doc +pPrint0 l = pPrintPrec l 0 + +appPrec :: Rational +appPrec = 10 + +-- | Parenthesize an value if the boolean is true. +{-# DEPRECATED prettyParen "Please use 'maybeParens' instead" #-} +prettyParen :: Bool -> Doc -> Doc +prettyParen = maybeParens + +-- Various Pretty instances +instance Pretty Int where pPrint = int + +instance Pretty Integer where pPrint = integer + +instance Pretty Float where pPrint = float + +instance Pretty Double where pPrint = double + +instance Pretty () where pPrint _ = text "()" + +instance Pretty Bool where pPrint = text . show + +instance Pretty Ordering where pPrint = text . show + +instance Pretty Char where + pPrint = char + pPrintList _ = text . show + +instance (Pretty a) => Pretty (Maybe a) where + pPrintPrec _ _ Nothing = text "Nothing" + pPrintPrec l p (Just x) = + prettyParen (p > appPrec) $ text "Just" <+> pPrintPrec l (appPrec+1) x + +instance (Pretty a, Pretty b) => Pretty (Either a b) where + pPrintPrec l p (Left x) = + prettyParen (p > appPrec) $ text "Left" <+> pPrintPrec l (appPrec+1) x + pPrintPrec l p (Right x) = + prettyParen (p > appPrec) $ text "Right" <+> pPrintPrec l (appPrec+1) x + +instance (Pretty a) => Pretty [a] where + pPrintPrec l _ = pPrintList l + +instance (Pretty a, Pretty b) => Pretty (a, b) where + pPrintPrec l _ (a, b) = + parens $ fsep $ punctuate comma [pPrint0 l a, pPrint0 l b] + +instance (Pretty a, Pretty b, Pretty c) => Pretty (a, b, c) where + pPrintPrec l _ (a, b, c) = + parens $ fsep $ punctuate comma [pPrint0 l a, pPrint0 l b, pPrint0 l c] + +instance (Pretty a, Pretty b, Pretty c, Pretty d) => Pretty (a, b, c, d) where + pPrintPrec l _ (a, b, c, d) = + parens $ fsep $ punctuate comma + [pPrint0 l a, pPrint0 l b, pPrint0 l c, pPrint0 l d] + +instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e) => Pretty (a, b, c, d, e) where + pPrintPrec l _ (a, b, c, d, e) = + parens $ fsep $ punctuate comma + [pPrint0 l a, pPrint0 l b, pPrint0 l c, pPrint0 l d, pPrint0 l e] + +instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f) => Pretty (a, b, c, d, e, f) where + pPrintPrec l _ (a, b, c, d, e, f) = + parens $ fsep $ punctuate comma + [pPrint0 l a, pPrint0 l b, pPrint0 l c, + pPrint0 l d, pPrint0 l e, pPrint0 l f] + +instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g) => + Pretty (a, b, c, d, e, f, g) where + pPrintPrec l _ (a, b, c, d, e, f, g) = + parens $ fsep $ punctuate comma + [pPrint0 l a, pPrint0 l b, pPrint0 l c, + pPrint0 l d, pPrint0 l e, pPrint0 l f, pPrint0 l g] + +instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g, Pretty h) => + Pretty (a, b, c, d, e, f, g, h) where + pPrintPrec l _ (a, b, c, d, e, f, g, h) = + parens $ fsep $ punctuate comma + [pPrint0 l a, pPrint0 l b, pPrint0 l c, + pPrint0 l d, pPrint0 l e, pPrint0 l f, pPrint0 l g, pPrint0 l h] + diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -1,4 +1,3 @@ -{-# OPTIONS -XStandaloneDeriving -XDeriveDataTypeable -XPackageImports #-} ----------------------------------------------------------------------------- -- Module : HughesPJQuickCheck -- Copyright : (c) 2008 Benedikt Huber @@ -16,6 +15,9 @@ import TestGenerators import TestStructures +import UnitPP1 +import UnitT3911 + import Control.Monad import Data.Char (isSpace) import Data.List (intersperse) @@ -31,6 +33,8 @@ check_non_prims -- hpc full coverage check_rendering check_list_def + testPP1 + testT3911 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Utility functions @@ -133,11 +137,6 @@ visibleSpace ' ' = '.' visibleSpace '.' = error "dot in visibleSpace (avoid confusion, please)" visibleSpace c = c - --- shorthands debug functions -pd = (print.prettyDoc) -pds = mapM_ pd -rds = (map mergeTexts.flattenDoc) -- (1) QuickCheck Properties: Laws diff --git a/tests/UnitPP1.hs b/tests/UnitPP1.hs new file mode 100644 --- /dev/null +++ b/tests/UnitPP1.hs @@ -0,0 +1,76 @@ +-- This code used to print an infinite string, by calling 'spaces' +-- with a negative argument. There's a patch in the library now, +-- which makes 'spaces' do something sensible when called with a negative +-- argument, but it really should not happen at all. + +module UnitPP1 where + +import TestUtils + +import Text.PrettyPrint.HughesPJ + +ncat :: Doc -> Doc -> Doc +ncat x y = nest 4 $ cat [ x, y ] + +d1, d2 :: Doc +d1 = foldl1 ncat $ take 50 $ repeat $ char 'a' +d2 = parens $ sep [ d1, text "+" , d1 ] + +testPP1 :: IO () +testPP1 = simpleMatch "PP1" expected out + where out = show d2 + +expected :: String +expected = + "(aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\n\ ++ a\n\ + a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a\n\ +a)" + diff --git a/tests/UnitT3911.hs b/tests/UnitT3911.hs new file mode 100644 --- /dev/null +++ b/tests/UnitT3911.hs @@ -0,0 +1,25 @@ +module UnitT3911 where + +import Text.PrettyPrint.HughesPJ + +import TestUtils + +xs :: [Doc] +xs = [text "hello", + nest 10 (text "world")] + +d1, d2, d3 :: Doc +d1 = vcat xs +d2 = foldr ($$) empty xs +d3 = foldr ($+$) empty xs + +testT3911 :: IO () +testT3911 = simpleMatch "T3911" expected out + where out = show d1 ++ "\n" ++ show d2 ++ "\n" ++ show d3 + +expected :: String +expected = + "hello world\n\ +hello world\n\ +hello\n\ + world"