{-# LANGUAGE NoMonomorphismRestriction #-}

module Text.XML.Light.Extractors.Internal
  ( Path
  , Err(..)
  , ExtractionErr(..)

  -- * Element extraction
  , ElementExtractor
  , runElementExtractor
  , attrib
  , attribAs
  , children
  , contents

  -- * Contents extraction
  , ContentsExtractor
  , runContentsExtractor
  , element
  , text
  , textAs
  , anyContent
  , eoc
  )
where

import Control.Monad.Identity
import Control.Monad.Trans.Reader
import Control.Monad.Trans.State

import           Text.XML.Light.Types as XML
import qualified Text.XML.Light       as XML

import           Text.XML.Light.Extractors.Internal.Result hiding (throwError, throwFatal)
import qualified Text.XML.Light.Extractors.Internal.Result as R

--------------------------------------------------------------------------------

elemName :: Element -> String
elemName :: Element -> String
elemName = QName -> String
XML.qName (QName -> String) -> (Element -> QName) -> Element -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> QName
XML.elName

--------------------------------------------------------------------------------

-- | Location for some content.
--
-- For now it is a reversed list of content indices (starting at 1)
-- and element names. This may change to something less \"stringly
-- typed\".
type Path = [String]


pushIdx :: Int -> Path -> Path
pushIdx :: Int -> Path -> Path
pushIdx Int
i Path
p = Int -> String
forall a. Show a => a -> String
show Int
i String -> Path -> Path
forall a. a -> [a] -> [a]
: Path
p

pushElem :: XML.Element -> Path -> Path
pushElem :: Element -> Path -> Path
pushElem Element
e Path
p = Element -> String
elemName Element
e String -> Path -> Path
forall a. a -> [a] -> [a]
: Path
p

pushAttrib :: String -> Path -> Path
pushAttrib :: String -> Path -> Path
pushAttrib String
a Path
p = (Char
'@'Char -> String -> String
forall a. a -> [a] -> [a]
:String
a) String -> Path -> Path
forall a. a -> [a] -> [a]
: Path
p

--------------------------------------------------------------------------------

-- | Error with a context.
data ExtractionErr = ExtractionErr { ExtractionErr -> Err
err :: Err, ExtractionErr -> Path
context :: Path }
  deriving Int -> ExtractionErr -> String -> String
[ExtractionErr] -> String -> String
ExtractionErr -> String
(Int -> ExtractionErr -> String -> String)
-> (ExtractionErr -> String)
-> ([ExtractionErr] -> String -> String)
-> Show ExtractionErr
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ExtractionErr] -> String -> String
$cshowList :: [ExtractionErr] -> String -> String
show :: ExtractionErr -> String
$cshow :: ExtractionErr -> String
showsPrec :: Int -> ExtractionErr -> String -> String
$cshowsPrec :: Int -> ExtractionErr -> String -> String
Show


-- | Extraction errors.
data Err = ErrExpectContent
           { Err -> String
expectedContent :: String
           , Err -> Content
foundContent    :: XML.Content
           } -- ^ Some expected content is missing
         | ErrExpectAttrib
           { Err -> String
expectedAttrib :: String       -- ^ name of expected attribute
           , Err -> Element
atElement      :: XML.Element  -- ^ element with missing attribute
           } -- ^ An expected attribute is missing
         | ErrAttribValue
           { Err -> String
expectedValue  :: String       -- ^ description of expected value
           , Err -> String
foundValue     :: String       -- ^ the value found
           , atElement      :: XML.Element  -- ^ element with bad attribute
           } -- ^ An attribute value was bad
         | ErrEnd
           { foundContent   :: XML.Content
           } -- ^ Expected end of contents
         | ErrNull
           { expectedContent :: String
           } -- ^ Unexpected end of contents
         | ErrMsg String
  deriving Int -> Err -> String -> String
[Err] -> String -> String
Err -> String
(Int -> Err -> String -> String)
-> (Err -> String) -> ([Err] -> String -> String) -> Show Err
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Err] -> String -> String
$cshowList :: [Err] -> String -> String
show :: Err -> String
$cshow :: Err -> String
showsPrec :: Int -> Err -> String -> String
$cshowsPrec :: Int -> Err -> String -> String
Show


