module Text.XML.PolySoup.Parser
(
P (..)
, evalP
, first
, every
, every'
, pop
, peek
, spy
, many_
) where
import Control.Applicative
import qualified Control.Arrow as Arr
import Data.Maybe (catMaybes)
import Text.XML.PolySoup.Predicate
newtype P a b = P { runP :: [a] -> Maybe (b, [a]) }
instance Functor (P a) where
fmap f (P p) = P $ fmap (fmap $ Arr.first f) p
instance Applicative (P a) where
pure x = P $ Just . (x,)
P p <*> P q = P $ \t0 -> do
(f, t1) <- p t0
(x, t2) <- q t1
return (f x, t2)
instance Alternative (P a) where
empty = P $ \_ -> Nothing
P p <|> P q = P $ \t -> p t <|> q t
instance Monad (P a) where
return = pure
P p >>= f = P $ \t0 -> do
(x, t1) <- p t0
runP (f x) t1
evalP :: P a b -> [a] -> Maybe b
evalP p = fmap fst . runP p
first :: Q a b -> P a b
first (Q p) = P $ go [] where
go acc (t:ts) = case p t of
Just v -> Just (v, reverse acc ++ ts)
Nothing -> go (t:acc) ts
go _ [] = Nothing
every :: Q a b -> P a [b]
every (Q p) =
P $ prep . foldl upd ([], [])
where
prep (x, y) = Just (reverse x, reverse y)
upd (vs, acc) t = case p t of
Just v -> (v:vs, acc)
Nothing -> (vs, t:acc)
every' :: Q a b -> P a [b]
every' (Q p) =
let prep xs = Just (xs, [])
in P $ prep . catMaybes . map p
pop :: Q a b -> P a b
pop (Q p) = P $ \tts -> case tts of
(t:ts) -> (,ts) <$> p t
[] -> Nothing
peek :: Q a b -> P a b
peek (Q p) = P $ \tts -> case tts of
(t:_) -> (,tts) <$> p t
[] -> Nothing
spy :: Q a b -> P a b
spy (Q p) = P $ \tts ->
let go (t:ts) = case p t of
Just v -> Just (v, tts)
Nothing -> go ts
go [] = Nothing
in go tts
many_ :: Alternative f => f a -> f ()
many_ v = many_v
where
many_v = some_v <|> pure ()
some_v = v *> many_v