-- | -- n-ary tree structure with filter combinators -- copied and modified from HxXml () -- -- Version : $Id: NTree.hs,v 1.18 2003/09/18 13:29:52 hxml Exp $ module NTree ( -- * The NTree n-ary Tree Data Type NTree(..) , NTrees , TFilter , TSFilter, -- * Constructor Functions mkLeaf -- construktors , mkNode -- * Selector Functions and Predicates , getNode -- selectors , getChildren , satisfies -- predicate , formatNTree, -- trace output -- * Filter none -- simple filter , this , isOf , isOfNode -- predicate filter , mkNTree -- contructor filter , replaceNode -- simple editing , replaceChildren , modifyNode , modifyNode0 , modifyChildren , substChildren , processChildren -- filter combinators , o , (.>) , seqF , (..>) , (+++) , cat , orElse -- choices , choice , IfThen(..) , when , whenNot , guards , neg -- negation , containing -- previous: with, but with is keyword in haskell extensions , notContaining -- previous: without , (/>) -- selectors , (>) -- monadic composition , ifM -- monadic if then else , whenM -- special monadic ifs , whenNotM , guardsM , containingM , processChildrenM , liftM -- lift a normal filter to a monadic filter , ($$) -- apply a filter to a list , ($$<) -- apply a monad filter to a list , performAction -- run a command within a filter , foldNTree -- general NTree functions , mapNTree , nTreeToList , depthNTree , cardNTree ) where infixl 6 `containing`, `notContaining`, `containingM` infixr 5 `o`, +++ infixl 5 />, , ..>, .>> infixr 4 `when`, `whenNot`, `guards`, `whenM`, `whenNotM`, `guardsM` infixr 3 :-> infixr 0 $$, $$< -- | n-ary ordered tree with nodes of type node -- -- a tree consists of a node and a possible empty list of children. -- If the list of children is empty, the node is a leaf, else it's -- an inner node. data NTree node = NTree node (NTrees node) deriving (Eq, Ord, Show, Read) -- | -- a sequence of n-ary trees type NTrees node = [NTree node] -- | -- tree filter type: a function mapping a tree onto a list of trees -- -- filter can be used in various ways, as predicates, selectors, transformers, ... type TFilter node = NTree node -> NTrees node -- | -- a filter for sequences type TSFilter node = NTrees node -> NTrees node -- constructor functions -- | -- construct a leaf, a tree with an empty list of children -- -- * 1.parameter n : the node value -- -- - returns : the leaf containing the value n mkLeaf :: node -> NTree node mkLeaf n = NTree n [] -- | -- constructs a tree -- -- * 1.parameter n : the node value -- -- - 2.parameter cs : the list of children -- -- - returns : the tree mkNode :: node -> NTrees node -> NTree node mkNode n cs = NTree n cs -- selector functions -- | -- selector function for the node value of a tree -- -- * 1.parameter t : the tree -- -- - returns : the node getNode :: NTree node -> node getNode (NTree n _) = n -- | -- selector function for the children of a tree -- -- * 1.parameter t : the tree -- -- - returns : the list of children getChildren :: NTree node -> NTrees node getChildren (NTree _ cs) = cs -- ------------------------------------------------------------ -- | -- satisfies converts a result of a predicate filter into a boolean -- -- is a shortcut for not . null -- -- typical use in guards or ifs: @if (satisfies f) t then ... else ... @ -- -- * 1.parameter f : the predicate filter -- -- - 2.parameter t : the tree to be tested -- -- - returns : @b = not (null (f t))@ satisfies :: (a -> [b]) -> a -> Bool satisfies f = not . null . f -- ------------------------------------------------------------ -- -- simple filter -- | -- the null filter, returns the empty list none :: a -> [b] none _ = [] -- | -- the unit filter, returns the single element list containing the argument this :: a -> [a] this n = [n] -- ------------------------------------------------------------ -- -- selecting filter -- | -- conversion from predicate function to filter -- -- * 1.parameter p : the predicate for testing the tree -- -- - returns : 'this' or 'none' depending on the predicate isOf :: (a -> Bool) -> (a -> [a]) isOf p t = if p t then [t] else [] -- | -- select filter, selects trees with node values with a specific property -- -- * 1.parameter p : the predicate for testing the node value -- -- - returns : @[]@ or @[t]@ depending on @p t@ -- -- a special case of 'isOf' filter isOfNode :: (node -> Bool) -> TFilter node isOfNode p = isOf (p . getNode) -- ------------------------------------------------------------ -- -- simple editing filters -- | -- filter for substituting an arbitray tree by a constant -- -- * 1.parameter t : the result tree, the input tree is ignored -- -- - returns : the filter mkNTree :: NTree node -> TFilter node mkNTree t = const [t] -- | -- filter for replacing the node -- -- * 1.parameter n : the new node -- -- - returns : the editing filter replaceNode :: node -> TFilter node replaceNode n (NTree _ cs) = [NTree n cs] -- | -- filter for replacing the children -- -- * 1.parameter cs : cs the list of children -- -- - returns : the filter replaceChildren :: NTrees node -> TFilter node replaceChildren cs (NTree n _) = [NTree n cs] modifyNode :: (node -> Maybe node) -> TFilter node modifyNode tf (NTree n cs) = maybe [] (\ n' -> [NTree n' cs]) (tf n) -- | -- filter for editing the node -- -- * 1.parameter nf : the XNode editing funtion -- -- - returns : the filter modifyNode0 :: (node -> node) -> TFilter node modifyNode0 tf = modifyNode (Just . tf) -- | -- filter for editing the children -- -- all children are processed with a filter mapping lists to lists, -- this enables not only elementwise editing by lifting a normal -- filter to a list filter with @(f $$)@ (see '($$)') but also manipulation -- of the order of the elements, e.g. "reverse" is an appropriate childen -- editing function. -- -- * 1.parameter csf : the children editing function -- -- - returns : the filter -- -- see also : 'processChildren' modifyChildren :: TSFilter node -> TFilter node modifyChildren f -- (NTree n cs) -- = [NTree n (f cs)] = substChildren (f . getChildren) -- | -- filter for substituting the children of a tree by -- a new list of childen computed by applying a filter to the input tree. -- 'modifyChildren' can be expressed by 'substChildren': -- @modifyChildren f t@ is equal to @substChildren (f . getChildren)@ substChildren :: TFilter node -> TFilter node substChildren f t@(NTree n _cs) = [NTree n (f t)] -- ------------------------------------------------------------ -- -- combinators (copied from HaXml) -- -- | -- sequential composition of filters, usually written in infix notation f2 `o` f1. -- -- for predicate filter the logical AND -- -- * 1.parameter f2 : the 2. filter -- -- - 2.parameter f1 : the 1. filter -- -- - returns : the fiter applying first f1 to n and then f2 to the result (like function composition) o :: (a -> [b]) -> (c -> [a]) -> (c -> [b]) f `o` g = concatMap f . g -- | -- pronounced \"followed by\", defined as: @f .> g = g \`o\` f@. -- -- allows filter composition in a more readable way from left to right -- -- * 1.parameter f1 : the 1. filter -- -- - 2.parameter f2 : the 2. filter -- -- - returns : the composition of f1 and f2 -- -- see also : 'o', '(..>)' (.>) :: (a -> [b]) -> (b -> [c]) -> (a -> [c]) f .> g = g `o` f -- | -- apply a list of filters sequentially with '(.>)', for predicate filters the generalized AND -- -- see also : '(.>)' seqF :: [a -> [a]] -> (a -> [a]) seqF = foldl (.>) this -- | -- binary parallel composition, the logical OR for predicate filter -- -- * 1.parameter f1 : the 1. filter -- -- - 2.parameter f2 : the 2. filter -- -- - returns : the filter for applying f1 and f2 both to an argument tree and concatenating the results (+++) :: (a -> [b]) -> (a -> [b]) -> (a -> [b]) f +++ g = \ t -> f t ++ g t -- | -- special sequential composition. -- -- filter f is applied to an argument t. -- then filter g is applied to all elements of the result list, -- but the argument t is also passed as extra parameter to g. -- -- This allows for step by step transformations of a tree -- with access to the original tree in every -- transformation step. -- -- see also : '(.>)', 'o' (..>) :: (a -> [b]) -> (a -> b -> [d]) -> (a -> [d]) f ..> g = \ t -> (g t `o` f) t -- | -- apply a list of filters, a \"union\" for lists, for predicate filters the generalized OR -- -- * 1.parameter fs : the list of filters -- -- - returns : the composing filter cat :: [a -> [b]] -> (a -> [b]) cat fs t = concat [ f t | f <- fs ] -- | -- Filter for editing the children of a tree element wise -- -- * 1.parameter cf : the filter applied to the children -- -- - returns : the editing filter -- -- see also : 'modifyChildren' processChildren :: TFilter node -> TFilter node processChildren ft (NTree n cs) = [NTree n (ft $$ cs)] -- | -- infix operator for applying a filter to a list of trees -- -- * 1.parameter f : the filter -- -- - 2.parameter ts : the list of trees -- -- - returns : the concatenated list of results ($$) :: (a -> [b]) -> [a] -> [b] f $$ l = concatMap f l -- ------------------------------------------------------------ -- -- choices -- -- | -- directional choice, usually written in infix notation as f `orElse` g -- -- * 1.parameter f : the 1. filter -- -- - 2.parameter g : the 2. filter -- -- - 3.parameter t : the tree -- -- - returns : the filter, that applies f to t, if the result is not the empty list, the result is found, else g t is the result orElse :: (a -> [b]) -> (a -> [b]) -> (a -> [b]) f `orElse` g = \ t-> let res = f t in if null res then g t else res -- | -- if then else lifted to filters -- -- * 1.parameter p : the predicate filter -- -- - 2.parameter t : the \"then\" filter -- -- - 3.parameter e : the \"else\" filter -- -- - returns : the resulting conditional filter iff :: (a -> [c]) -> (a -> [b]) -> (a -> [b]) -> (a -> [b]) iff p f g = \ c -> if (satisfies p) c then f c else g c -- | -- when the predicate p holds, f is applied, else the identity filter this -- -- * 1.parameter f : the conditinally applied filter -- -- - 2.parameter p : the predicate -- -- - returns : the conditional filter -- -- see also : 'iff', 'whenNot', 'guards', 'whenM' when :: (a -> [a]) -> (a -> [a]) -> (a -> [a]) f `when` g = iff g f this -- | -- the complementary filter of when -- -- shortcut for f `when` neg g -- -- see also : 'iff', 'when', 'whenNotM', 'neg' whenNot :: (a -> [a]) -> (a -> [a]) -> (a -> [a]) f `whenNot` g = iff g this f -- | -- when the predicate p holds, f is applied, else the null filter none -- -- * 1.parameter p : the predicate filter -- -- - 2.parameter f : the conditionally applied filter -- -- - returns : the conditional filter -- -- see also : 'iff', 'when', 'guardsM' guards :: (a -> [b]) -> (a -> [b]) -> (a -> [b]) g `guards` f = iff g f none -- | -- negation lifted to filters -- -- * 1.parameter f : the predicate filter -- -- - returns : the filter, that succeeds, when f failed neg :: (a -> [c]) -> a -> [a] neg f = iff f none this -- | -- auxiliary datatype for cases within choice filter data IfThen a b = a :-> b -- | -- multiway branch. The list of cases @f :-> g@ is processed sequentially, -- in the first case for that f holds g is applied, if no case matches, 'none' is -- applied. -- This filter can be used like a case expression: @choice [ p1 :-> f1, p2 :-> f2, ... , this :-> defaultFilter]@ choice :: [IfThen (a -> [c]) (a -> [b])] -> (a -> [b]) choice [] = none choice ((g :-> f) : cs) = iff g f (choice cs) -- | -- pruning: keep only those results from f for which g holds, usually written in infix notation as f `containing` g -- -- * 1.parameter f : the processing filter -- -- - 2.parameter g : the predicate filter -- -- - 3.parameter t : the tree -- -- - returns : all trees r from f t, for which g r holds (is not the empty list) -- -- see also : 'notContaining' containing :: (a -> [b]) -> (b -> [c]) -> a -> [b] f `containing` g = filter (satisfies g) . f -- | -- pruning: keep only those results from f for which g does not hold -- -- see also : 'containing' notContaining :: (a -> [b]) -> (b -> [c]) -> a -> [b] f `notContaining` g = filter (null . g) . f -- | -- pruning: monadic version of containing, usually written in infix notation as f `containingM` g -- -- * 1.parameter f : the monadic processing filter -- -- - 2.parameter g : the predicate filter -- -- - 3.parameter t : the tree -- -- - returns : all trees r from f t, for which g r holds (is not the empty list) -- -- see also : 'notContaining' containingM :: Monad m => (a -> m [b]) -> (b -> [c]) -> a -> m [b] f `containingM` g = \ t -> do res <- f t return $ filter (satisfies g) res -- | -- pronounced \"slash\", meaning g inside f (/>) :: TFilter node -> TFilter node -> TFilter node f /> g = g `o` getChildren `o` f -- | -- pronounced \"outside\" meaning f containing g ( TFilter node -> TFilter node f TFilter node deep f = f `orElse` (deep f `o` getChildren) -- | -- bottom up search. -- -- first the children are processed, -- if this does not succeed, the node itself is processed -- can e.g. be used for finding all innermost tag nodes of a specific kind deepest :: TFilter node -> TFilter node deepest f = (getChildren .> deepest f) `orElse` f -- | -- process all nodes of the whole tree. -- -- can e.g. be used for finding all nodes of a specific kind multi :: TFilter node -> TFilter node multi f = f +++ (getChildren .> multi f) -- ------------------------------------------------------------ -- -- recursive transformation filters -- -- | -- bottom up transformation -- -- * 1.parameter f : the /simple/ transforming filter -- -- - returns : the filter that applies f to all subtrees and the tree itself in a deepth first left to right manner -- -- see also : 'processTopDown', 'processBottomUpIfNot' processBottomUp :: TFilter node -> TFilter node processBottomUp f = processChildren (processBottomUp f) .> f -- | -- top down transformation -- -- * 1.parameter f : the /simple/ transforming filter -- -- - returns : the filter that applies f first to the tree and then recursively to all subtrees of the result -- -- see also : 'processBottomUp' processTopDown :: TFilter node -> TFilter node processTopDown f = f .> processChildren (processTopDown f) -- | -- guarded bottom up transformation, stops at subtrees for which a predicate p holds -- -- * 1.parameter f : the transforming filter -- -- - 2.parameter p : the predicate filter for the guard -- -- - returns : the filter for processing all (sub-)trees -- -- see also : 'processBottomUp' processBottomUpIfNot :: TFilter node -> TFilter node -> TFilter node processBottomUpIfNot f p = (processChildren (processBottomUpIfNot f p) .> f) `whenNot` p -- | -- top down transformation until a node to be transformed is found -- -- * 1.parameter f : the /simple/ transforming filter -- -- - returns : the filter that applies f first to the tree and, if the filter does not succeed, -- recursively to all children of the input tree. -- -- Example: -- -- @processTopDownUntil none@ -- -- is the identity filter (maybe a bit more inefficient). -- -- Example: -- -- @processTopDownUntil (add1Attr \"border\" \"2\" \`containing\` isTag \"table\")@ -- -- is a filter for adding an attribute border=\"2\" in all top level table tags. -- The content of table tags will remain unchanged. -- -- see also : 'processTopDown', 'processBottomUp' processTopDownUntil :: TFilter node -> TFilter node processTopDownUntil f t | null res = processChildren (processTopDownUntil f) t | otherwise = res where res = f t -- ------------------------------------------------------------ -- -- monadic filter -- | -- the monadic version of the identity filter this. -- -- see also : 'this' thisM :: Monad m => (a -> m [a]) thisM = liftM this -- | -- the monadic version of the null filter none. -- -- see also : 'none' noneM :: Monad m => (a -> m [b]) noneM = liftM none -- | -- sequential composition of monadic filters, monadic version of \".>\". -- -- * 1.parameter f1 : the 1. monadic filter -- -- - 2.parameter f2 : the 2. monadic filter -- -- - returns : the monadic fiter applying first f1 to n and then f2 to the result (like function composition) -- -- see also : '(.>)' (.>>) :: Monad m => (a -> m[b]) -> (b -> m [c]) -> (a -> m[c]) cmd1 .>> cmd2 = \ t -> do r1 <- cmd1 t r2 <- mapM cmd2 r1 return (concat r2) -- | -- monadic if-then-else. -- -- * 1.parameter p : the predicate -- -- - 2.parameter thenP : the then part: the monadic filter, that is applied if p holds for the input tree -- -- - 3.parameter elseP : the else part -- -- - returns : the monadic filter for the conditional ifM :: Monad m => (a -> [b]) -> (a -> m [c]) -> (a -> m [c]) -> (a -> m [c]) ifM p thenPart elsePart = \ t -> if (satisfies p) t then thenPart t else elsePart t -- | -- when the predicate p holds, the monadic filter f is applied, else the identity filter. -- -- * 1.parameter f : the conditinally applied monadic filter -- -- - 2.parameter p : the simple predicate -- -- - returns : the conditional filter -- -- see also : 'ifM', 'when', 'guardsM', 'whenNotM' whenM :: Monad m => (a -> m [a]) -> (a -> [b]) -> (a -> m [a]) f `whenM` g = ifM g f thisM -- | -- the complementary filter of whenM. -- -- see also : 'ifM', 'whenM', 'whenNot' whenNotM :: Monad m => (a -> m [a]) -> (a -> [b]) -> (a -> m [a]) f `whenNotM` g = ifM g thisM f -- | -- when the predicate p holds, the monadic filter f is applied, else the null filter. -- -- * 1.parameter p : the simple predicate filter -- -- - 2.parameter f : the conditionally applied monadic filter -- -- - returns : the conditional filter -- -- see also : 'iffM', 'guards', 'whenM' guardsM :: Monad m => (a -> [b]) -> (a -> m [c]) -> (a -> m [c]) g `guardsM` f = ifM g f noneM -- | -- Filter for editing the children of a tree with a monadic filter -- -- * 1.parameter cf : the monadic filter applied to the children -- -- - returns : the monadic editing filter -- -- see also : 'processChildren' processChildrenM :: Monad m => (NTree node -> m [NTree node]) -> (NTree node -> m [NTree node]) processChildrenM ft (NTree n cs) = do res <- ft $$< cs return [NTree n res] -- | -- infix operator for applying a monadic filter to a list of trees, -- typically used in do-notation for processing of intermediate results. -- -- * 1.parameter f : the monadic filter -- -- - 2.parameter ts : the list of trees -- -- - returns : the concatenated list of results -- -- see also : '($$)' ($$<) :: Monad m => (a -> m [b]) -> [a] -> m [b] cmd $$< l = do r <- mapM cmd l return (concat r) -- | -- lift a filter to a monadic filter -- -- * 1.parameter f : the /simple/ filter -- -- - returns : the lifted monadic version liftM :: Monad m => (a -> [b]) -> a -> m [b] liftM f t = return (f t) -- | -- run an arbitray command on a tree t and return the tree, -- used for inserting arbitray commands in a filter pipeline -- -- * 1.parameter cmd : the command -- -- - 2.parameter t : the argument tree -- -- - returns : the unchanged tree as a single element list performAction :: Monad m => (a -> m b) -> a -> m [a] performAction cmd t = do cmd t return [t] -- ------------------------------------------------------------ -- | -- format tree -- -- a /graphical/ representation of the tree in text format is generated -- -- * 1.parameter nf : the conversion function from nodes to text -- -- - 2.parameter t : the tree -- -- - returns : the formatted text formatNTree :: (node -> String) -> NTree node -> String formatNTree node2String n = formatNTreeF node2String (showString "---") (showString " ") n "" -- ------------------------------------------------------------ -- | -- formating done with function composition -- like in standard prelude in class Show formatNTreeF :: (node -> String) -> (String -> String) -> (String -> String) -> NTree node -> String -> String formatNTreeF node2String pf1 pf2 (NTree n l) = formatNode . formatChildren pf2 l where formatNode = pf1 . foldr (.) id (map trNL (node2String n)) . showNL trNL '\n' = showNL . pf2 trNL c = showChar c showNL = showChar '\n' formatChildren _ [] = id formatChildren pf (t:ts) | null ts = pfl' . formatTr pf2' t | otherwise = pfl' . formatTr pf1' t . formatChildren pf ts where pf0' = pf . showString indent1 pf1' = pf . showString indent2 pf2' = pf . showString indent3 pfl' = pf . showString indent4 formatTr = formatNTreeF node2String pf0' indent1 = "+---" indent2 = "| " indent3 = " " indent4 = "|\n" -- ------------------------------------------------------------ -- | -- fold for NTree foldNTree :: (a -> [b] -> b) -> NTree a -> b foldNTree f (NTree n cs) = f n (map (foldNTree f) cs) -- | -- map for NTree mapNTree :: (a -> b) -> NTree a -> NTree b mapNTree f (NTree n cs) = NTree (f n) (map (mapNTree f) cs) -- | -- all nodes of a tree in preorder nTreeToList :: NTree a -> [a] nTreeToList = foldNTree (\ n rs -> n : concat rs) -- | -- depth of a tree depthNTree :: NTree a -> Int depthNTree = foldNTree (\ _ rs -> 1 + maximum (0 : rs)) -- | -- number of nodes in a tree cardNTree :: NTree a -> Int cardNTree = foldNTree (\ _ rs -> 1 + sum rs) -- ------------------------------------------------------------