instance Error ExtractionErr where
  strMsg :: String -> ExtractionErr
strMsg String
msg = Err -> Path -> ExtractionErr
ExtractionErr (String -> Err
ErrMsg String
msg) []


throwError :: e -> t (ResultT e m) a
throwError = ResultT e m a -> t (ResultT e m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ResultT e m a -> t (ResultT e m) a)
-> (e -> ResultT e m a) -> e -> t (ResultT e m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> ResultT e m a
forall e (m :: * -> *) a. (Error e, Monad m) => e -> ResultT e m a
R.throwError

throwFatal :: e -> t (ResultT e m) a
throwFatal = ResultT e m a -> t (ResultT e m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ResultT e m a -> t (ResultT e m) a)
-> (e -> ResultT e m a) -> e -> t (ResultT e m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> ResultT e m a
forall e (m :: * -> *) a. (Error e, Monad m) => e -> ResultT e m a
R.throwFatal

--------------------------------------------------------------------------------

type ElementExtractor a = ReaderT (Path, XML.Element) (ResultT ExtractionErr Identity) a

runElementExtractor :: ElementExtractor a -> XML.Element -> Path -> Result ExtractionErr a
runElementExtractor :: ElementExtractor a -> Element -> Path -> Result ExtractionErr a
runElementExtractor ElementExtractor a
p Element
elem Path
path = Identity (Result ExtractionErr a) -> Result ExtractionErr a
forall a. Identity a -> a
runIdentity (Identity (Result ExtractionErr a) -> Result ExtractionErr a)
-> Identity (Result ExtractionErr a) -> Result ExtractionErr a
forall a b. (a -> b) -> a -> b
$ ResultT ExtractionErr Identity a
-> Identity (Result ExtractionErr a)
forall e (m :: * -> *) a. ResultT e m a -> m (Result e a)
runResultT (ResultT ExtractionErr Identity a
 -> Identity (Result ExtractionErr a))
-> ResultT ExtractionErr Identity a
-> Identity (Result ExtractionErr a)
forall a b. (a -> b) -> a -> b
$ ElementExtractor a
-> (Path, Element) -> ResultT ExtractionErr Identity a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ElementExtractor a
p (Path
path, Element
elem)

makeElementExtractor :: Result ExtractionErr a -> ElementExtractor a
makeElementExtractor :: Result ExtractionErr a -> ElementExtractor a
makeElementExtractor (Fatal ExtractionErr
e) = ExtractionErr -> ElementExtractor a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
(MonadTrans t, Monad m, Error e) =>
e -> t (ResultT e m) a
throwFatal ExtractionErr
e
makeElementExtractor (Fail ExtractionErr
e)  = ExtractionErr -> ElementExtractor a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
(MonadTrans t, Monad m, Error e) =>
e -> t (ResultT e m) a
throwError ExtractionErr
e
makeElementExtractor (Ok a
a)    = a -> ElementExtractor a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a


attrib :: String -> ElementExtractor String
attrib :: String -> ElementExtractor String
attrib String
name = String
-> (String -> Either String String) -> ElementExtractor String
forall a.
String -> (String -> Either String a) -> ElementExtractor a
attribAs String
name String -> Either String String
forall (m :: * -> *) a. Monad m => a -> m a
return


attribAs :: String -- ^ name of attribute to extract
         -> (String -> Either String a) -- ^ function returning given string to some value or an error message
         -> ElementExtractor a
attribAs :: String -> (String -> Either String a) -> ElementExtractor a
attribAs String
name String -> Either String a
f = do
  (Path
path,Element
x) <- ReaderT
  (Path, Element) (ResultT ExtractionErr Identity) (Path, Element)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  let path' :: Path
path' = String -> Path -> Path
pushAttrib String
name Path
path
  case QName -> [Attr] -> Maybe String
XML.lookupAttr (String -> QName
XML.unqual String
name) (Element -> [Attr]
XML.elAttribs Element
x) of
    Maybe String
Nothing -> ExtractionErr -> ElementExtractor a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
(MonadTrans t, Monad m, Error e) =>
e -> t (ResultT e m) a
throwError (ExtractionErr -> ElementExtractor a)
-> ExtractionErr -> ElementExtractor a
forall a b. (a -> b) -> a -> b
$ Err -> Path -> ExtractionErr
ExtractionErr (String -> Element -> Err
ErrExpectAttrib String
name Element
x) Path
path
    Just String
s  ->
      case String -> Either String a
f String
s of
        Left String
e  -> ExtractionErr -> ElementExtractor a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
(MonadTrans t, Monad m, Error e) =>
e -> t (ResultT e m) a
throwFatal (ExtractionErr -> ElementExtractor a)
-> ExtractionErr -> ElementExtractor a
forall a b. (a -> b) -> a -> b
$ Err -> Path -> ExtractionErr
ExtractionErr (String -> String -> Element -> Err
ErrAttribValue String
e String
s Element
x) Path
path'
        Right a
a -> a -> ElementExtractor a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a


contents :: ContentsExtractor a -> ElementExtractor a
contents :: ContentsExtractor a -> ElementExtractor a
contents ContentsExtractor a
p = do
  (Path
path,Element
x) <- ReaderT
  (Path, Element) (ResultT ExtractionErr Identity) (Path, Element)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  let r :: Result ExtractionErr (a, Ctx)
r = ContentsExtractor a
-> [Content] -> Int -> Path -> Result ExtractionErr (a, Ctx)
forall a.
ContentsExtractor a
-> [Content] -> Int -> Path -> Result ExtractionErr (a, Ctx)
runContentsExtractor ContentsExtractor a
p (Element -> [Content]
XML.elContent Element
x) Int
1 Path
path
  Result ExtractionErr a -> ElementExtractor a
forall a. Result ExtractionErr a -> ElementExtractor a
makeElementExtractor (Result ExtractionErr a -> ElementExtractor a)
-> Result ExtractionErr a -> ElementExtractor a
forall a b. (a -> b) -> a -> b
$ ((a, Ctx) -> a)
-> Result ExtractionErr (a, Ctx) -> Result ExtractionErr a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, Ctx) -> a
forall a b. (a, b) -> a
fst Result ExtractionErr (a, Ctx)
r


children :: ContentsExtractor a -> ElementExtractor a
children :: ContentsExtractor a -> ElementExtractor a
children ContentsExtractor a
p = do
  (Path
path,Element
x) <- ReaderT
  (Path, Element) (ResultT ExtractionErr Identity) (Path, Element)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  let r :: Result ExtractionErr (a, Ctx)
r = ContentsExtractor a
-> [Content] -> Int -> Path -> Result ExtractionErr (a, Ctx)
forall a.
ContentsExtractor a
-> [Content] -> Int -> Path -> Result ExtractionErr (a, Ctx)
runContentsExtractor ContentsExtractor a
p ((Element -> Content) -> [Element] -> [Content]
forall a b. (a -> b) -> [a] -> [b]
map Element -> Content
XML.Elem ([Element] -> [Content]) -> [Element] -> [Content]
forall a b. (a -> b) -> a -> b
$ Element -> [Element]
XML.elChildren Element
x) Int
1 Path
path
  Result ExtractionErr a -> ElementExtractor a
forall a. Result ExtractionErr a -> ElementExtractor a
makeElementExtractor (Result ExtractionErr a -> ElementExtractor a)
-> Result ExtractionErr a -> ElementExtractor a
forall a b. (a -> b) -> a -> b
$ ((a, Ctx) -> a)
-> Result ExtractionErr (a, Ctx) -> Result ExtractionErr a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, Ctx) -> a
forall a b. (a, b) -> a
fst Result ExtractionErr (a, Ctx)
r


