{-# 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
  , 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.Proc  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 = qName . elName

qname :: String -> QName
qname name = QName name Nothing Nothing

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

-- | Location for some content.
type Path = [String]


addIdx :: Int -> Path -> Path
addIdx i p = show i : p

addElem :: XML.Element -> Path -> Path
addElem e p = elemName e : p

addAttrib :: String -> Path -> Path
addAttrib a p = ('@':a) : p

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

-- | Error with a context.
data ExtractionErr = ExtractionErr { err :: Err, context :: Path }
  deriving Show


-- | Extraction errors.
data Err = ErrExpect
           { expected :: String      -- ^ expected content
           , found    :: XML.Content -- ^ found content
           } -- ^ Some expected content is missing
         | ErrAttr 
           { expected  :: String       -- ^ expected attribute
           , atElement :: XML.Element  -- ^ element with missing attribute
           } -- ^ An expected attribute is missing
         | ErrEnd 
           { found    :: XML.Content
           } -- ^ Expected end of contents
         | ErrNull
           { expected :: String  -- ^ expected content
           } -- ^ Unexpected end of contents
         | ErrMsg String
  deriving Show


instance Error ExtractionErr where
  strMsg msg = ExtractionErr (ErrMsg msg) []


throwError = lift . R.throwError

throwFatal = lift . R.throwFatal

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

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

runElementExtractor :: ElementExtractor a -> XML.Element -> Path -> Result ExtractionErr a
runElementExtractor p elem path = runIdentity $ runResultT $ runReaderT p (path, elem)

makeElementExtractor :: Result ExtractionErr a -> ElementExtractor a
makeElementExtractor (Fatal e) = throwFatal e
makeElementExtractor (Fail e)  = throwError e
makeElementExtractor (Ok a)    = return a


attrib :: String -> ElementExtractor String
attrib name = attribAs name return


attribAs :: String -- ^ name of attribute to extract
         -> (String -> Either Err a)
         -> ElementExtractor a
attribAs name f = do
  (path,x) <- ask
  let path' = addAttrib name path
  case XML.lookupAttr (qname name) (elAttribs x) of
    Nothing -> throwError $ ExtractionErr (ErrAttr name x) path
    Just s  ->
      case f s of
        Left e  -> throwFatal $ ExtractionErr e path'
        Right a -> return a


contents :: ContentsExtractor a -> ElementExtractor a
contents p = do
  (path,x) <- ask
  let r = runContentsExtractor p (elContent x) 1 path
  makeElementExtractor $ fmap fst r


children :: ContentsExtractor a -> ElementExtractor a
children p = do
  (path,x) <- ask
  let r = runContentsExtractor p (map XML.Elem $ XML.elChildren x) 1 path
  makeElementExtractor $ fmap fst 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 p contents i path = 
  runIdentity $ runResultT $ runStateT p (path, i, contents)


first :: String -> (Content -> Path -> Result ExtractionErr a) -> ContentsExtractor a
first expect f = do
  (path,i,xs) <- get
  case xs of
    []     -> throwError $ ExtractionErr (ErrNull expect) path
    (x:xs) -> do
      case f x (addIdx i path) of
        Fatal e -> throwFatal e
        Fail  e -> throwError e
        Ok    a -> do
          put (path,i+1,xs)
          return a


eoc :: ContentsExtractor ()
eoc = do
  (path,_,xs) <- get
  case xs of
    []    -> return ()
    (x:_) -> throwError (ExtractionErr (ErrEnd x) path)


element :: String -> ElementExtractor a -> ContentsExtractor a
element name p = first expect go
  where
    go (Elem x) path
      | elemName x == name = escalate $ runElementExtractor p x (addElem x path)
    go c        path       = Fail (ExtractionErr (ErrExpect expect c) path)

    expect = "element " ++ show name


textAs :: (String -> Either Err a) -> ContentsExtractor a
textAs f = first "text" go 
  where
    go (Text x) path =
      case f (cdData x) of
        Left e  -> Fatal $ ExtractionErr e path
        Right s -> return s
    go c path = Fail $ ExtractionErr (ErrExpect "text" c) path


text = textAs return