module Fadno.Xml.XParse
(
XParse(..),runXParse,xfail,require,xattr,xtext,xchild,xread,xel
, name,xsName
, readXml
) where
import qualified Text.XML.Light as X
import qualified Text.XML.Light.Cursor as C
import Control.Exception
import Control.Monad.State.Strict hiding (sequence)
import Control.Monad.Except hiding (sequence)
import Data.Either
import Control.Applicative
import Prelude hiding (sequence)
import Control.Lens
import Text.Read (readMaybe)
type XErrors = [([C.Tag],String)]
newtype XParse a = XParse { unXParse :: StateT C.Cursor (Except XErrors) a }
deriving (Functor,Applicative,Monad,MonadState C.Cursor,MonadError XErrors,Alternative)
runXParse :: X.Element -> XParse a -> Either XErrors a
runXParse e act = runExcept (evalStateT (unXParse act) (C.fromElement e))
lcurrent :: Lens' C.Cursor X.Content
lcurrent f s = fmap (\a -> s { C.current = a}) (f (C.current s))
_Elem :: Prism' X.Content X.Element
_Elem = prism X.Elem $ \c -> case c of X.Elem e -> Right e; _ -> Left c
xfail :: String -> XParse a
xfail msg = do
ts <- map (view _2) . C.parents <$> get
throwError [(ts,msg)]
require :: String -> Maybe a -> XParse a
require msg = maybe (xfail $ "Required: " ++ msg) return
xattr :: X.QName -> XParse String
xattr n = xel >>= require ("attribute " ++ show n) . X.findAttr n
xel :: XParse X.Element
xel = firstOf _Elem <$> use lcurrent >>= require "element"
xtext :: XParse String
xtext = X.strContent <$> xel
xchild :: X.QName -> XParse a -> XParse a
xchild n act = do
fc <- C.firstChild <$> get >>= require "at least one child"
let firstEl :: C.Cursor -> XParse C.Cursor
firstEl c = case firstOf (lcurrent._Elem) c of
Just e -> do
when (X.elName e /= n) (xfail $ "Element not found: " ++ show n)
return c
Nothing -> do
c' <- C.right c & require "at least one element child"
firstEl c'
e <- firstEl fc
put e
r <- catchError (Right <$> act) (return . Left)
case r of
Right a -> do
p <- C.removeGoUp <$> get >>= require "parent"
put p
return a
Left err -> do
p <- C.parent <$> get >>= require "parent"
put p
throwError err
xread :: Read a => String -> String -> XParse a
xread msg s = require (msg ++ ": " ++ s) $ readMaybe s
xsName :: String -> X.QName
xsName n = X.QName n (Just "http://www.w3.org/2001/XMLSchema") (Just "xs")
name :: String -> X.QName
name n = X.QName n Nothing Nothing
readXml :: FilePath -> IO X.Element
readXml f = maybe (throwIO $ userError "parse failed") return =<< X.parseXMLDoc <$> readFile f