-- -- | Lift a string function to an element extractor.
-- liftToElement :: (String -> Either Err a) -> String -> ElementExtractor a
-- liftToElement f s = do
--   (path,_) <- ask
--   case f s of
--     Left e   -> throwError (ExtractionErr e path)
--     Right a  -> return a

--------------------------------------------------------------------------------

type Ctx = (Path, Int, [XML.Content])

type ContentsExtractor a = StateT Ctx (ResultT ExtractionErr Identity) a

runContentsExtractor :: ContentsExtractor a -> [Content] -> Int -> Path -> Result ExtractionErr (a, Ctx)
runContentsExtractor :: ContentsExtractor a
-> [Content] -> Int -> Path -> Result ExtractionErr (a, Ctx)
runContentsExtractor ContentsExtractor a
p [Content]
contents Int
i Path
path =
  Identity (Result ExtractionErr (a, Ctx))
-> Result ExtractionErr (a, Ctx)
forall a. Identity a -> a
runIdentity (Identity (Result ExtractionErr (a, Ctx))
 -> Result ExtractionErr (a, Ctx))
-> Identity (Result ExtractionErr (a, Ctx))
-> Result ExtractionErr (a, Ctx)
forall a b. (a -> b) -> a -> b
$ ResultT ExtractionErr Identity (a, Ctx)
-> Identity (Result ExtractionErr (a, Ctx))
forall e (m :: * -> *) a. ResultT e m a -> m (Result e a)
runResultT (ResultT ExtractionErr Identity (a, Ctx)
 -> Identity (Result ExtractionErr (a, Ctx)))
