diff --git a/GenericPretty.cabal b/GenericPretty.cabal --- a/GenericPretty.cabal +++ b/GenericPretty.cabal @@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented. -Version: 0.1.3 +Version: 1.0.0 -- A short (one-line) description of the package. Synopsis: A generic, derivable, haskell pretty printer. @@ -15,7 +15,8 @@ -- A longer description of the package. Description: GenericPretty is a haskell library that provides support for automatic derivation of pretty printing functions on user defined data types. - The Outputable library is used underneath, the work is done over SDoc types. + The Pretty library + is used underneath, the work is done over 'Pretty.Doc' types. . The output provided by the library functions is identical to that of Prelude.show, except it has extra whitespace. @@ -23,7 +24,12 @@ This requires the use of the new GHC.Generics features: . These seem to be present in the GHC HEAD development snapshots >= 7.1.20110601. . - For more info and examples of usage please see the README file and the API at + The Generics used are based on those described in the paper "A Generic Deriving Mechanism for Haskell" : + . The changes from the original paper on the ghc implementation + are described here: . + . + For more info and examples of usage please see the README file included in the package + and the API at -- URL for the project homepage or repository. Homepage: https://github.com/HaggisMcMutton/GenericPretty @@ -50,7 +56,7 @@ -- Extra files to be distributed with the package, such as examples or -- a README. -Extra-source-files: README TestSuite\SimpleTest.hs TestSuite\Tests.hs +Extra-source-files: README TestSuite\SimpleTest.hs TestSuite\Tests.hs TestSuite\CustomTest.hs -- Constraint on the version of Cabal needed to build this package. Cabal-version: >=1.6 diff --git a/README b/README --- a/README +++ b/README @@ -4,10 +4,21 @@ GenericPretty is a haskell library that provides support for automatic derivation of pretty printing functions on user defined data types. -The output provided by the library functions is identical to that of Prelude.show, -except it has extra whitespace. +The Pretty library [1] is used underneath, the work is done over "Doc" types. -I find examples are the best aid in understanding. So, here is a possible +The output provided by the library functions is identical to that of +Prelude.show, except it has extra whitespace. + +This library requires the use of the new GHC.Generics features [2] +As of 9.08.2011, these aren't present in the stable GHC releases, but +seem to be present in the GHC HEAD development snapshots >= 7.1.20110601. + +The Generics used are based on those described in the paper +"A Generic Deriving Mechanism for Haskell" [3]. +There are however several changes between the mechanism described in the +paper and the one implemented in GHC [4]. + +I find examples are the best aid in understanding. So, here is a haskell source file, called 'SimpleTest.hs' ---------------------------------------------------- {-# LANGUAGE DeriveGeneric #-} @@ -17,7 +28,7 @@ data Tree a = Leaf a | Node (Tree a) (Tree a) deriving (Generic) instance (Out a) => Out (Tree a) where - out = genOut + docPrec = genOut tree1 :: Tree Int tree1 = Node (Node (Leaf 333333) (Leaf (-555555)))(Node (Node(Node(Leaf 888888) @@ -25,27 +36,24 @@ main = pp tree1 ------------------------------------------------ -The flag DeriveGeneric must be given to ghc. This can be done as above, +The flag DeriveGeneric must be given to GHC. This can be done as above, in a 'LANGUAGE' pragma, or manually by compiling with 'ghc -XDeriveGeneric'. As can be seen, to use the library one must simply import it, derive 'Generic' on the custom data type, and write an instance of 'Out' using 'genOut'. -Then one can use the pretty printing functions, such as 'pp' and 'prettyP'. +Then one can use the pretty printing functions, such as 'pp' and 'pretty'. Compiling and running the file is simple and gives the following result. ----------------------------- $ ghc SimpleTest.hs -[1 of 1] Compiling Main ( SimpleTest.hs, SimpleTest.o ) -Linking SimpleTest.exe ... - $ SimpleTest + Node (Node (Leaf 333333) (Leaf (-555555))) - (Node (Node (Node (Leaf 888888) (Leaf 57575757)) - (Leaf (-14141414))) + (Node (Node (Node (Leaf 888888) (Leaf 57575757)) (Leaf (-14141414))) (Leaf 7777777)) --------------------------- -If we replaced the main function with 'main = prettyP 30 1 tree1', +If we replaced the main function with 'main = ppLen 30 tree1', the result would instead be: Node (Node (Leaf 333333) @@ -55,23 +63,60 @@ (Leaf (-14141414))) (Leaf 7777777)) -In this case the output tries to remain under 30 characters/line if possible, -while maintaining correct indentation. +In this case the output tries to remain under 30 characters/line, if possible, +while always maintaining correct indentation. -------Note--------- -The defined pretty printing functions work with any type that implements -'Out' OR 'Outputable'. -This is so that if the data type that is using the deriving mechanism -relies on some other data type that can't, if the inner type implements -'Outputable', then the deriving still works. -------------------- +Customizing the pretty printed results is also straightforward, as in the +following example called 'CustomTest.hs' +---------------------------- +{-# LANGUAGE DeriveGeneric #-} -The above 'Tree' example can be found in 'TestSuite/SimpleTest.hs'. -More involved examples integrated with QuickCheck can be found in 'TestSuite/Tests.hs'. +import Text.PrettyPrint.GenericPretty +import Pretty +data Tree a = Leaf a | Node (Tree a) (Tree a) deriving (Generic) + +instance (Out a) => Out (Tree a) where + docPrec n (Leaf a) = parens $ text "customLeaf" <+> docPrec n a + docPrec n (Node a b) = parens $ text "customNode" $$ nest 1 (docPrec n a) + $$ nest 1 (docPrec n b) + +tree1 :: Tree Int +tree1 = Node (Node (Leaf 333333) (Leaf (-555555)))(Node (Node(Node(Leaf 888888) + (Leaf 57575757))(Leaf (-14141414)))(Leaf 7777777)) + +main = pp tree1 +------------------------------ +Here we import the library 'Pretty' and use it directly to define docPrec. +By running the above we get a tree with a minimum of indentation: + +(customNode + (customNode + (customLeaf 333333) + (customLeaf -555555)) + (customNode + (customNode + (customNode + (customLeaf 888888) + (customLeaf 57575757)) + (customLeaf -14141414)) + (customLeaf 7777777))) + +----------------------------------- +The above 'Tree' examples can be found in 'TestSuite/SimpleTest.hs' +and 'TestSuite/CustomTest.hs'. More involved examples integrated +with QuickCheck can be found in 'TestSuite/Tests.hs'. + Further information can be found in the API at http://haggismcmutton.github.com/GenericPretty/ and in the source code itself. =============================================================================== Please send any questions/suggestions to: Razvan Ranca + +=============================================================================== + +[1] http://www.haskell.org/ghc/docs/7.0.4/html/libraries/ghc-7.0.4/Pretty.html +[2] http://www.haskell.org/haskellwiki/Generics +[3] http://dreixel.net/research/pdf/gdmh.pdf +[4] http://www.haskell.org/haskellwiki/Generics#Changes_from_the_paper diff --git a/TestSuite/CustomTest.hs b/TestSuite/CustomTest.hs new file mode 100644 --- /dev/null +++ b/TestSuite/CustomTest.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DeriveGeneric #-} + +import Text.PrettyPrint.GenericPretty +import Pretty + +data Tree a = Leaf a | Node (Tree a) (Tree a) deriving (Generic) + +instance (Out a) => Out (Tree a) where + docPrec n (Leaf a) = parens $ text "customLeaf" <+> docPrec n a + docPrec n (Node a b) = parens $ text "customNode" $$ nest 1 (docPrec n a) $$ nest 1 (docPrec n b) + +tree1 :: Tree Int +tree1 = Node (Node (Leaf 333333) (Leaf (-555555)))(Node (Node(Node(Leaf 888888) + (Leaf 57575757))(Leaf (-14141414)))(Leaf 7777777)) + +main = pp tree1 diff --git a/TestSuite/SimpleTest.hs b/TestSuite/SimpleTest.hs --- a/TestSuite/SimpleTest.hs +++ b/TestSuite/SimpleTest.hs @@ -5,11 +5,11 @@ data Tree a = Leaf a | Node (Tree a) (Tree a) deriving (Generic) instance (Out a) => Out (Tree a) where - out = genOut + docPrec = genOut tree1 :: Tree Int -tree1 = Node (Node (Leaf 333333) (Leaf (-555555)))(Node (Node (Node (Leaf 888888) +tree1 = Node (Node (Leaf 333333) (Leaf (-555555)))(Node (Node(Node(Leaf 888888) (Leaf 57575757))(Leaf (-14141414)))(Leaf 7777777)) - -main = prettyP 30 1 tree1 +--main = pp tree1 +main = ppLen 30 tree1 diff --git a/TestSuite/Tests.hs b/TestSuite/Tests.hs --- a/TestSuite/Tests.hs +++ b/TestSuite/Tests.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {- Tests.hs has a number of different custom data types. All of them implement 'Out' and 'Arbitrary'. -Properties are provided for each that specify that the output given by 'prettyStr' and that given +Properties are provided for each that specify that the output given by 'pretty' and that given by 'show' should be identical except for the whitespace The different data types follow the same pattern of implementation and functions, so most of the @@ -22,7 +22,7 @@ -- checks the output of a specific value checkOutput :: (Out a, Show a) => a -> Bool -checkOutput a = removeSpaces (prettyStr a) == removeSpaces (show a) +checkOutput a = removeSpaces (pretty a) == removeSpaces (show a) -- Finite State Machine Type data FSM q = FSMCons ([q], Alphabet, q, [q], [Transition q]) deriving (Show, Generic) @@ -31,15 +31,15 @@ -- implement 'Out' so we can pretty print instance (Out a) => Out (FSM a) where - out = genOut + docPrec = genOut --implementation needed for quickCheck generation of random values instance Arbitrary a => Arbitrary (FSM a) where arbitrary = liftM FSMCons arbitrary --- check wether 'Maybe Int' FSM's are outputed the same via prettyStr and show (modulo the whitespace) +-- check wether 'Maybe Int' FSM's are outputed the same via pretty and show (modulo the whitespace) checkFSM :: FSM (Maybe Int) -> FSM (Maybe Int) -> Bool -checkFSM _ a = removeSpaces (prettyStr a) == removeSpaces (show a) +checkFSM _ a = removeSpaces (pretty a) == removeSpaces (show a) -- example of an FSM, you can check the output of this manually with 'checkOutput' f :: FSM Int @@ -55,7 +55,7 @@ data BinaryTree a = EmptyBTree | BNode a (BinaryTree a) (BinaryTree a) deriving (Show, Generic) instance (Out a) => Out (BinaryTree a) where - out = genOut + docPrec = genOut instance (Arbitrary a) => Arbitrary (BinaryTree a) where arbitrary = sized arbitTree @@ -68,7 +68,7 @@ subTree = arbitTree (n `div` 2) checkBinaryTree :: BinaryTree Char -> BinaryTree Char -> Bool -checkBinaryTree _ a = removeSpaces (prettyStr a) == removeSpaces (show a) +checkBinaryTree _ a = removeSpaces (pretty a) == removeSpaces (show a) -- functions for the construction of BinaryTrees singleton :: a -> BinaryTree a @@ -84,7 +84,7 @@ nums :: [Int] nums = [55555,99999,22222,77777,88888,11111,33333,44444,66666] --- mkBTree takes a list and creates a BinaryTree out of it +-- mkBTree takes a list and creates a BinaryTree docPrec of it mkBTree :: (Ord a) => [a] -> BinaryTree a mkBTree = foldr treeInsert EmptyBTree @@ -96,7 +96,7 @@ data RecordTree a = RNode {val :: a, children :: [RecordTree a]} deriving (Show, Generic) instance (Out a) => Out (RecordTree a) where - out = genOut + docPrec = genOut instance (Arbitrary a) => Arbitrary (RecordTree a) where arbitrary = sized arbitTree @@ -109,7 +109,7 @@ childList = resize (floor.sqrt.fromIntegral $ n) (listOf (arbitTree (n`div` 2)) ) checkRecordTree :: RecordTree String -> RecordTree String -> Bool -checkRecordTree _ a = removeSpaces (prettyStr a) == removeSpaces (show a) +checkRecordTree _ a = removeSpaces (pretty a) == removeSpaces (show a) rt :: RecordTree Int rt = RNode (-656565) [RNode 33344 [], RNode 98789 [RNode (-766444) [], RNode 454545 [], RNode 59996 []]] @@ -121,7 +121,7 @@ deriving (Show, Generic) instance (Out a) => Out (InfixTree a) where - out = genOut + docPrec = genOut instance (Arbitrary a) => Arbitrary (InfixTree a) where arbitrary = sized arbitTree @@ -138,7 +138,7 @@ :*: ILeaf 99999 88) ) :+: ILeaf 555 666 checkInfixTree :: InfixTree (Either Int Char) -> InfixTree (Either Int Char) -> Bool -checkInfixTree _ a = removeSpaces (prettyStr a) == removeSpaces (show a) +checkInfixTree _ a = removeSpaces (pretty a) == removeSpaces (show a) infixr 5 :^: -- infix and record tree, also uses a second user defined type in it's definition, 'Wrap' @@ -146,7 +146,7 @@ deriving (Show, Generic) instance (Out a) => Out (InfixRecordTree a) where - out = genOut + docPrec = genOut instance (Arbitrary a) => Arbitrary (InfixRecordTree a) where arbitrary = sized arbitTree @@ -163,16 +163,13 @@ (IRLeaf (Wrap (-2332323)) :^: IRLeaf (Wrap 676765))) :^: IRLeaf (Wrap 99999))) checkInfixRecordTree :: InfixRecordTree Int -> InfixRecordTree Int -> Bool -checkInfixRecordTree _ a = removeSpaces (prettyStr a) == removeSpaces (show a) +checkInfixRecordTree _ a = removeSpaces (pretty a) == removeSpaces (show a) -- just a very simple user defined type that is used in IRTree --- note, we could manually make 'Wrap' an instance of 'Outputable' instead of --- deriving 'Out' and the code would still work, --- but the output wouldn't be identical to show because of how 'Outputable' is implemented data Wrap a = Wrap a deriving (Show, Generic) instance Out a => Out (Wrap a) where - out = genOut + docPrec = genOut instance Arbitrary a => Arbitrary (Wrap a) where arbitrary = liftM Wrap arbitrary diff --git a/Text/PrettyPrint/GenericPretty.hs b/Text/PrettyPrint/GenericPretty.hs --- a/Text/PrettyPrint/GenericPretty.hs +++ b/Text/PrettyPrint/GenericPretty.hs @@ -1,68 +1,155 @@ -{-# LANGUAGE TypeOperators, FlexibleInstances, FlexibleContexts, - OverlappingInstances, UndecidableInstances #-} +{-# LANGUAGE TypeOperators, FlexibleInstances, FlexibleContexts #-} {-| -GenericPretty is a haskell library that provides support for automatic -derivation of pretty printing functions on user defined data types. -The Outputable library is used underneath, the work is done over SDoc types. - -The output provided by the library functions is identical to that of Prelude.show, -except it has extra whitespace. - -For examples of usage please see the README file. -} + GenericPretty is a haskell library that provides support for automatic + derivation of pretty printing functions on user defined data types. The "Pretty" library + is used underneath, the work is done over 'Pretty.Doc' types. + + The output provided by the library functions is identical to that of 'Prelude.show', + except it has extra whitespace. + + This requires the use of the new GHC.Generics features: . + As of 9.08.2011, these aren't present in the stable GHC releases, but + seem to be present in the GHC HEAD development snapshots >= 7.1.20110601. + + The Generics used are based on those described in the paper /"A Generic Deriving Mechanism for Haskell"/ : + . + There are however several changes between the mechanism described in the paper and the one implemented + in GHC which are described here: . + + For more info and examples of usage please see the README file included in the package -} -module Text.PrettyPrint.GenericPretty(pp, prettyP, prettyStr, fullPP, outputTxt, outputStr, Generic, Out(..), genOut) where +module Text.PrettyPrint.GenericPretty + (pp, ppLen, ppStyle, pretty, prettyLen, prettyStyle, fullPP, + genOut, outputIO, outputStr, wrapParens, defStyle, + Out(..), Style(..), Generic) where import Data.List -import Outputable import GHC.Generics -import Pretty (fullRender, Mode(..), TextDetails(..), Doc) -import FastString +import Pretty import Data.Char +import FastString --- | The class 'Out' is just a wrapper class for Outputable, which passes an extra parameter used to determine --- when to wrap types up in parentheses +-- | The class 'Out' is the equivalent of 'Prelude.Show' +-- +-- Conversion of values to pretty printable 'Pretty.Doc's. +-- +-- Minimal complete definition: 'docPrec' or 'doc'. +-- +-- Derived instances of 'Out' have the following properties +-- +-- * The result of 'show' is a syntactically correct Haskell +-- expression containing only constants, given the fixity +-- declarations in force at the point where the type is declared. +-- It contains only the constructor names defined in the data type, +-- parentheses, and spaces. When labelled constructor fields are +-- used, braces, commas, field names, and equal signs are also used. +-- +-- * If the constructor is defined to be an infix operator, then +-- 'docPrec' will produce infix applications of the constructor. +-- +-- * the representation will be enclosed in parentheses if the +-- precedence of the top-level constructor in @x@ is less than @d@ +-- (associativity is ignored). Thus, if @d@ is @0@ then the result +-- is never surrounded in parentheses; if @d@ is @11@ it is always +-- surrounded in parentheses, unless it is an atomic expression. +-- +-- * If the constructor is defined using record syntax, then 'doc' +-- will produce the record-syntax form, with the fields given in the +-- same order as the original declaration. +-- +-- For example, given the declarations +-- +-- +-- > data Tree a = Leaf a | Node (Tree a) (Tree a) deriving (Generic) +-- +-- The derived instance of 'Out' is equivalent to: +-- +-- > instance (Out a) => Out (Tree a) where +-- > +-- > docPrec d (Leaf m) = Pretty.sep $ wrapParens (d > appPrec) $ +-- > text "Leaf" : [nest (constrLen + parenLen) (docPrec (appPrec+1) m)] +-- > where appPrec = 10 +-- > constrLen = 5; +-- > parenLen = if(d > appPrec) then 1 else 0 +-- > +-- > docPrec d (Node u v) = Pretty.sep $ wrapParens (d > appPrec) $ +-- > text "Node" : +-- > nest (constrLen + parenLen) (docPrec (appPrec+1) u) : +-- > [nest (constrLen + parenLen) (docPrec (appPrec+1) v)] +-- > where appPrec = 10 +-- > constrLen = 5 +-- > parenLen = if(d > appPrec) then 1 else 0 class Out a where - -- | 'out' is the equivalent of Prelude.showsPrec - -- it generates output identical to show, except for the extra whitespace - out :: Int -> a -> SDoc - - -- | 'outList' mimics the behaviour of Prelude.showList - -- used mainly to output strings correctly, and not as lists of characters - outList :: Int -> [a] -> SDoc - outList n xs = brackets (fsep (punctuate comma (map (out n) xs))) + -- | 'docPrec' is the equivalent of 'Prelude.showsPrec' + -- Convert a value to a pretty printable 'Pretty.Doc'. + docPrec :: Int -- ^ the operator precedence of the enclosing + -- context (a number from @0@ to @11@). + -- Function application has precedence @10@. + -> a -- ^ the value to be converted to a 'String' + -> Doc -- ^ the resulting 'Doc' + + -- | 'doc' is the equivalent of 'Prelude.show' + -- + -- A specialised variant of 'docPrec', using precedence context zero. + doc :: a -> Doc + + -- | 'docList' is the equivalent of 'Prelude.showList' + -- + -- The method 'docList' is provided to allow the programmer to + -- give a specialised way of showing lists of values. + -- For example, this is used by the predefined 'Out' instance of + -- the 'Char' type, where values of type 'String' should be shown + -- in double quotes, rather than between square brackets. + docList :: [a] -> Doc + + doc = docPrec 0 + docPrec _ = doc + docList = docListWith doc --- | default, generic, 'out' method. --- User must use this when implementing 'Out' by typing 'out = genOut' -genOut :: (Generic a ,GOut (Rep a)) => Int -> a -> SDoc +-- | The default generic out method, converts the type into a sum of products and passes it on to the generic +-- pretty printing functions, finally it concatenates all of the SDoc's +-- +-- It needs to be used in code to define the instance for 'Out' +-- +-- For instance, given the declaration: +-- +-- > data Tree a = Leaf a | Node (Tree a) (Tree a) deriving (Generic) +-- +-- The user would need to write an instance declaration like: +-- +-- > instance (Out a) => Out (Tree a) where +-- > docPrec = genOut +-- +-- After doing this, the user can now use pretty printing function like 'pp' and 'pretty' +-- on data of type Tree +genOut :: (Generic a ,GOut (Rep a)) => Int -> a -> Doc genOut n x = sep $ out1 (from x) Pref n False - --- user-defined types that directly implement Outputable are handled here --- n marks wether the type needs to be surrounded by parens or not -instance (Outputable a) => Out a where - out n xs - | n > 0 = parens $ ppr xs - | otherwise = ppr xs - -instance Out a => Outputable a where - ppr = out 0 - --- 'middle' return a list without it's first and last elements + +-- used to define docList, creates output identical to that of show for general list types +docListWith :: (a -> Doc) -> [a] -> Doc +docListWith f = brackets . fcat . punctuate comma . map f + +-- returns a list without it's first and last elements -- except if the list has a single element, in which case it returns the list unchanged middle :: [a] -> [a] middle [] = [] middle [x] = [x] middle (x:xs) = init xs --- 'wrapParens' wraps the passed value in parens if the bool is true --- we don't want a single paren to possibly take a whole line, so we concatenate them to the first --- and last elements in the list, instead of just adding them to the list -wrapParens :: Bool -> [SDoc] -> [SDoc] +-- |Utility function used to wrap the passed value in parens if the bool is true +-- A single paren should never occupy a whole line, so they are concatenated +-- to the first and last elements in the list, instead of just adding them to the list +wrapParens :: Bool -> [Doc] -> [Doc] wrapParens _ [] = [] wrapParens False s = s wrapParens True s | length s == 1 = [lparen <> head s <> rparen] |otherwise = [lparen <> head s] ++ middle s ++ [last s <> rparen] + +-- show the whole document in one line +showDocOneLine :: Doc -> String +showDocOneLine = fullRender OneLineMode 1 1 outputStr "" -- The types of data we need to consider for product operator. Record, Prefix and Infix. -- Tuples aren't considered since they're already instances of 'Out' and thus won't pass through that code. @@ -71,13 +158,13 @@ --'GOut' is a helper class used to output the Sum-of-Products type, since it has kind *->*, -- so can't be an instance of 'Out' class GOut f where - -- |'out1' is the (*->*) kind equivalent of 'out' + -- |'out1' is the (*->*) kind equivalent of 'docPrec' out1 :: f x -- The sum of products representation of the user's custom type -> Type -- The type of multiplication. Record, Prefix or Infix. -> Int -- The operator precedence, determines wether to wrap stuff in parens. -> Bool -- A flag, marks wether the constructor directly above was wrapped in parens. -- Used to determine correct indentation - -> [SDoc] -- The result. Each SDoc could be on a newline, depending on available space. + -> [Doc] -- The result. Each Doc could be on a newline, depending on available space. -- |'isNullary' marks nullary constructors, so that we don't put parens around them isNullary :: f x -> Bool @@ -121,7 +208,7 @@ Infix _ _ -> Inf (conName c) --add whitespace and possible braces for records - makeMargins :: Type -> Bool -> [SDoc] -> [SDoc] + makeMargins :: Type -> Bool -> [Doc] -> [Doc] makeMargins _ _ [] = [] makeMargins Rec b s | length s == 1 = [nest (length name + 1) (lbrace <> head s <> rbrace)] @@ -138,9 +225,9 @@ isNullary (M1 a) = isNullary a --- ignore tagging, call out since these are concrete types +-- ignore tagging, call docPrec since these are concrete types instance (Out f) => GOut (K1 t f) where - out1 (K1 a) _ d _ = [out d a] + out1 (K1 a) _ d _ = [docPrec d a] isNullary _ = False -- just continue to the corresponding side of the OR @@ -163,18 +250,18 @@ pfn = out1 f t d p pgn = out1 g t d p - -- if the second value of the :*: is in parens, nest it - -- needs to get the string representation of the first elements in the left and right SDoc lists + -- if the second value of the :*: is in parens, nest it, otherwise just check for an extra paren space + -- needs to get the string representation of the first elements in the left and right Doc lists -- to be able to determine the correct indentation - checkIndent :: [SDoc] -> [SDoc] + checkIndent :: [Doc] -> [Doc] checkIndent [] = [] checkIndent m@(x:xs) - | parens == 0 = m + | parens == 0 = if p then map (nest 1) m else m | otherwise = map (nest $ cons + 1 + parenSpace) m where parenSpace = if p then 1 else 0 - strG = showSDocOneLine x - strF = showSDocOneLine (head pfn) + strG = showDocOneLine x + strF = showDocOneLine (head pfn) parens = length $ takeWhile (== '(') strG cons = length $ takeWhile( /= ' ') (dropWhile(== '(') strF) @@ -182,24 +269,27 @@ isNullary _ = False --- | 'fullPP' is a fully customizable Pretty Printer. - -fullPP :: (Out a) => a -- ^The value to pretty print - -> PprStyle -- ^The Outputable library style to use /(default is defaultUserStyle)/ - -> Mode -- ^The 'Pretty' library style(mode) to use /(default is PageMode)/ - -> Int -- ^The maximum line length - -> Float -- ^The number of ribbons per line - -> (TextDetails -> b -> b) -- ^Function that handles the text conversion /(default is 'outputTxt')/ - -> b -- ^The end element of the result /( eg: "" or putChar('\n') )/ - -> b -- ^The pretty printed result -fullPP a pstyle mode len rib td end = fullRender mode len rib td end doc +-- | 'fullPP' is a fully customizable Pretty Printer +-- Every other pretty printer just gives some default values to 'fullPP' +fullPP :: (Out a) => a -- ^The value to pretty print + -> Mode -- ^The "Pretty" mode to use /(eg: 'Pretty.PageMode')/ + -> Int -- ^The maximum line length + -> Float -- ^The number of ribbons per line /(the fraction of line length over the/ + -- /max length of non-indentation text per line; eg: lineLength = 80 and/ + -- /ribbonsPerLine = 1.5 => max of 53 non-indentation characters per line)/ + -> (TextDetails -> b -> b) -- ^Function that handles the text conversion /(eg: 'outputIO')/ + -> b -- ^The end element of the result /( eg: "" or putChar('\n') )/ + -> b -- ^The pretty printed result + +fullPP a mode len rib td end = fullRender mode len rib td end doc where - doc = withPprStyleDoc pstyle (out 0 a) + doc = docPrec 0 a --- | 'outputTxt' transforms the text into strings and outputs it directly. +-- | 'outputIO' transforms the text into strings and outputs it directly. +-- -- This is one example of a function that can handle the text conversion for 'fullPP'. -outputTxt :: TextDetails -> IO() -> IO() -outputTxt td act = do +outputIO :: TextDetails -> IO() -> IO() +outputIO td act = do putStr $ decode td act where @@ -210,7 +300,9 @@ decode (Str s) = s -- | 'outputStr' just leaves the text as a string. --- Another example of a function that can handle the text conversion for 'fullPP'. +-- This is usefull if you want to further process the pretty printed result. +-- +-- This is another example of a function that can handle the text conversion for 'fullPP'. outputStr :: TextDetails -> String -> String outputStr td str = decode td ++ str where @@ -219,137 +311,174 @@ decode (LStr s1 _) = unpackLitString s1 decode (Chr c) = [c] decode (Str s) = s - --- | 'prettyStr' returns the result as a string. --- The returned value is identical to one made by Prelude.show, except for the extra whitespace -prettyStr :: (Out a) => a -> String -prettyStr a = fullPP a defaultUserStyle PageMode 80 1.5 outputStr "" --- | 'prettyP' is a partly customizable Pretty Printer --- It takes the line length and ribbons per line as parameters -prettyP :: (Out a) => Int -> Float -> a -> IO() -prettyP len rib a = fullPP a defaultUserStyle PageMode len rib outputTxt (putChar '\n') +-- | Customizable pretty printer, takes a user defined 'Style' as a parameter and +-- uses 'outputStr' to obtain the result +prettyStyle :: (Out a) => Style -> a -> String +prettyStyle s a = fullPP a (mode s) (lineLength s) (ribbonsPerLine s) outputStr "" --- | 'pp' is the default Pretty Printer, --- it uses a line length of 80 and 1.5 ribbons per line /(= 53 non-whitespace chars per line)/ --- where ribbon is defined as the maximum length of text, excluding whitespace, on a single line +-- | Semi-customizable pretty printer. Takes the lineLength as a parameter +-- uses mode = 'Pretty.PageMode' and ribbonsPerLine = 1 +prettyLen :: (Out a) => Int -> a -> String +prettyLen l a = fullPP a PageMode l 1 outputStr "" + +-- | The default pretty printer returning 'String's +-- +-- It uses the default style, 'defStyle' +pretty :: (Out a) => a -> String +pretty = prettyStyle defStyle + +-- | Customizable pretty printer, takes a user defined 'Style' as a parameter and +-- uses 'outputIO' to obtain the result +ppStyle :: (Out a) => Style -> a -> IO() +ppStyle s a = fullPP a (mode s) (lineLength s) (ribbonsPerLine s) outputIO (putChar '\n') + +-- | Semi-customizable pretty printer. Takes the lineLength as a parameter +-- uses mode = 'Pretty.PageMode' and ribbonsPerLine = 1 +ppLen :: (Out a) => Int -> a -> IO() +ppLen l a = fullPP a PageMode l 1 outputIO (putChar '\n') + +-- | The default Pretty Printer, +-- +-- It uses the default style, 'defStyle' pp :: (Out a) => a -> IO() -pp = prettyP 80 1.5 +pp = ppStyle defStyle +-- | The default 'Style' used for 'pp' and 'pretty' +-- (mode=PageMode, lineLength=100, ribbonsPerLine=1.5) +defStyle :: Style +defStyle = Style {mode = PageMode, lineLength = 80, ribbonsPerLine = 1} + +-- | A rendering style +data Style + = Style { mode :: Mode -- ^ The rendering mode + , lineLength :: Int -- ^ Length of line, in chars + , ribbonsPerLine :: Float -- ^ Ratio of ribbon length to line length + } + +{- +prettyLenRib :: (Out a) => Int -> Float -> a -> String +prettyLenRib l r a = fullPP a PageMode l r outputStr "" + +ppLenRib :: (Out a) => Int -> Float -> a -> IO() +ppLenRib l r a = fullPP a PageMode l r outputIO (putChar '\n') + +-} + -- define some instances of Out making sure to generate output identical to 'show' modulo the extra whitespace instance Out Char where - out _ a = char '\'' <> (text.middle.show $ a) <> char '\'' - outList _ xs = text $ show xs + docPrec _ a = char '\'' <> (text.middle.show $ a) <> char '\'' + docList xs = text $ show xs instance Out Integer where - out n x + docPrec n x | n/=0 && x<0 = parens $ integer x | otherwise = integer x instance Out a => Out [a] where - out = outList + docPrec _ = docList instance Out Bool where - out _ True = ptext (sLit "True") - out _ False = ptext (sLit "False") + docPrec _ True = text "True" + docPrec _ False = text "False" instance Out Int where - out n x + docPrec n x | n/=0 && x<0 = parens $ int x | otherwise = int x instance Out a => Out (Maybe a) where - out n Nothing = ptext (sLit "Nothing") - out n (Just x) + docPrec n Nothing = text "Nothing" + docPrec n (Just x) | n/=0 = parens result |otherwise = result where - result = ptext (sLit "Just") <+> out 10 x + result = text "Just" <+> docPrec 10 x instance (Out a, Out b) => Out (Either a b) where - out n (Left x) + docPrec n (Left x) | n/=0 = parens result | otherwise = result where - result = ptext (sLit "Left") <+> out 10 x - out n (Right y) + result = text "Left" <+> docPrec 10 x + docPrec n (Right y) | n/=0 = parens result | otherwise = result where - result = ptext (sLit "Right") <+> out 10 y + result = text "Right" <+> docPrec 10 y instance (Out a, Out b) => Out (a, b) where - out _ (a,b) = parens (sep [out 0 a <> comma, out 0 b]) + docPrec _ (a,b) = parens (sep [docPrec 0 a <> comma, docPrec 0 b]) instance (Out a, Out b, Out c) => Out (a, b, c) where - out _ (a,b,c) = parens (sep [out 0 a <> comma, out 0 b <> comma, out 0 c]) + docPrec _ (a,b,c) = parens (sep [docPrec 0 a <> comma, docPrec 0 b <> comma, docPrec 0 c]) instance (Out a, Out b, Out c, Out d) => Out (a, b, c, d) where - out _ (a,b,c,d) = parens (sep [out 0 a <> comma, out 0 b <> comma, out 0 c <> comma, out 0 d]) + docPrec _ (a,b,c,d) = parens (sep [docPrec 0 a <> comma, docPrec 0 b <> comma, docPrec 0 c <> comma, docPrec 0 d]) instance (Out a, Out b, Out c, Out d, Out e) => Out (a, b, c, d, e) where - out _ (a,b,c,d,e) = parens (sep [out 0 a <> comma, out 0 b <> comma, out 0 c <> comma, out 0 d <> comma, out 0 e]) + docPrec _ (a,b,c,d,e) = parens (sep [docPrec 0 a <> comma, docPrec 0 b <> comma, docPrec 0 c <> comma, docPrec 0 d <> comma, docPrec 0 e]) instance (Out a, Out b, Out c, Out d, Out e, Out f) => Out (a, b, c, d, e, f) where - out _ (a, b, c, d, e, f) = - parens (sep [out 0 a <> comma, out 0 b <> comma, out 0 c <> comma, - out 0 d <> comma, out 0 e <> comma, out 0 f]) + docPrec _ (a, b, c, d, e, f) = + parens (sep [docPrec 0 a <> comma, docPrec 0 b <> comma, docPrec 0 c <> comma, + docPrec 0 d <> comma, docPrec 0 e <> comma, docPrec 0 f]) instance (Out a, Out b, Out c, Out d, Out e, Out f, Out g) => Out (a, b, c, d, e, f, g) where - out _ (a, b, c, d, e, f, g) = - parens (sep [out 0 a <> comma, out 0 b <> comma, out 0 c <> comma, - out 0 d <> comma, out 0 e <> comma, out 0 f <> comma, out 0 g]) + docPrec _ (a, b, c, d, e, f, g) = + parens (sep [docPrec 0 a <> comma, docPrec 0 b <> comma, docPrec 0 c <> comma, + docPrec 0 d <> comma, docPrec 0 e <> comma, docPrec 0 f <> comma, docPrec 0 g]) instance (Out a, Out b, Out c, Out d, Out e, Out f, Out g, Out h) => Out (a, b, c, d, e, f, g, h) where - out _ (a, b, c, d, e, f, g, h) = - parens (sep [out 0 a <> comma, out 0 b <> comma, out 0 c <> comma, - out 0 d <> comma, out 0 e <> comma, out 0 f <> comma, out 0 g <> comma, out 0 h]) + docPrec _ (a, b, c, d, e, f, g, h) = + parens (sep [docPrec 0 a <> comma, docPrec 0 b <> comma, docPrec 0 c <> comma, + docPrec 0 d <> comma, docPrec 0 e <> comma, docPrec 0 f <> comma, docPrec 0 g <> comma, docPrec 0 h]) instance (Out a, Out b, Out c, Out d, Out e, Out f, Out g, Out h, Out i) => Out (a, b, c, d, e, f, g, h, i) where - out _ (a, b, c, d, e, f, g, h, i) = - parens (sep [out 0 a <> comma, out 0 b <> comma, out 0 c <> comma, out 0 d <> comma, - out 0 e <> comma, out 0 f <> comma, out 0 g <> comma, out 0 h <> comma, out 0 i]) + docPrec _ (a, b, c, d, e, f, g, h, i) = + parens (sep [docPrec 0 a <> comma, docPrec 0 b <> comma, docPrec 0 c <> comma, docPrec 0 d <> comma, + docPrec 0 e <> comma, docPrec 0 f <> comma, docPrec 0 g <> comma, docPrec 0 h <> comma, docPrec 0 i]) instance (Out a, Out b, Out c, Out d, Out e, Out f, Out g, Out h, Out i, Out j) => Out (a, b, c, d, e, f, g, h, i, j) where - out _ (a, b, c, d, e, f, g, h, i, j) = - parens (sep [out 0 a <> comma, out 0 b <> comma, out 0 c <> comma, out 0 d <> comma, - out 0 e <> comma, out 0 f <> comma, out 0 g <> comma, out 0 h <> comma, out 0 i <> comma, out 0 j]) + docPrec _ (a, b, c, d, e, f, g, h, i, j) = + parens (sep [docPrec 0 a <> comma, docPrec 0 b <> comma, docPrec 0 c <> comma, docPrec 0 d <> comma, + docPrec 0 e <> comma, docPrec 0 f <> comma, docPrec 0 g <> comma, docPrec 0 h <> comma, docPrec 0 i <> comma, docPrec 0 j]) instance (Out a, Out b, Out c, Out d, Out e, Out f, Out g, Out h, Out i, Out j, Out k) => Out (a, b, c, d, e, f, g, h, i, j, k) where - out _ (a, b, c, d, e, f, g, h, i, j, k) = - parens (sep [out 0 a <> comma, out 0 b <> comma, out 0 c <> comma, out 0 d <> comma, out 0 e<> comma, - out 0 f <> comma, out 0 g <> comma, out 0 h <> comma, out 0 i <> comma, out 0 j <> comma, out 0 k]) + docPrec _ (a, b, c, d, e, f, g, h, i, j, k) = + parens (sep [docPrec 0 a <> comma, docPrec 0 b <> comma, docPrec 0 c <> comma, docPrec 0 d <> comma, docPrec 0 e<> comma, + docPrec 0 f <> comma, docPrec 0 g <> comma, docPrec 0 h <> comma, docPrec 0 i <> comma, docPrec 0 j <> comma, docPrec 0 k]) instance (Out a, Out b, Out c, Out d, Out e, Out f, Out g, Out h, Out i, Out j, Out k, Out l) => Out (a, b, c, d, e, f, g, h, i, j, k, l) where - out _ (a, b, c, d, e, f, g, h, i, j, k, l) = - parens (sep [out 0 a <> comma, out 0 b <> comma, out 0 c <> comma, out 0 d <> comma, out 0 e <> comma, - out 0 f <> comma, out 0 g <> comma, out 0 h <> comma, out 0 i <> comma, out 0 j <> comma, - out 0 k <> comma, out 0 l]) + docPrec _ (a, b, c, d, e, f, g, h, i, j, k, l) = + parens (sep [docPrec 0 a <> comma, docPrec 0 b <> comma, docPrec 0 c <> comma, docPrec 0 d <> comma, docPrec 0 e <> comma, + docPrec 0 f <> comma, docPrec 0 g <> comma, docPrec 0 h <> comma, docPrec 0 i <> comma, docPrec 0 j <> comma, + docPrec 0 k <> comma, docPrec 0 l]) instance (Out a, Out b, Out c, Out d, Out e, Out f, Out g, Out h, Out i, Out j, Out k, Out l, Out m) => Out (a, b, c, d, e, f, g, h, i, j, k, l, m) where - out _ (a, b, c, d, e, f, g, h, i, j, k, l, m) = - parens (sep [out 0 a <> comma, out 0 b <> comma, out 0 c <> comma, out 0 d <> comma, out 0 e <> comma, - out 0 f <> comma, out 0 g <> comma, out 0 h <> comma, out 0 i <> comma, out 0 j <> comma, - out 0 k <> comma, out 0 l <> comma, out 0 m]) + docPrec _ (a, b, c, d, e, f, g, h, i, j, k, l, m) = + parens (sep [docPrec 0 a <> comma, docPrec 0 b <> comma, docPrec 0 c <> comma, docPrec 0 d <> comma, docPrec 0 e <> comma, + docPrec 0 f <> comma, docPrec 0 g <> comma, docPrec 0 h <> comma, docPrec 0 i <> comma, docPrec 0 j <> comma, + docPrec 0 k <> comma, docPrec 0 l <> comma, docPrec 0 m]) instance (Out a, Out b, Out c, Out d, Out e, Out f, Out g, Out h, Out i, Out j, Out k, Out l, Out m, Out n) => Out (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where - out _ (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = - parens (sep [out 0 a <> comma, out 0 b <> comma, out 0 c <> comma, out 0 d <> comma, out 0 e <> comma, - out 0 f <> comma, out 0 g <> comma, out 0 h <> comma, out 0 i <> comma, out 0 j <> comma, - out 0 k <> comma, out 0 l <> comma, out 0 m <> comma, out 0 n]) + docPrec _ (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = + parens (sep [docPrec 0 a <> comma, docPrec 0 b <> comma, docPrec 0 c <> comma, docPrec 0 d <> comma, docPrec 0 e <> comma, + docPrec 0 f <> comma, docPrec 0 g <> comma, docPrec 0 h <> comma, docPrec 0 i <> comma, docPrec 0 j <> comma, + docPrec 0 k <> comma, docPrec 0 l <> comma, docPrec 0 m <> comma, docPrec 0 n]) instance (Out a, Out b, Out c, Out d, Out e, Out f, Out g, Out h, Out i, Out j, Out k, Out l, Out m, Out n, Out o) => Out (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where - out _ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = - parens (sep [out 0 a <> comma, out 0 b <> comma, out 0 c <> comma, out 0 d <> comma, out 0 e <> comma, - out 0 f <> comma, out 0 g <> comma, out 0 h <> comma, out 0 i <> comma, out 0 j <> comma, - out 0 k <> comma, out 0 l <> comma, out 0 m <> comma, out 0 n <> comma, out 0 o]) + docPrec _ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = + parens (sep [docPrec 0 a <> comma, docPrec 0 b <> comma, docPrec 0 c <> comma, docPrec 0 d <> comma, docPrec 0 e <> comma, + docPrec 0 f <> comma, docPrec 0 g <> comma, docPrec 0 h <> comma, docPrec 0 i <> comma, docPrec 0 j <> comma, + docPrec 0 k <> comma, docPrec 0 l <> comma, docPrec 0 m <> comma, docPrec 0 n <> comma, docPrec 0 o])