-- | 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 {
    StyleTree p -> p
style :: p,
    StyleTree p -> [StyleTree p]
children :: [StyleTree p]
}

-- | 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 :: (c -> c -> Path -> p -> (c, p'))
-> c -> StyleTree p -> StyleTree p'
treeOrder cb :: c -> c -> Path -> p -> (c, p')
cb ctxt :: c
ctxt tree :: 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 [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' :: (c -> c -> Path -> p -> (c, p'))
-> c -> c -> Path -> [StyleTree p] -> (c, [StyleTree p'])
treeOrder' cb :: c -> c -> Path -> p -> (c, p')
cb prevContext :: c
prevContext context :: c
context (num :: Integer
num:path :: Path
path) (node :: StyleTree p
node:nodes :: [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
        (selfContext :: c
selfContext, node' :: 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
        (childContext :: c
childContext, children' :: [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 (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
        (tailContext :: c
tailContext, nodes' :: [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
+ 1Integer -> Path -> Path
forall a. a -> [a] -> [a]
:Path
path) [StyleTree p]
nodes
treeOrder' _ _ context :: c
context _ [] = (c
context, [])
treeOrder' _ _ _ [] _ = [Char] -> (c, [StyleTree p'])
forall a. HasCallStack => [Char] -> a
error "Invalid path during tree traversal!"

-- | Runs a callback over all `style` properties in the tree.
treeMap :: (p -> p') -> StyleTree p -> StyleTree p'
treeMap :: (p -> p') -> StyleTree p -> StyleTree p'
treeMap cb :: 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 (\_ _ _ p :: p
p -> ((), p -> p'
cb p
p)) ()

-- | Flatten a styletree into a list.
treeFlatten :: StyleTree p -> [p]
treeFlatten :: 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' :: [StyleTree p] -> [p]
treeFlatten' (StyleTree p :: p
p []:ps :: [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 _ childs :: [StyleTree p]
childs:sibs :: [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 :: 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' :: [StyleTree p] -> [p]
treeFlattenAll' (StyleTree p :: p
p []:ps :: [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
p childs :: [StyleTree p]
childs:sibs :: [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 :: StyleTree p -> (p -> Bool) -> [p]
treeFind p :: StyleTree p
p test :: 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 :: (Maybe b -> Maybe b -> a -> b) -> StyleTree a -> StyleTree b
preorder cb :: Maybe b -> Maybe b -> a -> b
cb self :: StyleTree a
self = [StyleTree b] -> StyleTree b
forall a. [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' :: (Maybe b -> Maybe b -> a -> b)
-> Maybe b -> Maybe b -> [StyleTree a] -> [StyleTree b]
preorder' cb :: Maybe b -> Maybe b -> a -> b
cb parent :: Maybe b
parent previous :: Maybe b
previous (self :: StyleTree a
self:sibs :: [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' _ _ _ [] = []

-- | Postorder traversal over the tree.
postorder :: (a -> [b] -> [b]) -> StyleTree a -> [StyleTree b]
postorder :: (a -> [b] -> [b]) -> StyleTree a -> [StyleTree b]
postorder cb :: a -> [b] -> [b]
cb (StyleTree self :: a
self childs :: [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