-> ResultT ExtractionErr Identity (a, Ctx)
-> Identity (Result ExtractionErr (a, Ctx))
forall a b. (a -> b) -> a -> b
$ ContentsExtractor a
-> Ctx -> ResultT ExtractionErr Identity (a, Ctx)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT ContentsExtractor a
p (Path
path, Int
i, [Content]
contents)


first :: String -> (Content -> Path -> Result ExtractionErr a) -> ContentsExtractor a
first :: String
-> (Content -> Path -> Result ExtractionErr a)
-> ContentsExtractor a
first String
expect Content -> Path -> Result ExtractionErr a
f = do
  (Path
path,Int
i,[Content]
xs) <- StateT Ctx (ResultT ExtractionErr Identity) Ctx
forall (m :: * -> *) s. Monad m => StateT s m s
get
  case [Content]
xs of
    []     -> ExtractionErr -> ContentsExtractor a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
(MonadTrans t, Monad m, Error e) =>
e -> t (ResultT e m) a
throwError (ExtractionErr -> ContentsExtractor a)
-> ExtractionErr -> ContentsExtractor a
forall a b. (a -> b) -> a -> b
$ Err -> Path -> ExtractionErr
ExtractionErr (String -> Err
ErrNull String
expect) Path
path
    (Content
x:[Content]
xs) -> do
      case Content -> Path -> Result ExtractionErr a
f Content
x (Int -> Path -> Path
pushIdx Int
i Path
path) of
        Fatal ExtractionErr
e -> ExtractionErr -> ContentsExtractor a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
(MonadTrans t, Monad m, Error e) =>
e -> t (ResultT e m) a
throwFatal ExtractionErr
e
        Fail  ExtractionErr
e -> ExtractionErr -> ContentsExtractor a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
(MonadTrans t, Monad m, Error e) =>
e -> t (ResultT e m) a
throwError ExtractionErr
e
        Ok    a
a -> do
          Ctx -> StateT Ctx (ResultT ExtractionErr Identity) ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (Path
path,Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1,[Content]
xs)
          a -> ContentsExtractor a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a


element :: String -> ElementExtractor a -> ContentsExtractor a
element :: String -> ElementExtractor a -> ContentsExtractor a
element String
name ElementExtractor a
p = String
-> (Content -> Path -> Result ExtractionErr a)
-> ContentsExtractor a
forall a.
String
-> (Content -> Path -> Result ExtractionErr a)
-> ContentsExtractor a
first String
expect Content -> Path -> Result ExtractionErr a
go
  where
    go :: Content -> Path -> Result ExtractionErr a
go (Elem Element
x) Path
path
      | Element -> String
