{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- | Combinators over XML.
module Fadno.Xml.XParse

    (
     XParse(..),runXParse,xfail,require,xattr,xtext,xchild,xread,xel
    -- * QNames
    , name,xsName
    -- * Utility
    , readXml

    ) where

import qualified Text.XML.Light as X
import qualified Text.XML.Light.Cursor as C

import Control.Exception
import Control.Monad
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)


-- | Monoid errors with path.
type XErrors = [([C.Tag],String)]

-- | Parsing monad.
newtype XParse a = XParse { forall a. XParse a -> StateT Cursor (Except XErrors) a
unXParse :: StateT C.Cursor (Except XErrors) a }
    deriving ((forall a b. (a -> b) -> XParse a -> XParse b)
-> (forall a b. a -> XParse b -> XParse a) -> Functor XParse
forall a b. a -> XParse b -> XParse a
forall a b. (a -> b) -> XParse a -> XParse b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> XParse a -> XParse b
fmap :: forall a b. (a -> b) -> XParse a -> XParse b
$c<$ :: forall a b. a -> XParse b -> XParse a
<$ :: forall a b. a -> XParse b -> XParse a
Functor,Functor XParse
Functor XParse =>
(forall a. a -> XParse a)
-> (forall a b. XParse (a -> b) -> XParse a -> XParse b)
-> (forall a b c.
    (a -> b -> c) -> XParse a -> XParse b -> XParse c)
-> (forall a b. XParse a -> XParse b -> XParse b)
-> (forall a b. XParse a -> XParse b -> XParse a)
-> Applicative XParse
forall a. a -> XParse a
forall a b. XParse a -> XParse b -> XParse a
forall a b. XParse a -> XParse b -> XParse b
forall a b. XParse (a -> b) -> XParse a -> XParse b
forall a b c. (a -> b -> c) -> XParse a -> XParse b -> XParse c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> XParse a
pure :: forall a. a -> XParse a
$c<*> :: forall a b. XParse (a -> b) -> XParse a -> XParse b
<*> :: forall a b. XParse (a -> b) -> XParse a -> XParse b
$cliftA2 :: forall a b c. (a -> b -> c) -> XParse a -> XParse b -> XParse c
liftA2 :: forall a b c. (a -> b -> c) -> XParse a -> XParse b -> XParse c
$c*> :: forall a b. XParse a -> XParse b -> XParse b
*> :: forall a b. XParse a -> XParse b -> XParse b
$c<* :: forall a b. XParse a -> XParse b -> XParse a
<* :: forall a b. XParse a -> XParse b -> XParse a
Applicative,Applicative XParse
Applicative XParse =>
(forall a b. XParse a -> (a -> XParse b) -> XParse b)
-> (forall a b. XParse a -> XParse b -> XParse b)
-> (forall a. a -> XParse a)
-> Monad XParse
forall a. a -> XParse a
forall a b. XParse a -> XParse b -> XParse b
forall a b. XParse a -> (a -> XParse b) -> XParse b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. XParse a -> (a -> XParse b) -> XParse b
>>= :: forall a b. XParse a -> (a -> XParse b) -> XParse b
$c>> :: forall a b. XParse a -> XParse b -> XParse b
>> :: forall a b. XParse a -> XParse b -> XParse b
$creturn :: forall a. a -> XParse a
return :: forall a. a -> XParse a
Monad,MonadState C.Cursor,MonadError XErrors,Applicative XParse
Applicative XParse =>
(forall a. XParse a)
-> (forall a. XParse a -> XParse a -> XParse a)
-> (forall a. XParse a -> XParse [a])
-> (forall a. XParse a -> XParse [a])
-> Alternative XParse
forall a. XParse a
forall a. XParse a -> XParse [a]
forall a. XParse a -> XParse a -> XParse a
forall (f :: * -> *).
Applicative f =>
(forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
$cempty :: forall a. XParse a
empty :: forall a. XParse a
$c<|> :: forall a. XParse a -> XParse a -> XParse a
<|> :: forall a. XParse a -> XParse a -> XParse a
$csome :: forall a. XParse a -> XParse [a]
some :: forall a. XParse a -> XParse [a]
$cmany :: forall a. XParse a -> XParse [a]
many :: forall a. XParse a -> XParse [a]
Alternative)


-- | Run monad.
runXParse :: X.Element -> XParse a -> Either XErrors a
runXParse :: forall a. Element -> XParse a -> Either XErrors a
runXParse Element
e XParse a
act = Except XErrors a -> Either XErrors a
forall e a. Except e a -> Either e a
runExcept (StateT Cursor (Except XErrors) a -> Cursor -> Except XErrors a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (XParse a -> StateT Cursor (Except XErrors) a
forall a. XParse a -> StateT Cursor (Except XErrors) a
unXParse XParse a
act) (Element -> Cursor
C.fromElement Element
e))

-- LENSES

lcurrent :: Lens' C.Cursor X.Content
lcurrent :: Lens' Cursor Content
lcurrent Content -> f Content
f Cursor
s = (Content -> Cursor) -> f Content -> f Cursor
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Content
a -> Cursor
s { C.current = a}) (Content -> f Content
f (Cursor -> Content
C.current Cursor
s))

