----------------------------------------------------------------------------
--
-- Module	: XMLCombinators
-- Copyright	: (C) 2001,2002 Joe English.  Freely redistributable.
-- License	: "MIT-style"
--
-- Author	: Joe English <jenglish@flightlab.com>
-- Stability	: experimental
-- Portability	: portable
--
-- CVS  	: $Id: XMLCombinators.hs,v 1.6 2003/06/18 18:47:03 joe Exp $
--
----------------------------------------------------------------------------
--
-- 2 Nov 2001; revised 5 Nov 2001 to use Arrows.
--

module XMLCombinators
    ( module Arrow, module Filter, module HXML
    , xmlFilterMain, testFilter
    , qSelf, qChildren, qDescendants, qSubtree
    , qElem, qElems, qText, qEntity
    , qAttval, qAttlist, qNodeName
    , mkElem, mkElement
    , mkText, mkLiteral
    , mkAtt
    , apChildren, keepText
    , qInner, qOuter, qFirst
    , qMatch, qTest
    , aFoldTree, aScanTree
    , (.//), (./), (|>|), (|?>), qChildElem
    )
    where

import Monad
import Arrow
import Filter
import HXML

infixr 2 |?>		-- same as ?>, :>
infixl 1 ./, .//	-- same as >>>

--
-- Predicate adapters:
--

qMatch :: Filter a b -> Filter a a
qMatch f = aGuard (not . null . runFilter f)

qTest :: Filter a b -> Filter a Bool
qTest f = makeFilter (return . not . null . runFilter f)

(|?>) :: Filter a x -> Choice (Filter a b) -> Filter a b
f |?> choice = (not . null . runFilter f) ?> choice

--
-- Constructors:
--

mkNode :: a -> Filter s (Tree a) -> Filter s (Tree a)
mkNode nd body = makeFilter (\x -> [Tree nd (runFilter body x)])

mkLiteral :: String -> Filter a XML
mkLiteral = aConst . leafNode . TXNode

mkElem :: Name -> Filter a XML -> Filter a XML
mkElem name = mkNode (ELNode name [])

mkElement :: Name -> Filter a (Name,String) -> Filter a XML -> Filter a XML
mkElement name atts body = arr $ \x ->
	Tree (ELNode name (runFilter atts x)) (runFilter body x)

mkAtt :: Name -> Filter a String -> Filter a (Name,String)
mkAtt name val = aConst name &&& val

mkText :: Filter String XML
mkText = arr (leafNode . TXNode)

--
-- Navigation:
--

qChildren, qDescendants, qSubtree :: Filter (Tree a) (Tree a)
qChildren	= makeFilter treeChildren
qSubtree	= qSelf +++ (qChildren >>> qSubtree)
qDescendants	= qChildren >>> qSubtree

qInner, qOuter :: Filter (Tree a) b -> Filter (Tree a) b
qOuter p = p |>| (qChildren >>> qOuter p)
qInner p = (qChildren >>> qInner p) |>| p


(|>|) :: Filter a b -> Filter a b -> Filter a b
f |>| g = makeFilter choose where
    choose x = let fx = runFilter f x in if null fx then runFilter g x else fx

qFirst :: Filter a b -> Filter a b
qFirst = apFilter take1 where
	take1 [] 	= []
	take1 (x:_)	= [x]

--
-- Editing:
--

apChildren :: Filter (Tree a) (Tree a) -> Filter (Tree a) (Tree a)
apChildren f = arr (\(Tree x ts) -> Tree x (ts >>= runFilter f))

aFoldTree, aScanTree :: Filter (Tree a) (Tree a) -> Filter (Tree a) (Tree a)

aFoldTree f = apChildren (aFoldTree f) >>> f
aScanTree f = f >>> apChildren (aScanTree f)

--
-- Predicates:
--

qElem :: Name -> Filter XML XML
qElem name = aGuard (q . treeRoot) where
    q (ELNode gi _)	= gi == name
    q _			= False

qElems :: [Name] -> Filter XML XML	-- =  foldr1 (|>|) . map qElem
qElems gis = aGuard (test . treeRoot) where
    test (ELNode gi _)	= elem gi gis
    test _		= False

qText :: Filter XML XML
qText = aGuard (isTXNode . treeRoot) where
    isTXNode (TXNode _)	= True
    isTXNode _		= False

qEntity :: Filter XML XML
qEntity = aGuard (isENNode . treeRoot) where
    isENNode (ENNode _)	= True
    isENNode _		= False

qSelf :: Filter x x
qSelf = arr id

--
-- Extractions:
--

keepText :: Filter XML XML
keepText = qSubtree >>> (qText |>| qEntity)
-- ALT: arr stringValue >>> mkText

qAttval :: Name -> Filter XML String
qAttval name = arr (attval name) >>> aMaybe

qAttlist :: Filter XML (Name,String)
qAttlist = makeFilter attributes

qNodeName :: Filter XML Name
qNodeName = arr (nodeName . treeRoot) >>> aMaybe

--
-- Shorthand:
--

(./), (.//) :: Filter a XML -> String -> Filter a XML
f ./  gi = f >>> qChildren >>> qElem gi
f .// gi = f >>> qOuter (qElem gi)

qChildElem :: String -> Filter XML XML
qChildElem gi = qFirst (qChildren >>> qElem gi)

--
-- Utilities:
--

xmlFilterMain :: Filter XML XML -> IO ()
xmlFilterMain f =
    getContents >>= mapM_ printXML . runFilter f . parseXML
    >> putChar '\n'

testFilter :: FilePath -> Filter XML XML -> IO ()
testFilter filename f =
    readFile filename >>= mapM_ printXML . runFilter f . parseXML

-- EOF --