elemName Element
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
name = Result ExtractionErr a -> Result ExtractionErr a
forall e a. Result e a -> Result e a
escalate (Result ExtractionErr a -> Result ExtractionErr a)
-> Result ExtractionErr a -> Result ExtractionErr a
forall a b. (a -> b) -> a -> b
$ ElementExtractor a -> Element -> Path -> Result ExtractionErr a
forall a.
ElementExtractor a -> Element -> Path -> Result ExtractionErr a
runElementExtractor ElementExtractor a
p Element
x (Element -> Path -> Path
pushElem Element
x Path
path)
    go Content
c        Path
path       = ExtractionErr -> Result ExtractionErr a
forall e a. e -> Result e a
Fail (Err -> Path -> ExtractionErr
ExtractionErr (String -> Content -> Err
ErrExpectContent String
expect Content
c) Path
path)

    expect :: String
expect = String
"element " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
name


textAs :: (String -> Either Err a) -> ContentsExtractor a
textAs :: (String -> Either Err a) -> ContentsExtractor a
textAs String -> Either Err a
f = String
-> (Content -> Path -> Result ExtractionErr a)
-> ContentsExtractor a
forall a.
String
-> (Content -> Path -> Result ExtractionErr a)
-> ContentsExtractor a
first String
"text" Content -> Path -> Result ExtractionErr a
go
  where
    go :: Content -> Path -> Result ExtractionErr a
go (Text CData
x) Path
path =
      case String -> Either Err a
f (CData -> String
cdData CData
x) of
        Left Err
e  -> ExtractionErr -> Result ExtractionErr a
forall e a. e -> Result e a
Fatal (ExtractionErr -> Result ExtractionErr a)
-> ExtractionErr -> Result ExtractionErr a
forall a b. (a -> b) -> a -> b
$ Err -> Path -> ExtractionErr
ExtractionErr Err
e Path
path
        Right a
s -> a -> Result ExtractionErr a
forall (m :: * -> *) a. Monad m => a -> m a
return a
s
    go Content
c Path
path = ExtractionErr -> Result ExtractionErr a
forall e a. e -> Result e a
Fail (ExtractionErr -> Result ExtractionErr a)
-> ExtractionErr -> Result ExtractionErr a
forall a b. (a -> b) -> a -> b
$ Err -> Path -> ExtractionErr
ExtractionErr (String -> Content -> Err
ErrExpectContent String
"text" Content
c) Path
path


text :: ContentsExtractor String
text :: ContentsExtractor String
text = (String -> Either Err String) -> ContentsExtractor String
forall a. (String -> Either Err a) -> ContentsExtractor a
textAs String -> Either Err String
forall (m :: * -> *) a. Monad m => a -> m a
return


anyContent :: ContentsExtractor Content
anyContent :: ContentsExtractor Content
anyContent = String
-> (Content -> Path -> Result ExtractionErr Content)
-> ContentsExtractor Content
forall a.
String
-> (Content -> Path -> Result ExtractionErr a)
-> ContentsExtractor a
first String
"something" (Result ExtractionErr Content
-> Path -> Result ExtractionErr Content
forall a b. a -> b -> a
const (Result ExtractionErr Content
 -> Path -> Result ExtractionErr Content)
-> (Content -> Result ExtractionErr Content)
-> Content
-> Path
-> Result ExtractionErr Content
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Content -> Result ExtractionErr Content
forall (m :: * -> *) a. Monad m => a -> m a
return)


eoc :: ContentsExtractor ()
eoc :: StateT Ctx (ResultT ExtractionErr Identity) ()
eoc = do
  (Path
path,Int
_,[Content]
xs) <- StateT Ctx (ResultT ExtractionErr Identity) Ctx
forall (m :: * -> *) s. Monad m => StateT s m s
get
  case [Content]
xs of
    []    -> () -> StateT Ctx (ResultT ExtractionErr Identity) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    (Content
x:[Content]
_) -> ExtractionErr -> StateT Ctx (ResultT ExtractionErr Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
(MonadTrans t, Monad m, Error e) =>
e -> t (ResultT e m) a
throwError (Err -> Path -> ExtractionErr
ExtractionErr (Content -> Err
ErrEnd Content
x) Path
path)