_Elem :: Prism' X.Content X.Element
_Elem :: Prism' Content Element
_Elem = (Element -> Content)
-> (Content -> Either Content Element) -> Prism' Content Element
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism Element -> Content
X.Elem ((Content -> Either Content Element) -> Prism' Content Element)
-> (Content -> Either Content Element) -> Prism' Content Element
forall a b. (a -> b) -> a -> b
$ \Content
c -> case Content
c of X.Elem Element
e -> Element -> Either Content Element
forall a b. b -> Either a b
Right Element
e; Content
_ -> Content -> Either Content Element
forall a b. a -> Either a b
Left Content
c

-- | Parse failure.
xfail :: String -> XParse a
xfail :: forall a. String -> XParse a
xfail String
msg = do
  [Tag]
ts <- (([Content], Tag, [Content]) -> Tag)
-> [([Content], Tag, [Content])] -> [Tag]
forall a b. (a -> b) -> [a] -> [b]
map (Getting Tag ([Content], Tag, [Content]) Tag
-> ([Content], Tag, [Content]) -> Tag
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Tag ([Content], Tag, [Content]) Tag
forall s t a b. Field2 s t a b => Lens s t a b
Lens
  ([Content], Tag, [Content]) ([Content], Tag, [Content]) Tag Tag
_2) ([([Content], Tag, [Content])] -> [Tag])
-> (Cursor -> [([Content], Tag, [Content])]) -> Cursor -> [Tag]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cursor -> [([Content], Tag, [Content])]
C.parents (Cursor -> [Tag]) -> XParse Cursor -> XParse [Tag]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XParse Cursor
forall s (m :: * -> *). MonadState s m => m s
get
  XErrors -> XParse a
forall a. XErrors -> XParse a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError [([Tag]
ts,String
msg)]

-- | Require 'Just' a thing.
require :: String -> Maybe a -> XParse a
require :: forall a. String -> Maybe a -> XParse a
require String
msg = XParse a -> (a -> XParse a) -> Maybe a -> XParse a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> XParse a
forall a. String -> XParse a
xfail (String -> XParse a) -> String -> XParse a
forall a b. (a -> b) -> a -> b
$ String
"Required: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg) a -> XParse a
forall a. a -> XParse a
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Operate on attribute value/
xattr :: X.QName -> XParse String
xattr :: QName -> XParse String
xattr QName
n = XParse Element
xel XParse Element -> (Element -> XParse String) -> XParse String
forall a b. XParse a -> (a -> XParse b) -> XParse b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe String -> XParse String
forall a. String -> Maybe a -> XParse a
require (String
"attribute " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
forall a. Show a => a -> String
show QName
n) (Maybe String -> XParse String)
-> (Element -> Maybe String) -> Element -> XParse String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Element -> Maybe String
X.findAttr QName
n

-- | Operate on an element.
xel :: XParse X.Element
xel :: XParse Element
xel = Getting (Leftmost Element) Content Element
-> Content -> Maybe Element
forall a s. Getting (Leftmost a) s a -> s -> Maybe a
firstOf Getting (Leftmost Element) Content Element
Prism' Content Element
_Elem (Content -> Maybe Element)
-> XParse Content -> XParse (Maybe Element)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting Content Cursor Content -> XParse Content
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Content Cursor Content
Lens' Cursor Content
lcurrent XParse (Maybe Element)
-> (Maybe Element -> XParse Element) -> XParse Element
forall a b. XParse a -> (a -> XParse b) -> XParse b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe Element -> XParse Element
forall a. String -> Maybe a -> XParse a
require String
"element"

-- | Operate on text.
xtext :: XParse String
xtext :: XParse String
xtext = Element -> String
X.strContent (Element -> String) -> XParse Element -> XParse String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XParse Element
xel

-- | Consume a child element.
xchild :: X.QName -> XParse a -> XParse a
xchild :: forall a. QName -> XParse a -> XParse a
xchild QName
n XParse a
act = do
  Cursor
fc <- Cursor -> Maybe Cursor
C.firstChild (Cursor -> Maybe Cursor) -> XParse Cursor -> XParse (Maybe Cursor)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XParse Cursor
forall s (m :: * -> *). MonadState s m => m s
get XParse (Maybe Cursor)
-> (Maybe Cursor -> XParse Cursor) -> XParse Cursor
forall a b. XParse a -> (a -> XParse b) -> XParse b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe Cursor -> XParse Cursor
forall a. String -> Maybe a -> XParse a
require String
"at least one child"
  let firstEl :: C.Cursor -> XParse C.Cursor
      firstEl :: Cursor -> XParse Cursor
firstEl Cursor
c = case Getting (Leftmost Element) Cursor Element
-> Cursor -> Maybe Element
forall a s. Getting (Leftmost a) s a -> s -> Maybe a
firstOf ((Content -> Const (Leftmost Element) Content)
-> Cursor -> Const (Leftmost Element) Cursor
Lens' Cursor Content
lcurrent((Content -> Const (Leftmost Element) Content)
 -> Cursor -> Const (Leftmost Element) Cursor)
-> Getting (Leftmost Element) Content Element
-> Getting (Leftmost Element) Cursor Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Getting (Leftmost Element) Content Element
Prism' Content Element
_Elem) Cursor
c of
                    Just Element
e -> do
                      Bool -> XParse () -> XParse ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Element -> QName
X.elName Element
e QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
/= QName
n) (String -> XParse ()
forall a. String -> XParse a
xfail (String -> XParse ()) -> String -> XParse ()
forall a b. (a -> b) -> a -> b
$ String
"Element not found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
forall a. Show a => a -> String
show QName
n)
                      Cursor -> XParse Cursor
