diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for data-tree-print + +## 0.1.0.0 -- May 2017 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/data-tree-print.cabal b/data-tree-print.cabal new file mode 100644 --- /dev/null +++ b/data-tree-print.cabal @@ -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 + } diff --git a/src/DataTreePrint.hs b/src/DataTreePrint.hs new file mode 100644 --- /dev/null +++ b/src/DataTreePrint.hs @@ -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