diff --git a/GenericPretty.cabal b/GenericPretty.cabal --- a/GenericPretty.cabal +++ b/GenericPretty.cabal @@ -1,99 +1,99 @@ --- GenericPretty.cabal auto-generated by cabal init. For additional --- options, see --- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. --- The name of the package. -Name: GenericPretty - --- 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: 1.2.0 - --- A short (one-line) description of the package. -Synopsis: A generic, derivable, haskell pretty printer. - --- A longer description of the package. -Description: - GenericPretty is a Haskell library that supports automatic - derivation of pretty printing functions on user defined data - types. - . - The form of geenrics used is based on that introduced in the paper: - Magalhaes, Dijkstra, Jeuring, and Loh, - A Generic Deriving Mechanism for Haskell, - 3'rd ACM Symposium on Haskell, pp. 37-48, September 2010, - . - Changes from the original paper in the GHC implementation - are described here: - . - . - This package requires the use of the new GHC.Generics features - , present from GHC 7.2. - Use of these features is indicated by the DeriveGeneric pragma. - or the flag -XDeriveGeneric. - . - Pretty printing produces values of type Text.PrettyPrint.Doc, using - the Text.PrettyPrint library - . - . - The output provided is a pretty printed version of that provided by - Prelude.show. That is, rendering the document provided by this pretty - printer yields an output identical to that of Prelude.show, except - for extra whitespace. - . - For information about the functions exported by the package please see - the API linked further down this page. - - For examples of usage, both basic and more complex see the README file and - the haskell source code files in the TestSuite folder, both included in the package. - - Finally for installation instructions also see the README file or this page: - - --- URL for the project homepage or repository. -Homepage: https://github.com/RazvanRanca/GenericPretty - --- The license under which the package is released. -License: BSD3 - --- The file containing the license text. -License-file: LICENSE - --- The package author(s). -Author: Razvan Ranca - --- An email address to which users can send suggestions, bug reports, --- and patches. -Maintainer: ranca.razvan@gmail.com - --- A copyright notice. --- Copyright: - -Category: Text, Generics, Pretty Printer - -Build-type: Simple - --- Extra files to be distributed with the package, such as examples or --- a README. -Extra-source-files: README TestSuite\SimpleTest.hs TestSuite\Tests.hs TestSuite\CustomTest.hs TestSuite\ZigZagTest.hs - --- Constraint on the version of Cabal needed to build this package. -Cabal-version: >=1.6 - - -Library - -- Modules exported by the library. - Exposed-modules: Text.PrettyPrint.GenericPretty - - -- Packages needed in order to build this package. - Build-depends: base >= 3 && < 5, ghc-prim, pretty, ghc >= 7.4 - - -- Modules not exported by this package. - -- Other-modules: - - -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. - -- Build-tools: - -source-repository head - type: git +-- GenericPretty.cabal auto-generated by cabal init. For additional +-- options, see +-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. +-- The name of the package. +Name: GenericPretty + +-- 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: 1.2.1 + +-- A short (one-line) description of the package. +Synopsis: A generic, derivable, haskell pretty printer. + +-- A longer description of the package. +Description: + GenericPretty is a Haskell library that supports automatic + derivation of pretty printing functions on user defined data + types. + . + The form of generics used is based on that introduced in the paper: + Magalhaes, Dijkstra, Jeuring, and Loh, + A Generic Deriving Mechanism for Haskell, + 3'rd ACM Symposium on Haskell, pp. 37-48, September 2010, + . + Changes from the original paper in the GHC implementation + are described here: + . + . + This package requires the use of the new GHC.Generics features + , present from GHC 7.2. + Use of these features is indicated by the DeriveGeneric pragma + or the flag -XDeriveGeneric. + . + Pretty printing produces values of type Text.PrettyPrint.Doc, using + the Text.PrettyPrint library + . + . + The output provided is a pretty printed version of that provided by + Prelude.show. That is, rendering the document provided by this pretty + printer yields an output identical to that of Prelude.show, except + for extra whitespace. + . + For information about the functions exported by the package please see + the API linked further down this page. + + For examples of usage, both basic and more complex see the README file and + the haskell source code files in the TestSuite folder, both included in the package. + + Finally for installation instructions also see the README file or this page: + + +-- URL for the project homepage or repository. +Homepage: https://github.com/RazvanRanca/GenericPretty + +-- The license under which the package is released. +License: BSD3 + +-- The file containing the license text. +License-file: LICENSE + +-- The package author(s). +Author: Razvan Ranca + +-- An email address to which users can send suggestions, bug reports, +-- and patches. +Maintainer: ranca.razvan@gmail.com + +-- A copyright notice. +-- Copyright: + +Category: Text, Generics, Pretty Printer + +Build-type: Simple + +-- Extra files to be distributed with the package, such as examples or +-- a README. +Extra-source-files: README TestSuite/SimpleTest.hs TestSuite/Tests.hs TestSuite/CustomTest.hs TestSuite/ZigZagTest.hs + +-- Constraint on the version of Cabal needed to build this package. +Cabal-version: >=1.6 + + +Library + -- Modules exported by the library. + Exposed-modules: Text.PrettyPrint.GenericPretty + + -- Packages needed in order to build this package. + Build-depends: base >= 3 && < 5, ghc-prim, pretty + + -- Modules not exported by this package. + -- Other-modules: + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. + -- Build-tools: + +source-repository head + type: git location: git@github.com:RazvanRanca/GenericPretty.git diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,30 +1,30 @@ -Copyright (c)2011, Razvan Ranca - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Razvan Ranca nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +Copyright (c)2011, Razvan Ranca + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Razvan Ranca nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README b/README --- a/README +++ b/README @@ -1,269 +1,269 @@ -******************************************************************************* -* GenericPretty -* A Generic, Derivable, Haskell Pretty Printer -******************************************************************************* - -=============================================================================== -========================== Description ======================================== -=============================================================================== - -GenericPretty is a Haskell library that supports automatic -derivation of pretty printing functions on user defined data -types. - -The form of geenrics used is based on that introduced in the paper: -Magalhaes, Dijkstra, Jeuring, and Loh, -A Generic Deriving Mechanism for Haskell, -3'rd ACM Symposium on Haskell, pp. 37-48, September 2010, - http://dx.doi.org/10.1145/1863523.1863529. -Changes from the original paper in the GHC implementation -are described here: - http://www.haskell.org/haskellwiki/GHC.Generics#Changes_from_the_paper. - -This package requires the use of the new GHC.Generics features: - http://www.haskell.org/haskellwiki/GHC.Generics -present from GHC 7.2. -Use of these features is indicated by the DeriveGeneric pragma -or the flag -XDeriveGeneric. - -Pretty printing produces values of type Text.PrettyPrint.Doc, using -the Text.PrettyPrint library - http://www.haskell.org/ghc/docs/latest/html/libraries/pretty-1.1.1.0/Text-PrettyPrint.html. - -The output provided is a pretty printed version of that provided by -Prelude.show. That is, rendering the document provided by this pretty -printer yields an output identical to that of Prelude.show, except -for extra whitespace. - -The generics mechanism works on all haskell datatypes except for -constrained datatypes. -That is to say, datatypes which have a context will fail. -For instance, - data (Eq a) => Constr a = Constr a deriving (Generic) -will fail because of the (Eq a) context. - -=============================================================================== -===================== Installation Instructions =============================== -=============================================================================== - -The package is installed in the same way as any other package. -If you have cabal, you can simply do: - $ cabal update - $ cabal install GenericPretty - -Otherwise, the steps are: - 0. Make sure you have a version of ghc >= 7.4 installed and that you can - use the 'runhaskell' command from the command line. - 1. Download and unpack "GenericPretty-1.2.0.tar.gz" - 2. Move to the correct directory: - $ cd GenericPretty-1.2.0 - 3. Run the following haskell commands to install the library globally: - $ runhaskell Setup configure - $ runhaskell Setup build - $ runhaskell Setup install - - The last command requires root access, so you might need to run is as: - $ sudo runhaskell Setup install - -If something went wrong, you can check this page for more info, -look at manual installation: - http://www.haskell.org/haskellwiki/Cabal/How_to_install_a_Cabal_package - -=============================================================================== -============================== Basic Example ================================== -=============================================================================== - -Here is a haskell source file, called 'SimpleTest.hs' ----------------------------------------------------- -{-# LANGUAGE DeriveGeneric #-} - -import Text.PrettyPrint.GenericPretty - -data Tree a = Leaf a | Node (Tree a) (Tree a) deriving (Generic) - -instance (Out a) => Out (Tree a) - -tree1 :: Tree Int -tree1 = Node (Node (Leaf 333333) (Leaf (-555555)))(Node (Node(Node(Leaf 888888) - (Leaf 57575757))(Leaf (-14141414)))(Leaf 7777777)) - -main = pp tree1 ------------------------------------------------- -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 you must simply import it, derive Generic -on the custom data type by typing - "deriving (Generic)" -and writing an empty instance of Out. - -Then you 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 -$ SimpleTest - -Node (Node (Leaf 333333) (Leaf (-555555))) - (Node (Node (Node (Leaf 888888) (Leaf 57575757)) - (Leaf (-14141414))) - (Leaf 7777777)) ---------------------------- -If we replaced the main function with 'main = ppLen 30 tree1', -the result would instead be: ------------------------------ -Node (Node (Leaf 333333) - (Leaf (-555555))) - (Node (Node (Node (Leaf 888888) - (Leaf 57575757)) - (Leaf (-14141414))) - (Leaf 7777777)) -------------------------------- -In this case the output tries to remain under 30 characters/line, -if possible, while always maintaining correct indentation. - -=============================================================================== -================= The 'ppStyle' and 'prettyStyle' functions =================== -=============================================================================== - -The 'ppStyle' function lets you further customize the output -by giving a 'Style' which consists of the line length, the number of ribbons -per line and the mode to use. - -The 'prettyStyle' function does the same thing except it outputs a String -instead of an IO() operation. - -A ribbon length is the maximum length of non-indentation text per line. -So if I used a line length of 80 and 2 ribbons per line than I would have a -maximum of 40 non-indentation characters on any line. - -The mode tells 'Pretty' how to render the result. There are 4 options: - 1. PageMode - the default rendering - 2. ZigZagMode - zig-zag cuts - 3. LeftMode - there is no indentation and no maximum line length - 4. OneLineMode - everything is put on one line - -The most interesting one is the ZigZagMode. -Modifying the running example we get: --------------------------------------- -{-# LANGUAGE DeriveGeneric #-} - -import Text.PrettyPrint.GenericPretty -import Text.PrettyPrint - -data Tree a = Leaf a | Node (Tree a) (Tree a) deriving (Generic) - -instance (Out a) => Out (Tree a) - -tree1 :: Tree Int -tree1 = Node (Node (Leaf 333333) (Leaf (-555555)))(Node (Node(Node(Leaf 888888) - (Leaf 57575757))(Leaf (-14141414)))(Leaf 7777777)) - -zigStyle :: Style -zigStyle = Style {mode = ZigZagMode, lineLength = 30, ribbonsPerLine = 1.5} - -main = ppStyle zigStyle tree1 --------------------------------------- -We import "Text.PrettyPrint" to gain access to the "Style" functionality. -Then we proceed to define the 'zigStyle' using a maximum line length of 30, -1.5 ribbonsPerLine and the ZigZagMode. - -Running the program, we get: -------------------------------------- -Node (Node (Leaf 333333) - -///// - (Leaf (-555555))) -(Node (Node (Node (Leaf 888888) - -///// - (Leaf 57575757)) - (Leaf (-14141414))) - (Leaf 7777777)) -------------------------------------- -Notice that the "/" show us the direction in which the rows below have been -moved (left in this case) and the number of "/"s indicate the number of -characters that the rows were moved(in this case 5 characters to the left). - -So the last 3 lines are 10 characters to the left compared to where they -would be if we had no maximum line length. - -=============================================================================== -======================= Full Customization Example ============================ -=============================================================================== - -While the previous approach provides us some with some options as to the -format of the pretty printed result, sometimes you need even more control. - -Fully customizing the pretty printed results is straightforward, as in the -following example called 'CustomTest.hs' ----------------------------- -{-# LANGUAGE DeriveGeneric #-} - -import Text.PrettyPrint.GenericPretty -import Text.PrettyPrint - -data Tree a = Leaf a | Node (Tree a) (Tree a) deriving (Generic) - -instance (Out a) => Out (Tree a) where - doc (Leaf a) = parens $ text "customLeaf" <+> doc a - doc (Node a b) = parens $ text "customNode" $$ nest 1 (doc a) - $$ nest 1 (doc b) - docPrec _ = doc - -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 'Text.PrettyPrint' and use it directly to define doc. -We then define 'docPrec' in terms of 'doc', ignoring the precedence parameter. -We could have manually defined 'docList' as well if we wanted. As it is now, -'docList' is inferred from 'doc'. - -*****Note***** -As opposed to the 'Show' class, 'doc' and 'docPrec' are NOT defined in term -of one another. This means that even after giving a custom definition for -one of them, the other will retain the default behaviour. -If both are to be used, then custom definitions must be provided for both. - -For instance, in the above example, if we had ommited 'docPrec's definition, -the result would have been identical to that of 'SimpleTest.hs'. - -By running the above custom definition we get a tree with little indentation: ------------------------------------ -(customNode - (customNode - (customLeaf 333333) - (customLeaf -555555)) - (customNode - (customNode - (customNode - (customLeaf 888888) - (customLeaf 57575757)) - (customLeaf -14141414)) - (customLeaf 7777777))) ------------------------------------ -The details of the syntax used above can be found in the -Text.PrettyPrint library: - http://www.haskell.org/ghc/docs/latest/html/libraries/pretty-1.1.1.0/Text-PrettyPrint.html - -=============================================================================== -========================= Further Info ======================================== -=============================================================================== - -The above 'Tree' examples can be found in 'TestSuite/SimpleTest.hs', -'TestSuite.ZigZagTest.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: - http://hackage.haskell.org/packages/archive/GenericPretty/latest/doc/html/Text-PrettyPrint-GenericPretty.html -and in the source code itself. - -=============================================================================== -============================ Contact ========================================== -=============================================================================== - -Please send any questions/suggestions/issues to: +******************************************************************************* +* GenericPretty +* A Generic, Derivable, Haskell Pretty Printer +******************************************************************************* + +=============================================================================== +========================== Description ======================================== +=============================================================================== + +GenericPretty is a Haskell library that supports automatic +derivation of pretty printing functions on user defined data +types. + +The form of geenrics used is based on that introduced in the paper: +Magalhaes, Dijkstra, Jeuring, and Loh, +A Generic Deriving Mechanism for Haskell, +3'rd ACM Symposium on Haskell, pp. 37-48, September 2010, + http://dx.doi.org/10.1145/1863523.1863529. +Changes from the original paper in the GHC implementation +are described here: + http://www.haskell.org/haskellwiki/GHC.Generics#Changes_from_the_paper. + +This package requires the use of the new GHC.Generics features: + http://www.haskell.org/haskellwiki/GHC.Generics +present from GHC 7.2. +Use of these features is indicated by the DeriveGeneric pragma +or the flag -XDeriveGeneric. + +Pretty printing produces values of type Text.PrettyPrint.Doc, using +the Text.PrettyPrint library + http://www.haskell.org/ghc/docs/latest/html/libraries/pretty-1.1.1.0/Text-PrettyPrint.html. + +The output provided is a pretty printed version of that provided by +Prelude.show. That is, rendering the document provided by this pretty +printer yields an output identical to that of Prelude.show, except +for extra whitespace. + +The generics mechanism works on all haskell datatypes except for +constrained datatypes. +That is to say, datatypes which have a context will fail. +For instance, + data (Eq a) => Constr a = Constr a deriving (Generic) +will fail because of the (Eq a) context. + +=============================================================================== +===================== Installation Instructions =============================== +=============================================================================== + +The package is installed in the same way as any other package. +If you have cabal, you can simply do: + $ cabal update + $ cabal install GenericPretty + +Otherwise, the steps are: + 0. Make sure you have a version of ghc >= 7.4 installed and that you can + use the 'runhaskell' command from the command line. + 1. Download and unpack "GenericPretty-1.2.0.tar.gz" + 2. Move to the correct directory: + $ cd GenericPretty-1.2.0 + 3. Run the following haskell commands to install the library globally: + $ runhaskell Setup configure + $ runhaskell Setup build + $ runhaskell Setup install + + The last command requires root access, so you might need to run is as: + $ sudo runhaskell Setup install + +If something went wrong, you can check this page for more info, +look at manual installation: + http://www.haskell.org/haskellwiki/Cabal/How_to_install_a_Cabal_package + +=============================================================================== +============================== Basic Example ================================== +=============================================================================== + +Here is a haskell source file, called 'SimpleTest.hs' +---------------------------------------------------- +{-# LANGUAGE DeriveGeneric #-} + +import Text.PrettyPrint.GenericPretty + +data Tree a = Leaf a | Node (Tree a) (Tree a) deriving (Generic) + +instance (Out a) => Out (Tree a) + +tree1 :: Tree Int +tree1 = Node (Node (Leaf 333333) (Leaf (-555555)))(Node (Node(Node(Leaf 888888) + (Leaf 57575757))(Leaf (-14141414)))(Leaf 7777777)) + +main = pp tree1 +------------------------------------------------ +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 you must simply import it, derive Generic +on the custom data type by typing + "deriving (Generic)" +and writing an empty instance of Out. + +Then you 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 +$ SimpleTest + +Node (Node (Leaf 333333) (Leaf (-555555))) + (Node (Node (Node (Leaf 888888) (Leaf 57575757)) + (Leaf (-14141414))) + (Leaf 7777777)) +--------------------------- +If we replaced the main function with 'main = ppLen 30 tree1', +the result would instead be: +----------------------------- +Node (Node (Leaf 333333) + (Leaf (-555555))) + (Node (Node (Node (Leaf 888888) + (Leaf 57575757)) + (Leaf (-14141414))) + (Leaf 7777777)) +------------------------------- +In this case the output tries to remain under 30 characters/line, +if possible, while always maintaining correct indentation. + +=============================================================================== +================= The 'ppStyle' and 'prettyStyle' functions =================== +=============================================================================== + +The 'ppStyle' function lets you further customize the output +by giving a 'Style' which consists of the line length, the number of ribbons +per line and the mode to use. + +The 'prettyStyle' function does the same thing except it outputs a String +instead of an IO() operation. + +A ribbon length is the maximum length of non-indentation text per line. +So if I used a line length of 80 and 2 ribbons per line than I would have a +maximum of 40 non-indentation characters on any line. + +The mode tells 'Pretty' how to render the result. There are 4 options: + 1. PageMode - the default rendering + 2. ZigZagMode - zig-zag cuts + 3. LeftMode - there is no indentation and no maximum line length + 4. OneLineMode - everything is put on one line + +The most interesting one is the ZigZagMode. +Modifying the running example we get: +-------------------------------------- +{-# LANGUAGE DeriveGeneric #-} + +import Text.PrettyPrint.GenericPretty +import Text.PrettyPrint + +data Tree a = Leaf a | Node (Tree a) (Tree a) deriving (Generic) + +instance (Out a) => Out (Tree a) + +tree1 :: Tree Int +tree1 = Node (Node (Leaf 333333) (Leaf (-555555)))(Node (Node(Node(Leaf 888888) + (Leaf 57575757))(Leaf (-14141414)))(Leaf 7777777)) + +zigStyle :: Style +zigStyle = Style {mode = ZigZagMode, lineLength = 30, ribbonsPerLine = 1.5} + +main = ppStyle zigStyle tree1 +-------------------------------------- +We import "Text.PrettyPrint" to gain access to the "Style" functionality. +Then we proceed to define the 'zigStyle' using a maximum line length of 30, +1.5 ribbonsPerLine and the ZigZagMode. + +Running the program, we get: +------------------------------------- +Node (Node (Leaf 333333) + +///// + (Leaf (-555555))) +(Node (Node (Node (Leaf 888888) + +///// + (Leaf 57575757)) + (Leaf (-14141414))) + (Leaf 7777777)) +------------------------------------- +Notice that the "/" show us the direction in which the rows below have been +moved (left in this case) and the number of "/"s indicate the number of +characters that the rows were moved(in this case 5 characters to the left). + +So the last 3 lines are 10 characters to the left compared to where they +would be if we had no maximum line length. + +=============================================================================== +======================= Full Customization Example ============================ +=============================================================================== + +While the previous approach provides us some with some options as to the +format of the pretty printed result, sometimes you need even more control. + +Fully customizing the pretty printed results is straightforward, as in the +following example called 'CustomTest.hs' +---------------------------- +{-# LANGUAGE DeriveGeneric #-} + +import Text.PrettyPrint.GenericPretty +import Text.PrettyPrint + +data Tree a = Leaf a | Node (Tree a) (Tree a) deriving (Generic) + +instance (Out a) => Out (Tree a) where + doc (Leaf a) = parens $ text "customLeaf" <+> doc a + doc (Node a b) = parens $ text "customNode" $$ nest 1 (doc a) + $$ nest 1 (doc b) + docPrec _ = doc + +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 'Text.PrettyPrint' and use it directly to define doc. +We then define 'docPrec' in terms of 'doc', ignoring the precedence parameter. +We could have manually defined 'docList' as well if we wanted. As it is now, +'docList' is inferred from 'doc'. + +*****Note***** +As opposed to the 'Show' class, 'doc' and 'docPrec' are NOT defined in term +of one another. This means that even after giving a custom definition for +one of them, the other will retain the default behaviour. +If both are to be used, then custom definitions must be provided for both. + +For instance, in the above example, if we had ommited 'docPrec's definition, +the result would have been identical to that of 'SimpleTest.hs'. + +By running the above custom definition we get a tree with little indentation: +----------------------------------- +(customNode + (customNode + (customLeaf 333333) + (customLeaf -555555)) + (customNode + (customNode + (customNode + (customLeaf 888888) + (customLeaf 57575757)) + (customLeaf -14141414)) + (customLeaf 7777777))) +----------------------------------- +The details of the syntax used above can be found in the +Text.PrettyPrint library: + http://www.haskell.org/ghc/docs/latest/html/libraries/pretty-1.1.1.0/Text-PrettyPrint.html + +=============================================================================== +========================= Further Info ======================================== +=============================================================================== + +The above 'Tree' examples can be found in 'TestSuite/SimpleTest.hs', +'TestSuite.ZigZagTest.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: + http://hackage.haskell.org/packages/archive/GenericPretty/latest/doc/html/Text-PrettyPrint-GenericPretty.html +and in the source code itself. + +=============================================================================== +============================ Contact ========================================== +=============================================================================== + +Please send any questions/suggestions/issues to: Razvan Ranca - ranca.razvan@gmail.com diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain diff --git a/TestSuite/CustomTest.hs b/TestSuite/CustomTest.hs --- a/TestSuite/CustomTest.hs +++ b/TestSuite/CustomTest.hs @@ -1,18 +1,18 @@ -{-# LANGUAGE DeriveGeneric #-} - -import Text.PrettyPrint.GenericPretty -import Text.PrettyPrint - -data Tree a = Leaf a | Node (Tree a) (Tree a) deriving (Generic) - -instance (Out a) => Out (Tree a) where - doc (Leaf a) = parens $ text "customLeaf" <+> doc a - doc (Node a b) = parens $ text "customNode" $$ nest 1 (doc a) - $$ nest 1 (doc b) - docPrec _ = doc - -tree1 :: Tree Int -tree1 = Node (Node (Leaf 333333) (Leaf (-555555)))(Node (Node(Node(Leaf 888888) - (Leaf 57575757))(Leaf (-14141414)))(Leaf 7777777)) - +{-# LANGUAGE DeriveGeneric #-} + +import Text.PrettyPrint.GenericPretty +import Text.PrettyPrint + +data Tree a = Leaf a | Node (Tree a) (Tree a) deriving (Generic) + +instance (Out a) => Out (Tree a) where + doc (Leaf a) = parens $ text "customLeaf" <+> doc a + doc (Node a b) = parens $ text "customNode" $$ nest 1 (doc a) + $$ nest 1 (doc b) + docPrec _ = doc + +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 @@ -1,14 +1,14 @@ -{-# LANGUAGE DeriveGeneric #-} - -import Text.PrettyPrint.GenericPretty - -data Tree a = Leaf a | Node (Tree a) (Tree a) deriving (Generic) - -instance (Out a) => Out (Tree a) - -tree1 :: Tree Int -tree1 = Node (Node (Leaf 333333) (Leaf (-555555)))(Node (Node(Node(Leaf 888888) - (Leaf 57575757))(Leaf (-14141414)))(Leaf 7777777)) - ---main = pp tree1 +{-# LANGUAGE DeriveGeneric #-} + +import Text.PrettyPrint.GenericPretty + +data Tree a = Leaf a | Node (Tree a) (Tree a) deriving (Generic) + +instance (Out a) => Out (Tree a) + +tree1 :: Tree Int +tree1 = Node (Node (Leaf 333333) (Leaf (-555555)))(Node (Node(Node(Leaf 888888) + (Leaf 57575757))(Leaf (-14141414)))(Leaf 7777777)) + +--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,177 +1,177 @@ -{-# 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 '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 -functions are only commented for the first data type -} - -import Text.PrettyPrint.GenericPretty -import Test.QuickCheck -import Control.Monad -import Data.Maybe -import Text.Printf - --- used to make pretty printed and show output identical for comparing purposes -removeSpaces :: String -> String -removeSpaces [] = [] -removeSpaces (x:xs) - | x `elem` " \n" = removeSpaces xs - | otherwise = x : removeSpaces xs - --- checks the output of a specific value -checkOutput :: (Out a, Show a) => a -> Bool -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) -type Alphabet = String -type Transition q = (q, Char, q) - --- implement 'Out' so we can pretty print -instance (Out a) => Out (FSM a) - ---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 pretty and show (modulo the whitespace) -checkFSM :: FSM (Maybe Int) -> FSM (Maybe Int) -> Bool -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 -f = FSMCons([0,1,2,3,4], - "ab", - 0, - [4], - [(0,'a',1), (0,'b',1), (0,'a',2), (0,'b',2), - (1,'b',4), (2,'a',3), (2,'b',3), (3,'b',4), - (4,'a',4), (4,'b',4)]) - --- Binary Tree data type -data BinaryTree a = EmptyBTree | BNode a (BinaryTree a) (BinaryTree a) deriving (Show, Generic) - -instance (Out a) => Out (BinaryTree a) - -instance (Arbitrary a) => Arbitrary (BinaryTree a) where - arbitrary = sized arbitTree - where - arbitTree 0 = return EmptyBTree - arbitTree n - | n>0 = oneof [return EmptyBTree, liftM3 BNode arbitrary subTree subTree] - | otherwise = error "tree size should never be < 0" - where - subTree = arbitTree (n `div` 2) - -checkBinaryTree :: BinaryTree Char -> BinaryTree Char -> Bool -checkBinaryTree _ a = removeSpaces (pretty a) == removeSpaces (show a) - --- functions for the construction of BinaryTrees -singleton :: a -> BinaryTree a -singleton x = BNode x EmptyBTree EmptyBTree - -treeInsert :: (Ord a) => a -> BinaryTree a -> BinaryTree a -treeInsert x EmptyBTree = singleton x -treeInsert x (BNode a left right) - | x == a = BNode x left right - | x < a = BNode a (treeInsert x left) right - | x > a = BNode a left (treeInsert x right) - -nums :: [Int] -nums = [55555,99999,22222,77777,88888,11111,33333,44444,66666] - --- mkBTree takes a list and creates a BinaryTree docPrec of it -mkBTree :: (Ord a) => [a] -> BinaryTree a -mkBTree = foldr treeInsert EmptyBTree - --- example BinaryTree -bt :: BinaryTree Int -bt = mkBTree nums - --- Tree using record syntax -data RecordTree a = RNode {val :: a, children :: [RecordTree a]} deriving (Show, Generic) - -instance (Out a) => Out (RecordTree a) - -instance (Arbitrary a) => Arbitrary (RecordTree a) where - arbitrary = sized arbitTree - where - arbitTree 0 = liftM2 RNode arbitrary (return []) - arbitTree n - | n>0 = liftM2 RNode arbitrary childList - | otherwise = error "tree size should never be < 0" - where - childList = resize (floor.sqrt.fromIntegral $ n) (listOf (arbitTree (n`div` 2)) ) - -checkRecordTree :: RecordTree String -> RecordTree String -> Bool -checkRecordTree _ a = removeSpaces (pretty a) == removeSpaces (show a) - -rt :: RecordTree Int -rt = RNode (-656565) [RNode 33344 [], RNode 98789 [RNode (-766444) [], RNode 454545 [], RNode 59996 []]] - -infixr 5 :*: -infixr 3 :+: --- tree using infix notation -data InfixTree a = ILeaf a a | (InfixTree a) :*: (InfixTree a) | (InfixTree a) :+: (InfixTree a) - deriving (Show, Generic) - -instance (Out a) => Out (InfixTree a) - -instance (Arbitrary a) => Arbitrary (InfixTree a) where - arbitrary = sized arbitTree - where - arbitTree 0 = liftM2 ILeaf arbitrary arbitrary - arbitTree n - | n>0 = oneof [ liftM2 (:*:) subTree subTree, liftM2 (:+:) subTree subTree] - | otherwise = error "tree size should never be < 0" - where - subTree = arbitTree (n `div` 2) - -nt :: InfixTree Int -nt = ILeaf 5454544 55 :*: (ILeaf 5375738 44 :+: ((ILeaf 699879 55 :*: ILeaf 2332323 66 :+: ILeaf 676765 77) - :*: ILeaf 99999 88) ) :+: ILeaf 555 666 - -checkInfixTree :: InfixTree (Either Int Char) -> InfixTree (Either Int Char) -> Bool -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' -data InfixRecordTree a = IRLeaf (Wrap a) | (:^:) {left :: InfixRecordTree a, right :: InfixRecordTree a} - deriving (Show, Generic) - -instance (Out a) => Out (InfixRecordTree a) - -instance (Arbitrary a) => Arbitrary (InfixRecordTree a) where - arbitrary = sized arbitTree - where - arbitTree 0 = liftM IRLeaf arbitrary - arbitTree n - | n>0 = liftM2 (:^:) subTree subTree - | otherwise = error "tree size should never be < 0" - where - subTree = arbitTree (n `div` 2) - -irt :: InfixRecordTree Int -irt = IRLeaf (Wrap 5454544) :^: (IRLeaf (Wrap (-5375738)) :^: ((IRLeaf (Wrap 699879) :^: - (IRLeaf (Wrap (-2332323)) :^: IRLeaf (Wrap 676765))) :^: IRLeaf (Wrap 99999))) - -checkInfixRecordTree :: InfixRecordTree Float -> InfixRecordTree Float -> Bool -checkInfixRecordTree _ a = removeSpaces (pretty a) == removeSpaces (show a) - --- just a very simple user defined type that is used in IRTree -data Wrap a = Wrap a deriving (Show, Generic) - -instance Out a => Out (Wrap a) - -instance Arbitrary a => Arbitrary (Wrap a) where - arbitrary = liftM Wrap arbitrary - -allTests = [ ("FSM (Maybe Int)", quickCheck checkFSM), - ("BinaryTree (Char)", quickCheck checkBinaryTree), - ("RecordTree (String)", quickCheck checkRecordTree), - ("InfixTree (Either Int Char)", quickCheck checkInfixTree), - ("InfixRecordTree (Float)", quickCheck checkInfixRecordTree)] - +{-# 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 '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 +functions are only commented for the first data type -} + +import Text.PrettyPrint.GenericPretty +import Test.QuickCheck +import Control.Monad +import Data.Maybe +import Text.Printf + +-- used to make pretty printed and show output identical for comparing purposes +removeSpaces :: String -> String +removeSpaces [] = [] +removeSpaces (x:xs) + | x `elem` " \n" = removeSpaces xs + | otherwise = x : removeSpaces xs + +-- checks the output of a specific value +checkOutput :: (Out a, Show a) => a -> Bool +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) +type Alphabet = String +type Transition q = (q, Char, q) + +-- implement 'Out' so we can pretty print +instance (Out a) => Out (FSM a) + +--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 pretty and show (modulo the whitespace) +checkFSM :: FSM (Maybe Int) -> FSM (Maybe Int) -> Bool +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 +f = FSMCons([0,1,2,3,4], + "ab", + 0, + [4], + [(0,'a',1), (0,'b',1), (0,'a',2), (0,'b',2), + (1,'b',4), (2,'a',3), (2,'b',3), (3,'b',4), + (4,'a',4), (4,'b',4)]) + +-- Binary Tree data type +data BinaryTree a = EmptyBTree | BNode a (BinaryTree a) (BinaryTree a) deriving (Show, Generic) + +instance (Out a) => Out (BinaryTree a) + +instance (Arbitrary a) => Arbitrary (BinaryTree a) where + arbitrary = sized arbitTree + where + arbitTree 0 = return EmptyBTree + arbitTree n + | n>0 = oneof [return EmptyBTree, liftM3 BNode arbitrary subTree subTree] + | otherwise = error "tree size should never be < 0" + where + subTree = arbitTree (n `div` 2) + +checkBinaryTree :: BinaryTree Char -> BinaryTree Char -> Bool +checkBinaryTree _ a = removeSpaces (pretty a) == removeSpaces (show a) + +-- functions for the construction of BinaryTrees +singleton :: a -> BinaryTree a +singleton x = BNode x EmptyBTree EmptyBTree + +treeInsert :: (Ord a) => a -> BinaryTree a -> BinaryTree a +treeInsert x EmptyBTree = singleton x +treeInsert x (BNode a left right) + | x == a = BNode x left right + | x < a = BNode a (treeInsert x left) right + | x > a = BNode a left (treeInsert x right) + +nums :: [Int] +nums = [55555,99999,22222,77777,88888,11111,33333,44444,66666] + +-- mkBTree takes a list and creates a BinaryTree docPrec of it +mkBTree :: (Ord a) => [a] -> BinaryTree a +mkBTree = foldr treeInsert EmptyBTree + +-- example BinaryTree +bt :: BinaryTree Int +bt = mkBTree nums + +-- Tree using record syntax +data RecordTree a = RNode {val :: a, children :: [RecordTree a]} deriving (Show, Generic) + +instance (Out a) => Out (RecordTree a) + +instance (Arbitrary a) => Arbitrary (RecordTree a) where + arbitrary = sized arbitTree + where + arbitTree 0 = liftM2 RNode arbitrary (return []) + arbitTree n + | n>0 = liftM2 RNode arbitrary childList + | otherwise = error "tree size should never be < 0" + where + childList = resize (floor.sqrt.fromIntegral $ n) (listOf (arbitTree (n`div` 2)) ) + +checkRecordTree :: RecordTree String -> RecordTree String -> Bool +checkRecordTree _ a = removeSpaces (pretty a) == removeSpaces (show a) + +rt :: RecordTree Int +rt = RNode (-656565) [RNode 33344 [], RNode 98789 [RNode (-766444) [], RNode 454545 [], RNode 59996 []]] + +infixr 5 :*: +infixr 3 :+: +-- tree using infix notation +data InfixTree a = ILeaf a a | (InfixTree a) :*: (InfixTree a) | (InfixTree a) :+: (InfixTree a) + deriving (Show, Generic) + +instance (Out a) => Out (InfixTree a) + +instance (Arbitrary a) => Arbitrary (InfixTree a) where + arbitrary = sized arbitTree + where + arbitTree 0 = liftM2 ILeaf arbitrary arbitrary + arbitTree n + | n>0 = oneof [ liftM2 (:*:) subTree subTree, liftM2 (:+:) subTree subTree] + | otherwise = error "tree size should never be < 0" + where + subTree = arbitTree (n `div` 2) + +nt :: InfixTree Int +nt = ILeaf 5454544 55 :*: (ILeaf 5375738 44 :+: ((ILeaf 699879 55 :*: ILeaf 2332323 66 :+: ILeaf 676765 77) + :*: ILeaf 99999 88) ) :+: ILeaf 555 666 + +checkInfixTree :: InfixTree (Either Int Char) -> InfixTree (Either Int Char) -> Bool +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' +data InfixRecordTree a = IRLeaf (Wrap a) | (:^:) {left :: InfixRecordTree a, right :: InfixRecordTree a} + deriving (Show, Generic) + +instance (Out a) => Out (InfixRecordTree a) + +instance (Arbitrary a) => Arbitrary (InfixRecordTree a) where + arbitrary = sized arbitTree + where + arbitTree 0 = liftM IRLeaf arbitrary + arbitTree n + | n>0 = liftM2 (:^:) subTree subTree + | otherwise = error "tree size should never be < 0" + where + subTree = arbitTree (n `div` 2) + +irt :: InfixRecordTree Int +irt = IRLeaf (Wrap 5454544) :^: (IRLeaf (Wrap (-5375738)) :^: ((IRLeaf (Wrap 699879) :^: + (IRLeaf (Wrap (-2332323)) :^: IRLeaf (Wrap 676765))) :^: IRLeaf (Wrap 99999))) + +checkInfixRecordTree :: InfixRecordTree Float -> InfixRecordTree Float -> Bool +checkInfixRecordTree _ a = removeSpaces (pretty a) == removeSpaces (show a) + +-- just a very simple user defined type that is used in IRTree +data Wrap a = Wrap a deriving (Show, Generic) + +instance Out a => Out (Wrap a) + +instance Arbitrary a => Arbitrary (Wrap a) where + arbitrary = liftM Wrap arbitrary + +allTests = [ ("FSM (Maybe Int)", quickCheck checkFSM), + ("BinaryTree (Char)", quickCheck checkBinaryTree), + ("RecordTree (String)", quickCheck checkRecordTree), + ("InfixTree (Either Int Char)", quickCheck checkInfixTree), + ("InfixRecordTree (Float)", quickCheck checkInfixRecordTree)] + main = mapM_ (\(s,r) -> printf "%-30s: " s >> r) allTests diff --git a/TestSuite/ZigZagTest.hs b/TestSuite/ZigZagTest.hs --- a/TestSuite/ZigZagTest.hs +++ b/TestSuite/ZigZagTest.hs @@ -1,17 +1,17 @@ -{-# LANGUAGE DeriveGeneric #-} - -import Text.PrettyPrint.GenericPretty -import Text.PrettyPrint - -data Tree a = Leaf a | Node (Tree a) (Tree a) deriving (Generic) - -instance (Out a) => Out (Tree a) - -tree1 :: Tree Int -tree1 = Node (Node (Leaf 333333) (Leaf (-555555)))(Node (Node(Node(Leaf 888888) - (Leaf 57575757))(Leaf (-14141414)))(Leaf 7777777)) - -zigStyle :: Style -zigStyle = Style {mode = ZigZagMode, lineLength = 30, ribbonsPerLine = 1.5} - +{-# LANGUAGE DeriveGeneric #-} + +import Text.PrettyPrint.GenericPretty +import Text.PrettyPrint + +data Tree a = Leaf a | Node (Tree a) (Tree a) deriving (Generic) + +instance (Out a) => Out (Tree a) + +tree1 :: Tree Int +tree1 = Node (Node (Leaf 333333) (Leaf (-555555)))(Node (Node(Node(Leaf 888888) + (Leaf 57575757))(Leaf (-14141414)))(Leaf 7777777)) + +zigStyle :: Style +zigStyle = Style {mode = ZigZagMode, lineLength = 30, ribbonsPerLine = 1.5} + main = ppStyle zigStyle tree1 diff --git a/Text/PrettyPrint/GenericPretty.hs b/Text/PrettyPrint/GenericPretty.hs --- a/Text/PrettyPrint/GenericPretty.hs +++ b/Text/PrettyPrint/GenericPretty.hs @@ -1,454 +1,456 @@ -{-# LANGUAGE TypeOperators, FlexibleInstances, FlexibleContexts, DefaultSignatures #-} - -{-| - GenericPretty is a Haskell library that supports automatic - derivation of pretty printing functions on user defined data - types. - - The output provided is a pretty printed version of that provided by - 'Prelude.show'. That is, rendering the document provided by this pretty - printer yields an output identical to that of 'Prelude.show', except - for extra whitespace. - - For examples of usage please see the README file included in the package. - - For more information see the HackageDB project page: --} - -module Text.PrettyPrint.GenericPretty - ( - Out(..), - pp, ppLen, ppStyle, pretty, prettyLen, prettyStyle, fullPP, - Generic, - outputIO, outputStr, - ) where - -import Data.List -import GHC.Generics -import Data.Char -import Text.PrettyPrint - --- | The class 'Out' is the equivalent of 'Prelude.Show' --- --- It provides 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 'docPrec' 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 'docPrec' --- 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 - -- | '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 - default docPrec :: (Generic a ,GOut (Rep a)) => Int -> a -> Doc - docPrec n x = sep $ out1 (from x) Pref n False - - -- | 'doc' is the equivalent of 'Prelude.show' - -- - -- This is a specialised variant of 'docPrec', using precedence context zero. - doc :: a -> Doc - default doc :: (Generic a ,GOut (Rep a)) => a -> Doc - doc x = sep $ out1 (from x) Pref 0 False - - -- | '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 - docList = docListWith doc - --- 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 - --- |Utility function used to wrap the passed value in parens if the bool is true. -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. -data Type = Rec | Pref | Inf String - ---'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 '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 - -> [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 - --- if empty, output nothing, this is a null constructor -instance GOut U1 where - out1 _ _ _ _ = [empty] - isNullary _ = True - --- ignore datatype meta-information -instance (GOut f, Datatype c) => GOut (M1 D c f) where - out1 (M1 a) = out1 a - isNullary (M1 a) = isNullary a - --- if there is a selector, display it and it's value + appropriate white space -instance (GOut f, Selector c) => GOut (M1 S c f) where - out1 s@(M1 a) t d p - | selector == "" = out1 a t d p - | otherwise = (text selector <+> char '='):map (nest $ length selector + 3) (out1 a t 0 p) - where - selector = selName s - - isNullary (M1 a) = isNullary a - --- constructor --- here the real type and parens flag is set and propagated forward via t and n, the precedence factor is updated -instance (GOut f, Constructor c) => GOut (M1 C c f) where - out1 c@(M1 a) _ d p = - case fixity of - -- if prefix add the constructor name, nest the result and possibly put it in parens - Prefix -> wrapParens boolParens $ text name: makeMargins t boolParens (out1 a t 11 boolParens) - -- if infix possibly put in parens - Infix _ m -> wrapParens (d>m) $ out1 a t (m+1) (d>m) - where - boolParens = d>10 && (not $ isNullary a) - name = checkInfix $ conName c - fixity = conFixity c - -- get the type of the data, Record, Infix or Prefix. - t = if conIsRecord c then Rec else - case fixity of - Prefix -> Pref - Infix _ _ -> Inf (conName c) - - --add whitespace and possible braces for records - makeMargins :: Type -> Bool -> [Doc] -> [Doc] - makeMargins _ _ [] = [] - makeMargins Rec b s - | length s == 1 = [nest (length name + 1) (lbrace <> head s <> rbrace)] - | otherwise = nest (length name + 1) (lbrace <> head s) : - map (nest $ length name + 2) (middle s ++ [last s <> rbrace]) - makeMargins _ b s = map (nest $ length name + if b then 2 else 1) s - - -- check for infix operators that are acting like prefix ones due to records, put them in parens - checkInfix :: String -> String - checkInfix [] = [] - checkInfix (x:xs) - | fixity == Prefix && (isAlphaNum x || x == '_') = (x:xs) - | otherwise = "(" ++ (x:xs) ++ ")" - - isNullary (M1 a) = isNullary a - --- ignore tagging, call docPrec since these are concrete types -instance (Out f) => GOut (K1 t f) where - out1 (K1 a) _ d _ = [docPrec d a] - isNullary _ = False - --- just continue to the corresponding side of the OR -instance (GOut f, GOut g) => GOut (f :+: g) where - out1 (L1 a) t d p = out1 a t d p - out1 (R1 a) t d p = out1 a t d p - isNullary (L1 a) = isNullary a - isNullary (R1 a) = isNullary a - --- output both sides of the product, possible separated by a comma or an infix operator -instance (GOut f, GOut g) => GOut (f :*: g) where - out1 (f :*: g) t@Rec d p = init pfn ++ [last pfn <> comma] ++ pgn - where - pfn = out1 f t d p - pgn = out1 g t d p - - -- if infix, nest the second value since it isn't nested in the constructor - out1 (f :*: g) t@(Inf s) d p = init pfn ++ [last pfn <+> text s] ++ checkIndent pgn - where - pfn = out1 f t d p - pgn = out1 g t d p - - -- 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 :: [Doc] -> [Doc] - checkIndent [] = [] - checkIndent m@(x:xs) - | 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 = showDocOneLine x - strF = showDocOneLine (head pfn) - parens = length $ takeWhile (== '(') strG - cons = length $ takeWhile( /= ' ') (dropWhile(== '(') strF) - - out1 (f :*: g) t@Pref n p = out1 f t n p ++ out1 g t n p - - isNullary _ = False - --- | 'fullPP' is a fully customizable Pretty Printer --- --- Every other pretty printer just gives some default values to 'fullPP' -fullPP :: (Out a) => (TextDetails -> b -> b) -- ^Function that handles the text conversion /(eg: 'outputIO')/ - -> b -- ^The end element of the result /( eg: "" or putChar('\n') )/ - -> Style -- ^The pretty printing 'Text.PrettyPrint.MyPretty.Style' to use - -> a -- ^The value to pretty print - -> b -- ^The pretty printed result -fullPP td end s a = fullRender (mode s) (lineLength s) (ribbonsPerLine s) td end doc - where - doc = docPrec 0 a - -defaultStyle :: Style -defaultStyle = Style {mode = PageMode, lineLength = 80, ribbonsPerLine = 1.5} - --- | Utility function that handles the text conversion for 'fullPP'. --- --- 'outputIO' transforms the text into 'String's and outputs it directly. -outputIO :: TextDetails -> IO() -> IO() -outputIO td act = do - putStr $ decode td - act - where - decode :: TextDetails -> String - decode (Str s) = s - decode (PStr s1) = s1 - decode (Chr c) = [c] - --- | Utility function that handles the text conversion for 'fullPP'. --- ---'outputStr' just leaves the text as a 'String' which is usefull if you want --- to further process the pretty printed result. -outputStr :: TextDetails -> String -> String -outputStr td str = decode td ++ str - where - decode :: TextDetails -> String - decode (Str s) = s - decode (PStr s1) = s1 - decode (Chr c) = [c] - --- | Customizable pretty printer --- --- Takes a user defined 'Text.PrettyPrint.MyPretty.Style' as a parameter and uses 'outputStr' to obtain the result --- Equivalent to: --- --- > fullPP outputStr "" -prettyStyle :: (Out a) => Style -> a -> String -prettyStyle = fullPP outputStr "" - --- | Semi-customizable pretty printer. --- --- Equivalent to: --- --- > prettyStyle customStyle --- --- Where customStyle uses the specified line length, mode = PageMode and ribbonsPerLine = 1. -prettyLen :: (Out a) => Int -> a -> String -prettyLen l = prettyStyle customStyle - where - customStyle = Style {mode = PageMode, lineLength = l, ribbonsPerLine = 1} - --- | The default pretty printer returning 'String's --- --- Equivalent to --- --- > prettyStyle defaultStyle --- --- Where defaultStyle = (mode=PageMode, lineLength=80, ribbonsPerLine=1.5) -pretty :: (Out a) => a -> String -pretty = prettyStyle defaultStyle - --- | Customizable pretty printer. --- --- Takes a user defined 'Text.PrettyPrint.MyPretty.Style' as a parameter and uses 'outputIO' to obtain the result --- Equivalent to: --- --- > fullPP outputIO (putChar '\n') -ppStyle :: (Out a) => Style -> a -> IO() -ppStyle = fullPP outputIO (putChar '\n') - --- | Semi-customizable pretty printer. --- --- Equivalent to: --- --- > ppStyle customStyle --- --- Where customStyle uses the specified line length, mode = PageMode and ribbonsPerLine = 1. -ppLen :: (Out a) => Int -> a -> IO() -ppLen l = ppStyle customStyle - where - customStyle = Style {mode = PageMode, lineLength = l, ribbonsPerLine = 1} - --- | The default Pretty Printer, --- --- Equivalent to: --- --- > ppStyle defaultStyle --- --- Where defaultStyle = (mode=PageMode, lineLength=80, ribbonsPerLine=1.5) -pp :: (Out a) => a -> IO() -pp = ppStyle defaultStyle - - --- define some instances of Out making sure to generate output identical to 'show' modulo the extra whitespace -instance Out () where - doc _ = text "()" - docPrec _ = doc - -instance Out Char where - doc a = char '\'' <> (text.middle.show $ a) <> char '\'' - docPrec _ = doc - docList xs = text $ show xs - -instance Out Int where - docPrec n x - | n/=0 && x<0 = parens $ int x - | otherwise = int x - doc = docPrec 0 - -instance Out Integer where - docPrec n x - | n/=0 && x<0 = parens $ integer x - | otherwise = integer x - doc = docPrec 0 - -instance Out Float where - docPrec n x - | n/=0 && x<0 = parens $ float x - | otherwise = float x - doc = docPrec 0 - -instance Out Double where - docPrec n x - | n/=0 && x<0 = parens $ double x - | otherwise = double x - doc = docPrec 0 - -instance Out Rational where - docPrec n x - | n/=0 && x<0 = parens $ rational x - | otherwise = rational x - doc = docPrec 0 - -instance Out a => Out [a] where - doc = docList - docPrec _ = doc - -instance Out Bool where - doc True = text "True" - doc False = text "False" - docPrec _ = doc - -instance Out a => Out (Maybe a) where - docPrec n Nothing = text "Nothing" - docPrec n (Just x) - | n/=0 = parens result - |otherwise = result - where - result = text "Just" <+> docPrec 10 x - doc = docPrec 0 - -instance (Out a, Out b) => Out (Either a b) where - docPrec n (Left x) - | n/=0 = parens result - | otherwise = result - where - result = text "Left" <+> docPrec 10 x - docPrec n (Right y) - | n/=0 = parens result - | otherwise = result - where - result = text "Right" <+> docPrec 10 y - doc = docPrec 0 - -instance (Out a, Out b) => Out (a, b) where - doc (a,b) = parens (sep [doc a <> comma, doc b]) - docPrec _ = doc - -instance (Out a, Out b, Out c) => Out (a, b, c) where - doc (a,b,c) = parens (sep [doc a <> comma, doc b <> comma, doc c]) - docPrec _ = doc - -instance (Out a, Out b, Out c, Out d) => Out (a, b, c, d) where - doc (a,b,c,d) = parens (sep [doc a <> comma, doc b <> comma, doc c <> comma, doc d]) - docPrec _ = doc - -instance (Out a, Out b, Out c, Out d, Out e) => Out (a, b, c, d, e) where - doc (a,b,c,d,e) = parens (sep [doc a <> comma, doc b <> comma, doc c <> comma, doc d <> comma, doc e]) - docPrec _ = doc - -instance (Out a, Out b, Out c, Out d, Out e, Out f) - => Out (a, b, c, d, e, f) where - doc (a, b, c, d, e, f) = - parens (sep [ doc a <> comma, doc b <> comma, doc c <> comma, - doc d <> comma, doc e <> comma, doc f]) - docPrec _ = doc - -instance (Out a, Out b, Out c, Out d, Out e, Out f, Out g) - => Out (a, b, c, d, e, f, g) where - doc (a, b, c, d, e, f, g) = - parens (sep [ doc a <> comma, doc b <> comma, doc c <> comma, - doc d <> comma, doc e <> comma, doc f <> comma, doc g]) +{-# LANGUAGE TypeOperators, FlexibleInstances, FlexibleContexts, DefaultSignatures #-} + +{-| + GenericPretty is a Haskell library that supports automatic + derivation of pretty printing functions on user defined data + types. + + The output provided is a pretty printed version of that provided by + 'Prelude.show'. That is, rendering the document provided by this pretty + printer yields an output identical to that of 'Prelude.show', except + for extra whitespace. + + For examples of usage please see the README file included in the package. + + For more information see the HackageDB project page: +-} + +module Text.PrettyPrint.GenericPretty + ( + Out(..), + pp, ppLen, ppStyle, pretty, prettyLen, prettyStyle, fullPP, + Generic, + outputIO, outputStr, + ) where + +import Data.List +import GHC.Generics +import Data.Char +import Text.PrettyPrint + +-- | The class 'Out' is the equivalent of 'Prelude.Show' +-- +-- It provides 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 'docPrec' 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 'docPrec' +-- 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 + -- | '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 + default docPrec :: (Generic a ,GOut (Rep a)) => Int -> a -> Doc + docPrec n x = sep $ out1 (from x) Pref n False + + -- | 'doc' is the equivalent of 'Prelude.show' + -- + -- This is a specialised variant of 'docPrec', using precedence context zero. + doc :: a -> Doc + default doc :: (Generic a ,GOut (Rep a)) => a -> Doc + doc x = sep $ out1 (from x) Pref 0 False + + -- | '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 + docList = docListWith doc + +-- 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 + +-- |Utility function used to wrap the passed value in parens if the bool is true. +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. +data Type = Rec | Pref | Inf String + +--'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 '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 + -> [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 + +-- if empty, output nothing, this is a null constructor +instance GOut U1 where + out1 _ _ _ _ = [empty] + isNullary _ = True + +-- ignore datatype meta-information +instance (GOut f, Datatype c) => GOut (M1 D c f) where + out1 (M1 a) = out1 a + isNullary (M1 a) = isNullary a + +-- if there is a selector, display it and it's value + appropriate white space +instance (GOut f, Selector c) => GOut (M1 S c f) where + out1 s@(M1 a) t d p + | selector == "" = out1 a t d p + | otherwise = (text selector <+> char '='):map (nest $ length selector + 3) (out1 a t 0 p) + where + selector = selName s + + isNullary (M1 a) = isNullary a + +-- constructor +-- here the real type and parens flag is set and propagated forward via t and n, the precedence factor is updated +instance (GOut f, Constructor c) => GOut (M1 C c f) where + out1 c@(M1 a) _ d p = + case fixity of + -- if prefix add the constructor name, nest the result and possibly put it in parens + Prefix -> wrapParens boolParens $ text name: makeMargins t boolParens (out1 a t 11 boolParens) + -- if infix possibly put in parens + Infix _ m -> wrapParens (d>m) $ out1 a t (m+1) (d>m) + where + boolParens = d>10 && (not $ isNullary a) + name = checkInfix $ conName c + fixity = conFixity c + -- get the type of the data, Record, Infix or Prefix. + t = if conIsRecord c then Rec else + case fixity of + Prefix -> Pref + Infix _ _ -> Inf (conName c) + + --add whitespace and possible braces for records + makeMargins :: Type -> Bool -> [Doc] -> [Doc] + makeMargins _ _ [] = [] + makeMargins Rec b s + | length s == 1 = [nest (length name + 1) (lbrace <> head s <> rbrace)] + | otherwise = nest (length name + 1) (lbrace <> head s) : + map (nest $ length name + 2) (middle s ++ [last s <> rbrace]) + makeMargins _ b s = map (nest $ length name + if b then 2 else 1) s + + -- check for infix operators that are acting like prefix ones due to records, put them in parens + checkInfix :: String -> String + checkInfix [] = [] + checkInfix (x:xs) + | fixity == Prefix && (isAlphaNum x || x == '_') = (x:xs) + | otherwise = "(" ++ (x:xs) ++ ")" + + isNullary (M1 a) = isNullary a + +-- ignore tagging, call docPrec since these are concrete types +instance (Out f) => GOut (K1 t f) where + out1 (K1 a) _ d _ = [docPrec d a] + isNullary _ = False + +-- just continue to the corresponding side of the OR +instance (GOut f, GOut g) => GOut (f :+: g) where + out1 (L1 a) t d p = out1 a t d p + out1 (R1 a) t d p = out1 a t d p + isNullary (L1 a) = isNullary a + isNullary (R1 a) = isNullary a + +-- output both sides of the product, possible separated by a comma or an infix operator +instance (GOut f, GOut g) => GOut (f :*: g) where + out1 (f :*: g) t@Rec d p = init pfn ++ [last pfn <> comma] ++ pgn + where + pfn = out1 f t d p + pgn = out1 g t d p + + -- if infix, nest the second value since it isn't nested in the constructor + out1 (f :*: g) t@(Inf s) d p = init pfn ++ [last pfn <+> text s] ++ checkIndent pgn + where + pfn = out1 f t d p + pgn = out1 g t d p + + -- 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 :: [Doc] -> [Doc] + checkIndent [] = [] + checkIndent m@(x:xs) + | 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 = showDocOneLine x + strF = showDocOneLine (head pfn) + parens = length $ takeWhile (== '(') strG + cons = length $ takeWhile( /= ' ') (dropWhile(== '(') strF) + + out1 (f :*: g) t@Pref n p = out1 f t n p ++ out1 g t n p + + isNullary _ = False + +-- | 'fullPP' is a fully customizable Pretty Printer +-- +-- Every other pretty printer just gives some default values to 'fullPP' +fullPP :: (Out a) => (TextDetails -> b -> b) -- ^Function that handles the text conversion /(eg: 'outputIO')/ + -> b -- ^The end element of the result /( eg: "" or putChar('\n') )/ + -> Style -- ^The pretty printing 'Text.PrettyPrint.MyPretty.Style' to use + -> a -- ^The value to pretty print + -> b -- ^The pretty printed result +fullPP td end s a = fullRender (mode s) (lineLength s) (ribbonsPerLine s) td end doc + where + doc = docPrec 0 a + +defaultStyle :: Style +defaultStyle = Style {mode = PageMode, lineLength = 80, ribbonsPerLine = 1.5} + +-- | Utility function that handles the text conversion for 'fullPP'. +-- +-- 'outputIO' transforms the text into 'String's and outputs it directly. +outputIO :: TextDetails -> IO() -> IO() +outputIO td act = do + putStr $ decode td + act + where + decode :: TextDetails -> String + decode (Str s) = s + decode (PStr s1) = s1 + decode (Chr c) = [c] + +-- | Utility function that handles the text conversion for 'fullPP'. +-- +--'outputStr' just leaves the text as a 'String' which is usefull if you want +-- to further process the pretty printed result. +outputStr :: TextDetails -> String -> String +outputStr td str = decode td ++ str + where + decode :: TextDetails -> String + decode (Str s) = s + decode (PStr s1) = s1 + decode (Chr c) = [c] + +-- | Customizable pretty printer +-- +-- Takes a user defined 'Text.PrettyPrint.MyPretty.Style' as a parameter and uses 'outputStr' to obtain the result +-- +-- Equivalent to: +-- +-- > fullPP outputStr "" +prettyStyle :: (Out a) => Style -> a -> String +prettyStyle = fullPP outputStr "" + +-- | Semi-customizable pretty printer. +-- +-- Equivalent to: +-- +-- > prettyStyle customStyle +-- +-- Where customStyle uses the specified line length, mode = PageMode and ribbonsPerLine = 1. +prettyLen :: (Out a) => Int -> a -> String +prettyLen l = prettyStyle customStyle + where + customStyle = Style {mode = PageMode, lineLength = l, ribbonsPerLine = 1} + +-- | The default pretty printer returning 'String's +-- +-- Equivalent to +-- +-- > prettyStyle defaultStyle +-- +-- Where defaultStyle = (mode=PageMode, lineLength=80, ribbonsPerLine=1.5) +pretty :: (Out a) => a -> String +pretty = prettyStyle defaultStyle + +-- | Customizable pretty printer. +-- +-- Takes a user defined 'Text.PrettyPrint.MyPretty.Style' as a parameter and uses 'outputIO' to obtain the result +-- +-- Equivalent to: +-- +-- > fullPP outputIO (putChar '\n') +ppStyle :: (Out a) => Style -> a -> IO() +ppStyle = fullPP outputIO (putChar '\n') + +-- | Semi-customizable pretty printer. +-- +-- Equivalent to: +-- +-- > ppStyle customStyle +-- +-- Where customStyle uses the specified line length, mode = PageMode and ribbonsPerLine = 1. +ppLen :: (Out a) => Int -> a -> IO() +ppLen l = ppStyle customStyle + where + customStyle = Style {mode = PageMode, lineLength = l, ribbonsPerLine = 1} + +-- | The default Pretty Printer, +-- +-- Equivalent to: +-- +-- > ppStyle defaultStyle +-- +-- Where defaultStyle = (mode=PageMode, lineLength=80, ribbonsPerLine=1.5) +pp :: (Out a) => a -> IO() +pp = ppStyle defaultStyle + + +-- define some instances of Out making sure to generate output identical to 'show' modulo the extra whitespace +instance Out () where + doc _ = text "()" + docPrec _ = doc + +instance Out Char where + doc a = char '\'' <> (text.middle.show $ a) <> char '\'' + docPrec _ = doc + docList xs = text $ show xs + +instance Out Int where + docPrec n x + | n/=0 && x<0 = parens $ int x + | otherwise = int x + doc = docPrec 0 + +instance Out Integer where + docPrec n x + | n/=0 && x<0 = parens $ integer x + | otherwise = integer x + doc = docPrec 0 + +instance Out Float where + docPrec n x + | n/=0 && x<0 = parens $ float x + | otherwise = float x + doc = docPrec 0 + +instance Out Double where + docPrec n x + | n/=0 && x<0 = parens $ double x + | otherwise = double x + doc = docPrec 0 + +instance Out Rational where + docPrec n x + | n/=0 && x<0 = parens $ rational x + | otherwise = rational x + doc = docPrec 0 + +instance Out a => Out [a] where + doc = docList + docPrec _ = doc + +instance Out Bool where + doc True = text "True" + doc False = text "False" + docPrec _ = doc + +instance Out a => Out (Maybe a) where + docPrec n Nothing = text "Nothing" + docPrec n (Just x) + | n/=0 = parens result + |otherwise = result + where + result = text "Just" <+> docPrec 10 x + doc = docPrec 0 + +instance (Out a, Out b) => Out (Either a b) where + docPrec n (Left x) + | n/=0 = parens result + | otherwise = result + where + result = text "Left" <+> docPrec 10 x + docPrec n (Right y) + | n/=0 = parens result + | otherwise = result + where + result = text "Right" <+> docPrec 10 y + doc = docPrec 0 + +instance (Out a, Out b) => Out (a, b) where + doc (a,b) = parens (sep [doc a <> comma, doc b]) + docPrec _ = doc + +instance (Out a, Out b, Out c) => Out (a, b, c) where + doc (a,b,c) = parens (sep [doc a <> comma, doc b <> comma, doc c]) + docPrec _ = doc + +instance (Out a, Out b, Out c, Out d) => Out (a, b, c, d) where + doc (a,b,c,d) = parens (sep [doc a <> comma, doc b <> comma, doc c <> comma, doc d]) + docPrec _ = doc + +instance (Out a, Out b, Out c, Out d, Out e) => Out (a, b, c, d, e) where + doc (a,b,c,d,e) = parens (sep [doc a <> comma, doc b <> comma, doc c <> comma, doc d <> comma, doc e]) + docPrec _ = doc + +instance (Out a, Out b, Out c, Out d, Out e, Out f) + => Out (a, b, c, d, e, f) where + doc (a, b, c, d, e, f) = + parens (sep [ doc a <> comma, doc b <> comma, doc c <> comma, + doc d <> comma, doc e <> comma, doc f]) + docPrec _ = doc + +instance (Out a, Out b, Out c, Out d, Out e, Out f, Out g) + => Out (a, b, c, d, e, f, g) where + doc (a, b, c, d, e, f, g) = + parens (sep [ doc a <> comma, doc b <> comma, doc c <> comma, + doc d <> comma, doc e <> comma, doc f <> comma, doc g]) docPrec _ = doc