forall a. a -> XParse a
forall (m :: * -> *) a. Monad m => a -> m a
return Cursor
c
                    Maybe Element
Nothing -> do
                      Cursor
c' <- Cursor -> Maybe Cursor
C.right Cursor
c Maybe Cursor -> (Maybe Cursor -> XParse Cursor) -> XParse Cursor
forall a b. a -> (a -> b) -> b
& String -> Maybe Cursor -> XParse Cursor
forall a. String -> Maybe a -> XParse a
require String
"at least one element child"
                      Cursor -> XParse Cursor
firstEl Cursor
c'
  Cursor
e <- Cursor -> XParse Cursor
firstEl Cursor
fc
  Cursor -> XParse ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Cursor
e
  Either XErrors a
r <- XParse (Either XErrors a)
-> (XErrors -> XParse (Either XErrors a))
-> XParse (Either XErrors a)
forall a. XParse a -> (XErrors -> XParse a) -> XParse a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (a -> Either XErrors a
forall a b. b -> Either a b
Right (a -> Either XErrors a) -> XParse a -> XParse (Either XErrors a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XParse a
act) (Either XErrors a -> XParse (Either XErrors a)
forall a. a -> XParse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XErrors a -> XParse (Either XErrors a))
-> (XErrors -> Either XErrors a)
-> XErrors
-> XParse (Either XErrors a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XErrors -> Either XErrors a
forall a b. a -> Either a b
Left)
  case Either XErrors a
r of
    Right a
a -> do
           Cursor
p <- Cursor -> Maybe Cursor
C.removeGoUp (Cursor -> Maybe Cursor) -> XParse Cursor -> XParse (Maybe Cursor)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XParse Cursor
forall s (m :: * -> *). MonadState s m => m s
get XParse (Maybe Cursor)
-> (Maybe Cursor -> XParse Cursor) -> XParse Cursor
forall a b. XParse a -> (a -> XParse b) -> XParse b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe Cursor -> XParse Cursor
forall a. String -> Maybe a -> XParse a
require String
"parent"
           Cursor -> XParse ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Cursor
p
           a -> XParse a
forall a. a -> XParse a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
    Left XErrors
err -> do
           Cursor
p <- Cursor -> Maybe Cursor
C.parent (Cursor -> Maybe Cursor) -> XParse Cursor -> XParse (Maybe Cursor)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XParse Cursor
forall s (m :: * -> *). MonadState s m => m s
get XParse (Maybe Cursor)
-> (Maybe Cursor -> XParse Cursor) -> XParse Cursor
forall a b. XParse a -> (a -> XParse b) -> XParse b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe Cursor -> XParse Cursor
forall a. String -> Maybe a -> XParse a
require String
"parent"
           Cursor -> XParse ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Cursor
p
           XErrors -> XParse a
forall a. XErrors -> XParse a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XErrors
err

-- | Parse with `read`.
xread :: Read a => String -> String -> XParse a
xread :: forall a. Read a => String -> String -> XParse a
xread String
msg String
s = String -> Maybe a -> XParse a
forall a. String -> Maybe a -> XParse a
require (String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s) (Maybe a -> XParse a) -> Maybe a -> XParse a
forall a b. (a -> b) -> a -> b
$ String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe String
s




-- | XSD name.
xsName :: String -> X.QName
xsName :: String -> QName
xsName String
n = String -> Maybe String -> Maybe String -> QName
X.QName String
n (String -> Maybe String
forall a. a -> Maybe a
Just String
"http://www.w3.org/2001/XMLSchema") (String -> Maybe String
forall a. a -> Maybe a
Just String
"xs")

-- | Local name.
name :: String -> X.QName
name :: String -> QName
name String
n = String -> Maybe String -> Maybe String -> QName
X.QName String
n Maybe String
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing

-- | Convenience to read in top element from file.
readXml :: FilePath -> IO X.Element
readXml :: String -> IO Element
readXml String
f = IO Element
-> (Element -> IO Element) -> Maybe Element -> IO Element
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IOError -> IO Element
forall e a. Exception e => e -> IO a
throwIO (IOError -> IO Element) -> IOError -> IO Element
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"parse failed") Element -> IO Element
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Element -> IO Element) -> IO (Maybe Element) -> IO Element
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Maybe Element
forall s. XmlSource s => s -> Maybe Element
X.parseXMLDoc (String -> Maybe Element) -> IO String -> IO (Maybe Element)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile String
f