-- | Abstracts away tree traversals.
-- Mostly used by callers including (soon) XML Conduit Stylist,
-- but also used internally for generating counter text.
module Stylist.Tree(StyleTree(..), treeOrder, treeOrder',
    Path, treeMap, treeFind, treeFlatten, treeFlattenAll, preorder, preorder', postorder) where

-- | A generic tree, variable numbers of children.
data StyleTree p = StyleTree {
    forall p. StyleTree p -> p
style :: p,
    forall p. StyleTree p -> [StyleTree p]
children :: [StyleTree p]
} deriving (ReadPrec [StyleTree p]
ReadPrec (StyleTree p)
Int -> ReadS (StyleTree p)
ReadS [StyleTree p]
(Int -> ReadS (StyleTree p))
-> ReadS [StyleTree p]
-> ReadPrec (StyleTree p)
-> ReadPrec [StyleTree p]
-> Read (StyleTree p)
forall p. Read p => ReadPrec [StyleTree p]
forall p. Read p => ReadPrec (StyleTree p)
forall p. Read p => Int -> ReadS (StyleTree p)
forall p. Read p => ReadS [StyleTree p]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall p. Read p => Int -> ReadS (StyleTree p)
readsPrec :: Int -> ReadS (StyleTree p)
$creadList :: forall p. Read p => ReadS [StyleTree p]
readList :: ReadS [StyleTree p]
$creadPrec :: forall p. Read p => ReadPrec (StyleTree p)
readPrec :: ReadPrec (StyleTree p)
$creadListPrec :: forall p. Read p => ReadPrec [StyleTree p]
readListPrec :: ReadPrec [StyleTree p]
Read, Int -> StyleTree p -> ShowS
[StyleTree p] -> ShowS
StyleTree p -> String
(Int -> StyleTree p -> ShowS)
-> (StyleTree p -> String)
-> ([StyleTree p] -> ShowS)
-> Show (StyleTree p)
forall p. Show p => Int -> StyleTree p -> ShowS
forall p. Show p => [StyleTree p] -> ShowS
forall p. Show p => StyleTree p -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall p. Show p => Int -> StyleTree p -> ShowS
showsPrec :: Int -> StyleTree p -> ShowS
$cshow :: forall p. Show p => StyleTree p -> String
show :: StyleTree p -> String
$cshowList :: forall p. Show p => [StyleTree p] -> ShowS
showList :: [StyleTree p] -> ShowS
Show, StyleTree p -> StyleTree p -> Bool
(StyleTree p -> StyleTree p -> Bool)
-> (StyleTree p -> StyleTree p -> Bool) -> Eq (StyleTree p)
forall p. Eq p => StyleTree p -> StyleTree p -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall p. Eq p => StyleTree p -> StyleTree p -> Bool
== :: StyleTree p -> StyleTree p -> Bool
$c/= :: forall p. Eq p => StyleTree p -> StyleTree p -> Bool
/= :: StyleTree p -> StyleTree p -> Bool
Eq, Eq (StyleTree p)
Eq (StyleTree p)
-> (StyleTree p -> StyleTree p -> Ordering)
-> (StyleTree p -> StyleTree p -> Bool)
-> (StyleTree p -> StyleTree p -> Bool)
-> (StyleTree p -> StyleTree p -> Bool)
-> (StyleTree p -> StyleTree p -> Bool)
-> (StyleTree p -> StyleTree p -> StyleTree p)
-> (StyleTree p -> StyleTree p -> StyleTree p)
-> Ord (StyleTree p)
StyleTree p -> StyleTree p -> Bool
StyleTree p -> StyleTree p -> Ordering
StyleTree p -> StyleTree p -> StyleTree p
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {p}. Ord p => Eq (StyleTree p)
forall p. Ord p => StyleTree p -> StyleTree p -> Bool
forall p. Ord p => StyleTree p -> StyleTree p -> Ordering
forall p. Ord p => StyleTree p -> StyleTree p -> StyleTree p
$ccompare :: forall p. Ord p => StyleTree p -> StyleTree p -> Ordering
compare :: StyleTree p -> StyleTree p -> Ordering
$c< :: forall p. Ord p => StyleTree p -> StyleTree p -> Bool
< :: StyleTree p -> StyleTree p -> Bool
$c<= :: forall p. Ord p => StyleTree p -> StyleTree p -> Bool
<= :: StyleTree p -> StyleTree p -> Bool
$c> :: forall p. Ord p => StyleTree p -> StyleTree p -> Bool
> :: StyleTree p -> StyleTree p -> Bool
$c>= :: forall p. Ord p => StyleTree p -> StyleTree p -> Bool
>= :: StyleTree p -> StyleTree p -> Bool
$cmax :: forall p. Ord p => StyleTree p -> StyleTree p -> StyleTree p
max :: StyleTree p -> StyleTree p -> StyleTree p
$cmin :: forall p. Ord p => StyleTree p -> StyleTree p -> StyleTree p
min :: StyleTree p -> StyleTree p -> StyleTree p
Ord)

-- | Indices within the tree.
type Path = [Integer]
-- | Preorder traversal of the tree.
treeOrder :: (c -> c -> Path -> p -> (c, p')) ->
    c -> StyleTree p -> StyleTree p'
treeOrder :: forall c p p'.
(c -> c -> Path -> p -> (c, p'))
-> c -> StyleTree p -> StyleTree p'
treeOrder c -> c -> Path -> p -> (c, p')
cb c
ctxt StyleTree p
tree = p' -> [StyleTree p'] -> StyleTree p'
forall p. p -> [StyleTree p] -> StyleTree p
StyleTree
    ((c, p') -> p'
forall a b. (a, b) -> b
snd ((c, p') -> p') -> (c, p') -> p'
forall a b. (a -> b) -> a -> b
$ c -> c -> Path -> p -> (c, p')
cb c
ctxt c
ctxt [] (p -> (c, p')) -> p -> (c, p')
forall a b. (a -> b) -> a -> b
$ StyleTree p -> p
forall p. StyleTree p -> p
style StyleTree p
tree)
    ((c, [StyleTree p']) -> [StyleTree p']
forall a b. (a, b) -> b
snd ((c, [StyleTree p']) -> [StyleTree p'])
-> (c, [StyleTree p']) -> [StyleTree p']
forall a b. (a -> b) -> a -> b
$ (c -> c -> Path -> p -> (c, p'))
-> c -> c -> Path -> [StyleTree p] -> (c, [StyleTree p'])
forall c p p'.
(c -> c -> Path -> p -> (c, p'))
-> c -> c -> Path -> [StyleTree p] -> (c, [StyleTree p'])
treeOrder' c -> c -> Path -> p -> (c, p')
cb c
ctxt c
ctxt [Integer
0] ([StyleTree p] -> (c, [StyleTree p']))
-> [StyleTree p] -> (c, [StyleTree p'])
forall a b. (a -> b) -> a -> b
$ StyleTree p -> [StyleTree p]
forall p. StyleTree p -> [StyleTree p]
children StyleTree p
tree)
-- | Preorder traversal of the tree managing per-layer contexts.
treeOrder' :: (c -> c -> Path -> p -> (c, p')) ->
    c -> c -> Path -> [StyleTree p] -> (c, [StyleTree p'])
treeOrder' :: forall c p p'.
(c -> c -> Path -> p -> (c, p'))
-> c -> c -> Path -> [StyleTree p] -> (c, [StyleTree p'])
treeOrder' c -> c -> Path -> p -> (c, p')
cb c
prevContext c
context (Integer
num:Path
path) (StyleTree p
node:[StyleTree p]
nodes) = (c
tailContext, p' -> [StyleTree p'] -> StyleTree p'
forall p. p -> [StyleTree p] -> StyleTree p
StyleTree p'
node' [StyleTree p']
children' StyleTree p' -> [StyleTree p'] -> [StyleTree p']
forall a. a -> [a] -> [a]
: [StyleTree p']
nodes')
    where
        (c
selfContext, p'
node') = c -> c -> Path -> p -> (c, p')
cb c
prevContext c
context (Integer
numInteger -> Path -> Path
forall a. a -> [a] -> [a]
:Path
path) (p -> (c, p')) -> p -> (c, p')
forall a b. (a -> b) -> a -> b
$ StyleTree p -> p
forall p. StyleTree p -> p
style StyleTree p
node
        (c
childContext, [StyleTree p']
children') = (c -> c -> Path -> p -> (c, p'))
-> c -> c -> Path -> [StyleTree p] -> (c, [StyleTree p'])
forall c p p'.
(c -> c -> Path -> p -> (c, p'))
-> c -> c -> Path -> [StyleTree p] -> (c, [StyleTree p'])
treeOrder' c -> c -> Path -> p -> (c, p')
cb c
selfContext c
selfContext (Integer
0Integer -> Path -> Path
forall a. a -> [a] -> [a]
:Integer
numInteger -> Path -> Path
forall a. a -> [a] -> [a]
:Path
path) ([StyleTree p] -> (c, [StyleTree p']))
-> [StyleTree p] -> (c, [StyleTree p'])
forall a b. (a -> b) -> a -> b
$ StyleTree p -> [StyleTree p]
forall p. StyleTree p -> [StyleTree p]
children StyleTree p
node
        (c
tailContext, [StyleTree p']
nodes') = (c -> c -> Path -> p -> (c, p'))
-> c -> c -> Path -> [StyleTree p] -> (c, [StyleTree p'])
forall c p p'.
(c -> c -> Path -> p -> (c, p'))
-> c -> c -> Path -> [StyleTree p] -> (c, [StyleTree p'])
treeOrder' c -> c -> Path -> p -> (c, p')
cb c
selfContext c
childContext (Integer
num Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1Integer -> Path -> Path
forall a. a -> [a] -> [a]
:Path
path) [StyleTree p]
nodes
treeOrder' c -> c -> Path -> p -> (c, p')
_ c
_ c
context Path
_ [] = (c
context, [])
treeOrder' c -> c -> Path -> p -> (c, p')
_ c
_ c
_ [] [StyleTree p]
_ = String -> (c, [StyleTree p'])
forall a. HasCallStack => String -> a
error String
"Invalid path during tree traversal!"

-- | Runs a callback over all `style` properties in the tree.
treeMap :: (p -> p') -> StyleTree p -> StyleTree p'
treeMap :: forall p p'. (p -> p') -> StyleTree p -> StyleTree p'
treeMap p -> p'
cb = (() -> () -> Path -> p -> ((), p'))
-> () -> StyleTree p -> StyleTree p'
forall c p p'.
(c -> c -> Path -> p -> (c, p'))
-> c -> StyleTree p -> StyleTree p'
treeOrder (\()
_ ()
_ Path
_ p
p -> ((), p -> p'
cb p
p)) ()

-- | Flatten a styletree into a list.
treeFlatten :: StyleTree p -> [p]
treeFlatten :: forall p. StyleTree p -> [p]
treeFlatten = [StyleTree p] -> [p]
forall p. [StyleTree p] -> [p]
treeFlatten' ([StyleTree p] -> [p])
-> (StyleTree p -> [StyleTree p]) -> StyleTree p -> [p]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StyleTree p -> [StyleTree p]
forall p. StyleTree p -> [StyleTree p]
children
-- | Flatten a list of styletrees into a list.
treeFlatten' :: [StyleTree p] -> [p]
treeFlatten' :: forall p. [StyleTree p] -> [p]
treeFlatten' (StyleTree p
p []:[StyleTree p]
ps) = p
p p -> [p] -> [p]
forall a. a -> [a] -> [a]
: [StyleTree p] -> [p]
forall p. [StyleTree p] -> [p]
treeFlatten' [StyleTree p]
ps
treeFlatten' (StyleTree p
_ [StyleTree p]
childs:[StyleTree p]
sibs) = [StyleTree p] -> [p]
forall p. [StyleTree p] -> [p]
treeFlatten' [StyleTree p]
childs [p] -> [p] -> [p]
forall a. [a] -> [a] -> [a]
++ [StyleTree p] -> [p]
forall p. [StyleTree p] -> [p]
treeFlatten' [StyleTree p]
sibs
treeFlatten' [] = []

-- | Flatten a styletree into a list, including parent nodes.
treeFlattenAll :: StyleTree p -> [p]
treeFlattenAll :: forall p. StyleTree p -> [p]
treeFlattenAll = [StyleTree p] -> [p]
forall p. [StyleTree p] -> [p]
treeFlattenAll' ([StyleTree p] -> [p])
-> (StyleTree p -> [StyleTree p]) -> StyleTree p -> [p]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StyleTree p -> [StyleTree p]
forall p. StyleTree p -> [StyleTree p]
children
-- | Flatten styletrees into a list, including parent nodes.
treeFlattenAll' :: [StyleTree p] -> [p]
treeFlattenAll' :: forall p. [StyleTree p] -> [p]
treeFlattenAll' (StyleTree p
p []:[StyleTree p]
ps) = p
p p -> [p] -> [p]
forall a. a -> [a] -> [a]
: [StyleTree p] -> [p]
forall p. [StyleTree p] -> [p]
treeFlattenAll' [StyleTree p]
ps
treeFlattenAll' (StyleTree p
p [StyleTree p]
childs:[StyleTree p]
sibs) = p
p p -> [p] -> [p]
forall a. a -> [a] -> [a]
: [StyleTree p] -> [p]
forall p. [StyleTree p] -> [p]
treeFlattenAll' [StyleTree p]
childs [p] -> [p] -> [p]
forall a. [a] -> [a] -> [a]
++ [StyleTree p] -> [p]
forall p. [StyleTree p] -> [p]
treeFlattenAll' [StyleTree p]
sibs
treeFlattenAll' [] = []

-- | Find the styltree node matching the given predicate.
treeFind :: StyleTree p -> (p -> Bool) -> [p]
treeFind :: forall p. StyleTree p -> (p -> Bool) -> [p]
treeFind StyleTree p
p p -> Bool
test = (p -> Bool) -> [p] -> [p]
forall a. (a -> Bool) -> [a] -> [a]
filter p -> Bool
test ([p] -> [p]) -> [p] -> [p]
forall a b. (a -> b) -> a -> b
$ StyleTree p -> [p]
forall p. StyleTree p -> [p]
treeFlattenAll StyleTree p
p

-- | Preorder traversal over a tree, without tracking contexts.
preorder :: (Maybe b -> Maybe b -> a -> b) -> StyleTree a -> StyleTree b
preorder :: forall b a.
(Maybe b -> Maybe b -> a -> b) -> StyleTree a -> StyleTree b
preorder Maybe b -> Maybe b -> a -> b
cb StyleTree a
self = [StyleTree b] -> StyleTree b
forall a. HasCallStack => [a] -> a
head ([StyleTree b] -> StyleTree b) -> [StyleTree b] -> StyleTree b
forall a b. (a -> b) -> a -> b
$ (Maybe b -> Maybe b -> a -> b)
-> Maybe b -> Maybe b -> [StyleTree a] -> [StyleTree b]
forall b a.
(Maybe b -> Maybe b -> a -> b)
-> Maybe b -> Maybe b -> [StyleTree a] -> [StyleTree b]
preorder' Maybe b -> Maybe b -> a -> b
cb Maybe b
forall a. Maybe a
Nothing Maybe b
forall a. Maybe a
Nothing [StyleTree a
self]
-- | Variant of `preorder` with given parent & previous-sibling.
preorder' :: (Maybe b -> Maybe b -> a -> b) ->
        Maybe b -> Maybe b -> [StyleTree a] -> [StyleTree b]
preorder' :: forall b a.
(Maybe b -> Maybe b -> a -> b)
-> Maybe b -> Maybe b -> [StyleTree a] -> [StyleTree b]
preorder' Maybe b -> Maybe b -> a -> b
cb Maybe b
parent Maybe b
previous (StyleTree a
self:[StyleTree a]
sibs) = let self' :: b
self' = Maybe b -> Maybe b -> a -> b
cb Maybe b
parent Maybe b
previous (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ StyleTree a -> a
forall p. StyleTree p -> p
style StyleTree a
self
        in b -> [StyleTree b] -> StyleTree b
forall p. p -> [StyleTree p] -> StyleTree p
StyleTree b
self' ((Maybe b -> Maybe b -> a -> b)
-> Maybe b -> Maybe b -> [StyleTree a] -> [StyleTree b]
forall b a.
(Maybe b -> Maybe b -> a -> b)
-> Maybe b -> Maybe b -> [StyleTree a] -> [StyleTree b]
preorder' Maybe b -> Maybe b -> a -> b
cb (b -> Maybe b
forall a. a -> Maybe a
Just b
self') Maybe b
forall a. Maybe a
Nothing ([StyleTree a] -> [StyleTree b]) -> [StyleTree a] -> [StyleTree b]
forall a b. (a -> b) -> a -> b
$ StyleTree a -> [StyleTree a]
forall p. StyleTree p -> [StyleTree p]
children StyleTree a
self) StyleTree b -> [StyleTree b] -> [StyleTree b]
forall a. a -> [a] -> [a]
:
            (Maybe b -> Maybe b -> a -> b)
-> Maybe b -> Maybe b -> [StyleTree a] -> [StyleTree b]
forall b a.
(Maybe b -> Maybe b -> a -> b)
-> Maybe b -> Maybe b -> [StyleTree a] -> [StyleTree b]
preorder' Maybe b -> Maybe b -> a -> b
cb Maybe b
parent (b -> Maybe b
forall a. a -> Maybe a
Just b
self') [StyleTree a]
sibs
preorder' Maybe b -> Maybe b -> a -> b
_ Maybe b
_ Maybe b
_ [] = []

-- | Postorder traversal over the tree.
postorder :: (a -> [b] -> [b]) -> StyleTree a -> [StyleTree b]
postorder :: forall a b. (a -> [b] -> [b]) -> StyleTree a -> [StyleTree b]
postorder a -> [b] -> [b]
cb (StyleTree a
self [StyleTree a]
childs) =
    [b -> [StyleTree b] -> StyleTree b
forall p. p -> [StyleTree p] -> StyleTree p
StyleTree b
self' [StyleTree b]
children' | b
self' <- a -> [b] -> [b]
cb a
self ([b] -> [b]) -> [b] -> [b]
forall a b. (a -> b) -> a -> b
$ (StyleTree b -> b) -> [StyleTree b] -> [b]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map StyleTree b -> b
forall p. StyleTree p -> p
style [StyleTree b]
children']
  where children' :: [StyleTree b]
children' = [[StyleTree b]] -> [StyleTree b]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[StyleTree b]] -> [StyleTree b])
-> [[StyleTree b]] -> [StyleTree b]
forall a b. (a -> b) -> a -> b
$ (StyleTree a -> [StyleTree b]) -> [StyleTree a] -> [[StyleTree b]]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map ((a -> [b] -> [b]) -> StyleTree a -> [StyleTree b]
forall a b. (a -> [b] -> [b]) -> StyleTree a -> [StyleTree b]
postorder a -> [b] -> [b]
cb) [StyleTree a]
childs