data-tree-print-0.1.0.2/0000755000000000000000000000000013364150743013044 5ustar0000000000000000data-tree-print-0.1.0.2/ChangeLog.md0000644000000000000000000000043113364150743015213 0ustar0000000000000000# Revision history for data-tree-print ## 0.1.0.2 -- October 2018 * Support ghc-8.6, but drop support for ghc<7.10 * Fix default formatter for strings ## 0.1.0.1 -- April 2018 * Fixups for ghc-8.4 ## 0.1.0.0 -- May 2017 * First version. Released on an unsuspecting world. data-tree-print-0.1.0.2/LICENSE0000644000000000000000000000277213364150743014061 0ustar0000000000000000Copyright (c) 2016, Lennart Spitzner 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 Lennart Spitzner 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. data-tree-print-0.1.0.2/data-tree-print.cabal0000644000000000000000000000301713364150743017031 0ustar0000000000000000name: data-tree-print version: 0.1.0.2 synopsis: Print Data instances as a nested tree license: BSD3 license-file: LICENSE author: Lennart Spitzner maintainer: Lennart Spitzner copyright: Copyright (C) 2016 Lennart Spitzner Homepage: https://github.com/lspitzner/data-tree-print Bug-reports: https://github.com/lspitzner/data-tree-print/issues category: Pretty Printer build-type: Simple extra-source-files: ChangeLog.md cabal-version: >=1.10 description: { Provides functionality similar to that of the `Show` class: Taking some arbitrary value and returning a String. . * Output is not intended to be valid haskell. . * Requires a `Data.Data.Data` instance instead of a `Text.Show` one. . * Output, if large, is often easier to parse than `show` output due to the formatting as a nested tree. . * The user can adapt the behaviour at runtime using custom layouting expressed via syb-style extension. } source-repository head { type: git location: https://github.com/lspitzner/data-tree-print.git } library exposed-modules: DataTreePrint build-depends: { base >=4.8 && <4.13 , pretty >=1.1 && <1.2 , syb >=0.6 && <0.8 } hs-source-dirs: src default-language: Haskell2010 ghc-options: { -Wall -fno-warn-orphans -fno-warn-unused-imports } if impl(ghc >= 8.0) { ghc-options: { -Wcompat } } data-tree-print-0.1.0.2/Setup.hs0000644000000000000000000000005613364150743014501 0ustar0000000000000000import Distribution.Simple main = defaultMain data-tree-print-0.1.0.2/src/0000755000000000000000000000000013364150743013633 5ustar0000000000000000data-tree-print-0.1.0.2/src/DataTreePrint.hs0000644000000000000000000001310313364150743016673 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} module DataTreePrint ( simplePrintTree , simplePrintTreeWithCustom , printTree , printTreeWithCustom , showTree , showTreeWithCustom , DataToLayouter(..) , LayouterF , NodeLayouter(..) , defaultLayouterF ) where import Data.Data import Text.PrettyPrint as PP import Data.Generics.Aliases import Data.Function (fix) import Data.Functor ((<$>)) -- | The "simple" printer does not try to fit more than one node into the -- same line, even if it would fit. simplePrintTree :: Data a => a -> Doc simplePrintTree = runDataToDoc (fix defaultToDocF) -- | Allows to specialize the transformation for specific types. Use `syb`'s -- `extQ` function(s). See the source of `defaultLayouterF` for an -- example of how to do this. simplePrintTreeWithCustom :: Data a => ToDocF -> a -> Doc simplePrintTreeWithCustom toDocF = runDataToDoc (fix toDocF) ------- ------- -- | Somewhat more intelligent printer that tries to fit multiple nodes -- into the same line there is space given the specified number of total -- columns. -- For example, `(1,2,3)` will be printed as "(,,) (1) (2) (3)" instead -- of "(,,)\n 1\n 2\n 3". Parentheses are added in these cases to prevent -- syntactic ambiguities. printTree :: forall a . Data a => Int -> a -> Doc printTree startIndent node = _lay_func (runDataToLayouter (fix defaultLayouterF) node) (Right startIndent) printTreeWithCustom :: Data a => Int -> LayouterF -> a -> Doc printTreeWithCustom startIndent layoutF node = _lay_func (runDataToLayouter (fix layoutF) node) (Right startIndent) showTree :: Data a => a -> String showTree = render . printTree 100 showTreeWithCustom :: Data a => LayouterF -> a -> String showTreeWithCustom layoutF node = render $ printTreeWithCustom 100 layoutF node -- | This newtype is necessary so `fix` can be used in combination with -- the constrained forall-quantification. newtype DataToDoc = DataToDoc { runDataToDoc :: forall a . Data a => a -> Doc } type ToDocF = DataToDoc -> DataToDoc data NodeLayouter = NodeLayouter { _lay_llength :: Int -- ^ the length of this node, if printed -- on a single line , _lay_needsParens :: Bool , _lay_func :: Either Bool Int -> Doc -- ^ Left: one-line output, the boolean -- indicates if parentheses are advisable -- given the context. (They can be omitted -- in cases like when there is only one -- constructor). -- Right: The Int is the remaining vertical -- space left for this node. } -- | This newtype is necessary so `fix` can be used in combination with -- the constrained forall-quantification. newtype DataToLayouter = DataToLayouter { runDataToLayouter :: forall a . Data a => a -> NodeLayouter } type LayouterF = DataToLayouter -> DataToLayouter defaultToDocF :: ToDocF defaultToDocF (DataToDoc lf) = DataToDoc $ genLayouter `ext1Q` listLayouter `extQ` string where genLayouter n = let cStr = showConstr $ toConstr n childrenDoc = gmapQ lf n in text cStr $$ nest 2 (vcat childrenDoc) listLayouter :: forall b . Data b => [b] -> Doc listLayouter [] = text "[]" listLayouter (x1:xr) = text "[" $$ nest 2 d1 $$ vcat [text "," $$ nest 2 d | d <- dr] $$ text "]" where d1 = lf x1 dr = lf <$> xr string :: String -> Doc string s = text $ show s defaultLayouterF :: LayouterF defaultLayouterF (DataToLayouter lf) = DataToLayouter $ genLayouter `ext1Q` listLayouter `extQ` string where genLayouter :: forall b . Data b => b -> NodeLayouter genLayouter n = NodeLayouter llen needParens func where cs = show $ toConstr n subs = gmapQ lf n llen = length cs + length subs + sum [ if _lay_needsParens s then _lay_llength s + 2 else _lay_llength s | s <- subs ] needParens = not $ null subs func (Right i) | llen<=i = text cs <+> hsep [_lay_func s (Left True) | s <- subs] | otherwise = text cs $$ nest 2 (vcat [_lay_func s (Right $ i-2) | s <- subs]) func (Left True) = (if null subs then id else parens) $ text cs <+> hsep [_lay_func s (Left True) | s <- subs] func (Left False) = text cs <+> hsep [_lay_func s (Left True) | s <- subs] listLayouter :: forall b . Data b => [b] -> NodeLayouter listLayouter [] = NodeLayouter 2 False $ \_ -> text "[]" listLayouter xs@(_:_) = NodeLayouter llen False func where subs@(s1:sr) = lf <$> xs llen = 1 + length subs + sum (_lay_llength <$> subs) func (Right i) | llen<=i = text "[" PP.<> hcat (punctuate (text ",") [_lay_func s (Left False) | s <- subs]) PP.<> text "]" | otherwise = text "[" $$ nest 2 (_lay_func s1 (Right $ i-2)) $$ vcat [text "," $$ nest 2 (_lay_func s (Right $ i-2)) | s <- sr] $$ text "]" func (Left _) = func (Right 99999999) string :: String -> NodeLayouter string s = NodeLayouter (length s') False $ \_ -> text $ s' where s' = show s