{-# 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 ((<$>))
simplePrintTree :: Data a => a -> Doc
simplePrintTree :: a -> Doc
simplePrintTree = DataToDoc -> forall a. Data a => a -> Doc
runDataToDoc ((DataToDoc -> DataToDoc) -> DataToDoc
forall a. (a -> a) -> a
fix DataToDoc -> DataToDoc
defaultToDocF)
simplePrintTreeWithCustom :: Data a => ToDocF -> a -> Doc
simplePrintTreeWithCustom :: (DataToDoc -> DataToDoc) -> a -> Doc
simplePrintTreeWithCustom toDocF :: DataToDoc -> DataToDoc
toDocF = DataToDoc -> forall a. Data a => a -> Doc
runDataToDoc ((DataToDoc -> DataToDoc) -> DataToDoc
forall a. (a -> a) -> a
fix DataToDoc -> DataToDoc
toDocF)
printTree :: forall a . Data a => Int -> a -> Doc
printTree :: Int -> a -> Doc
printTree startIndent :: Int
startIndent node :: a
node =
NodeLayouter -> Either Bool Int -> Doc
_lay_func (DataToLayouter -> a -> NodeLayouter
DataToLayouter -> forall a. Data a => a -> NodeLayouter
runDataToLayouter ((DataToLayouter -> DataToLayouter) -> DataToLayouter
forall a. (a -> a) -> a
fix DataToLayouter -> DataToLayouter
defaultLayouterF) a
node) (Int -> Either Bool Int
forall a b. b -> Either a b
Right Int
startIndent)
printTreeWithCustom :: Data a => Int -> LayouterF -> a -> Doc
printTreeWithCustom :: Int -> (DataToLayouter -> DataToLayouter) -> a -> Doc
printTreeWithCustom startIndent :: Int
startIndent layoutF :: DataToLayouter -> DataToLayouter
layoutF node :: a
node =
NodeLayouter -> Either Bool Int -> Doc
_lay_func (DataToLayouter -> a -> NodeLayouter
DataToLayouter -> forall a. Data a => a -> NodeLayouter
runDataToLayouter ((DataToLayouter -> DataToLayouter) -> DataToLayouter
forall a. (a -> a) -> a
fix DataToLayouter -> DataToLayouter
layoutF) a
node) (Int -> Either Bool Int
forall a b. b -> Either a b
Right Int
startIndent)
showTree :: Data a => a -> String
showTree :: a -> String
showTree = Doc -> String
render (Doc -> String) -> (a -> Doc) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a -> Doc
forall a. Data a => Int -> a -> Doc
printTree 100
showTreeWithCustom :: Data a => LayouterF -> a -> String
showTreeWithCustom :: (DataToLayouter -> DataToLayouter) -> a -> String
showTreeWithCustom layoutF :: DataToLayouter -> DataToLayouter
layoutF node :: a
node = Doc -> String
render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ Int -> (DataToLayouter -> DataToLayouter) -> a -> Doc
forall a.
Data a =>
Int -> (DataToLayouter -> DataToLayouter) -> a -> Doc
printTreeWithCustom 100 DataToLayouter -> DataToLayouter
layoutF a
node
newtype DataToDoc = DataToDoc
{ DataToDoc -> forall a. Data a => a -> Doc
runDataToDoc :: forall a . Data a => a -> Doc }
type ToDocF = DataToDoc -> DataToDoc
data NodeLayouter = NodeLayouter
{ NodeLayouter -> Int
_lay_llength :: Int
, NodeLayouter -> Bool
_lay_needsParens :: Bool
, NodeLayouter -> Either Bool Int -> Doc
_lay_func :: Either Bool Int -> Doc
}
newtype DataToLayouter = DataToLayouter
{ DataToLayouter -> forall a. Data a => a -> NodeLayouter
runDataToLayouter :: forall a . Data a => a -> NodeLayouter }
type LayouterF = DataToLayouter -> DataToLayouter
defaultToDocF :: ToDocF
defaultToDocF :: DataToDoc -> DataToDoc
defaultToDocF (DataToDoc lf :: forall a. Data a => a -> Doc
lf) = (forall a. Data a => a -> Doc) -> DataToDoc
DataToDoc ((forall a. Data a => a -> Doc) -> DataToDoc)
-> (forall a. Data a => a -> Doc) -> DataToDoc
forall a b. (a -> b) -> a -> b
$ a -> Doc
forall a. Data a => a -> Doc
genLayouter (a -> Doc) -> (forall e. Data e => [e] -> Doc) -> a -> Doc
forall d (t :: * -> *) q.
(Data d, Typeable t) =>
(d -> q) -> (forall e. Data e => t e -> q) -> d -> q
`ext1Q` forall e. Data e => [e] -> Doc
listLayouter
(a -> Doc) -> (String -> Doc) -> a -> Doc
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` String -> Doc
string
where
genLayouter :: a -> Doc
genLayouter n :: a
n =
let cStr :: String
cStr = Constr -> String
showConstr (Constr -> String) -> Constr -> String
forall a b. (a -> b) -> a -> b
$ a -> Constr
forall a. Data a => a -> Constr
toConstr a
n
childrenDoc :: [Doc]
childrenDoc = (forall a. Data a => a -> Doc) -> a -> [Doc]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
gmapQ forall a. Data a => a -> Doc
lf a
n
in String -> Doc
text String
cStr Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 2 ([Doc] -> Doc
vcat [Doc]
childrenDoc)
listLayouter :: forall b . Data b => [b] -> Doc
listLayouter :: [b] -> Doc
listLayouter [] = String -> Doc
text "[]"
listLayouter (x1 :: b
x1:xr :: [b]
xr) = String -> Doc
text "[" Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 2 Doc
d1
Doc -> Doc -> Doc
$$ [Doc] -> Doc
vcat [String -> Doc
text "," Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 2 Doc
d | Doc
d <- [Doc]
dr]
Doc -> Doc -> Doc
$$ String -> Doc
text "]"
where
d1 :: Doc
d1 = b -> Doc
forall a. Data a => a -> Doc
lf b
x1
dr :: [Doc]
dr = b -> Doc
forall a. Data a => a -> Doc
lf (b -> Doc) -> [b] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [b]
xr
string :: String -> Doc
string :: String -> Doc
string s :: String
s = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. Show a => a -> String
show String
s
defaultLayouterF :: LayouterF
defaultLayouterF :: DataToLayouter -> DataToLayouter
defaultLayouterF (DataToLayouter lf :: forall a. Data a => a -> NodeLayouter
lf) = (forall a. Data a => a -> NodeLayouter) -> DataToLayouter
DataToLayouter
((forall a. Data a => a -> NodeLayouter) -> DataToLayouter)
-> (forall a. Data a => a -> NodeLayouter) -> DataToLayouter
forall a b. (a -> b) -> a -> b
$ a -> NodeLayouter
forall a. Data a => a -> NodeLayouter
genLayouter (a -> NodeLayouter)
-> (forall e. Data e => [e] -> NodeLayouter) -> a -> NodeLayouter
forall d (t :: * -> *) q.
(Data d, Typeable t) =>
(d -> q) -> (forall e. Data e => t e -> q) -> d -> q
`ext1Q` forall e. Data e => [e] -> NodeLayouter
listLayouter
(a -> NodeLayouter)
-> (String -> NodeLayouter) -> a -> NodeLayouter
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` String -> NodeLayouter
string
where
genLayouter :: forall b . Data b => b -> NodeLayouter
genLayouter :: b -> NodeLayouter
genLayouter n :: b
n = Int -> Bool -> (Either Bool Int -> Doc) -> NodeLayouter
NodeLayouter Int
llen Bool
needParens Either Bool Int -> Doc
func
where
cs :: String
cs = Constr -> String
forall a. Show a => a -> String
show (Constr -> String) -> Constr -> String
forall a b. (a -> b) -> a -> b
$ b -> Constr
forall a. Data a => a -> Constr
toConstr b
n
subs :: [NodeLayouter]
subs = (forall a. Data a => a -> NodeLayouter) -> b -> [NodeLayouter]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
gmapQ forall a. Data a => a -> NodeLayouter
lf b
n
llen :: Int
llen = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
cs
Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [NodeLayouter] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [NodeLayouter]
subs
Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ if NodeLayouter -> Bool
_lay_needsParens NodeLayouter
s
then NodeLayouter -> Int
_lay_llength NodeLayouter
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2
else NodeLayouter -> Int
_lay_llength NodeLayouter
s
| NodeLayouter
s <- [NodeLayouter]
subs
]
needParens :: Bool
needParens = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [NodeLayouter] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NodeLayouter]
subs
func :: Either Bool Int -> Doc
func (Right i :: Int
i)
| Int
llenInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<=Int
i = String -> Doc
text String
cs Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep [NodeLayouter -> Either Bool Int -> Doc
_lay_func NodeLayouter
s (Bool -> Either Bool Int
forall a b. a -> Either a b
Left Bool
True) | NodeLayouter
s <- [NodeLayouter]
subs]
| Bool
otherwise = String -> Doc
text String
cs
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 2 ([Doc] -> Doc
vcat [NodeLayouter -> Either Bool Int -> Doc
_lay_func NodeLayouter
s (Int -> Either Bool Int
forall a b. b -> Either a b
Right (Int -> Either Bool Int) -> Int -> Either Bool Int
forall a b. (a -> b) -> a -> b
$ Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-2) | NodeLayouter
s <- [NodeLayouter]
subs])
func (Left True)
= (if [NodeLayouter] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NodeLayouter]
subs then Doc -> Doc
forall a. a -> a
id else Doc -> Doc
parens)
(Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
cs Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep [NodeLayouter -> Either Bool Int -> Doc
_lay_func NodeLayouter
s (Bool -> Either Bool Int
forall a b. a -> Either a b
Left Bool
True) | NodeLayouter
s <- [NodeLayouter]
subs]
func (Left False)
= String -> Doc
text String
cs Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep [NodeLayouter -> Either Bool Int -> Doc
_lay_func NodeLayouter
s (Bool -> Either Bool Int
forall a b. a -> Either a b
Left Bool
True) | NodeLayouter
s <- [NodeLayouter]
subs]
listLayouter :: forall b . Data b => [b] -> NodeLayouter
listLayouter :: [b] -> NodeLayouter
listLayouter [] = Int -> Bool -> (Either Bool Int -> Doc) -> NodeLayouter
NodeLayouter 2 Bool
False ((Either Bool Int -> Doc) -> NodeLayouter)
-> (Either Bool Int -> Doc) -> NodeLayouter
forall a b. (a -> b) -> a -> b
$ \_ -> String -> Doc
text "[]"
listLayouter xs :: [b]
xs@(_:_) = Int -> Bool -> (Either Bool Int -> Doc) -> NodeLayouter
NodeLayouter Int
llen Bool
False Either Bool Int -> Doc
forall a. Either a Int -> Doc
func
where
subs :: [NodeLayouter]
subs@(s1 :: NodeLayouter
s1:sr :: [NodeLayouter]
sr) = b -> NodeLayouter
forall a. Data a => a -> NodeLayouter
lf (b -> NodeLayouter) -> [b] -> [NodeLayouter]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [b]
xs
llen :: Int
llen = 1
Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [NodeLayouter] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [NodeLayouter]
subs
Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (NodeLayouter -> Int
_lay_llength (NodeLayouter -> Int) -> [NodeLayouter] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NodeLayouter]
subs)
func :: Either a Int -> Doc
func (Right i :: Int
i)
| Int
llenInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<=Int
i = String -> Doc
text "["
Doc -> Doc -> Doc
PP.<> [Doc] -> Doc
hcat (Doc -> [Doc] -> [Doc]
punctuate (String -> Doc
text ",") [NodeLayouter -> Either Bool Int -> Doc
_lay_func NodeLayouter
s (Bool -> Either Bool Int
forall a b. a -> Either a b
Left Bool
False) | NodeLayouter
s <- [NodeLayouter]
subs])
Doc -> Doc -> Doc
PP.<> String -> Doc
text "]"
| Bool
otherwise = String -> Doc
text "[" Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 2 (NodeLayouter -> Either Bool Int -> Doc
_lay_func NodeLayouter
s1 (Int -> Either Bool Int
forall a b. b -> Either a b
Right (Int -> Either Bool Int) -> Int -> Either Bool Int
forall a b. (a -> b) -> a -> b
$ Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-2))
Doc -> Doc -> Doc
$$ [Doc] -> Doc
vcat [String -> Doc
text "," Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 2 (NodeLayouter -> Either Bool Int -> Doc
_lay_func NodeLayouter
s (Int -> Either Bool Int
forall a b. b -> Either a b
Right (Int -> Either Bool Int) -> Int -> Either Bool Int
forall a b. (a -> b) -> a -> b
$ Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-2)) | NodeLayouter
s <- [NodeLayouter]
sr]
Doc -> Doc -> Doc
$$ String -> Doc
text "]"
func (Left _)
= Either a Int -> Doc
func (Int -> Either a Int
forall a b. b -> Either a b
Right 99999999)
string :: String -> NodeLayouter
string :: String -> NodeLayouter
string s :: String
s = Int -> Bool -> (Either Bool Int -> Doc) -> NodeLayouter
NodeLayouter (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s') Bool
False ((Either Bool Int -> Doc) -> NodeLayouter)
-> (Either Bool Int -> Doc) -> NodeLayouter
forall a b. (a -> b) -> a -> b
$ \_ -> String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
s'
where s' :: String
s' = String -> String
forall a. Show a => a -> String
show String
s