data-tree-print (empty) → 0.1.0.0
raw patch · 5 files changed
+244/−0 lines, 5 filesdep +basedep +prettydep +sybsetup-changed
Dependencies added: base, pretty, syb
Files
- ChangeLog.md +5/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- data-tree-print.cabal +49/−0
- src/DataTreePrint.hs +158/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for data-tree-print++## 0.1.0.0 -- May 2017++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ data-tree-print.cabal view
@@ -0,0 +1,49 @@+name: data-tree-print+version: 0.1.0.0+synopsis: Print Data instances as a nested tree+license: BSD3+license-file: LICENSE+author: Lennart Spitzner+maintainer: lsp@informatik.uni-kiel.de+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.3 && <4.10+ , pretty >=1.1 && <1.2+ , syb >=0.6 && <0.7+ }+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: {+ -Wall+ -fno-warn-orphans+ -fno-warn-unused-imports+ }
+ src/DataTreePrint.hs view
@@ -0,0 +1,158 @@+{-# 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++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 `extQ` string+ `ext1Q` listLayouter+ 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 "["+ <> hcat (punctuate (text ",") [_lay_func s (Left False) | s <- subs])+ <> 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