{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Symantic.XML.Parser where

import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..))
import Data.Bool
import Data.Either (Either(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), (.))
import Data.Functor ((<$>))
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (ViewL(..))
import Data.String (String)
import Prelude (error)
import Text.Show (Show(..))
import qualified Data.List as List
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Sequence as Seq
import qualified Text.Megaparsec as P

import Language.Symantic.XML.Document (XML, XMLs)
import qualified Language.Symantic.XML.Document as XML

-- | Whether the given 'XML.Node' must be ignored by the parser.
isIgnoredNode :: XML.Node -> Bool
isIgnoredNode = \case
 XML.NodeComment{} -> True
 XML.NodePI{}      -> True
 XML.NodeCDATA{}   -> True
 _ -> False

instance P.Stream XMLs where
	type Token  XMLs = XML
	type Tokens XMLs = XMLs
	take1_ s =
		case Seq.viewl s of
		 EmptyL -> Nothing
		 t@(XML.Tree XML.Sourced{XML.unSourced=n} _) :< ts
		  | isIgnoredNode n -> P.take1_ ts
		  | otherwise       -> Just (t, ts)
	takeN_ n s | n <= 0    = Just (mempty, s)
	           | null s    = Nothing
	           | otherwise =
		let (ns,rs) = Seq.splitAt n s in
		let (ko,ok) = Seq.partition (isIgnoredNode . XML.unSourced . XML.unTree) ns in
		case P.takeN_ (Seq.length ko) rs of
		 Nothing -> Just (ok, rs)
		 Just (ns',rs') -> Just (ok<>ns', rs')
	tokensToChunk _s  = Seq.fromList
	chunkToTokens _s  = toList
	chunkLength _s    = Seq.length
	takeWhile_        = Seq.spanl
	-- | NOTE: unimplemented: useless since each 'XML.Node' is annotated with its 'FileSource'.
	reachOffset       = error "[BUG] P.Stream XMLs: reachOffset is not helpful, please use annotated source locations"
	-- | NOTE: useless since each 'XML.Node' is annotated with its 'FileSource'.
	reachOffsetNoLine = error "[BUG] P.Stream XMLs: reachOffsetNoLine is not helpful, please use annotated source locations"
	showTokens _s toks = List.intercalate ", " $ toList $ showTree <$> toks
		where
		showTree :: XML -> String
		showTree (XML.Tree a _ts) =
			showCell a $ \case
			 XML.NodeElem n     -> "element "<>show n<>""
			 XML.NodeAttr n     -> "attribute "<>show n<>""
			 XML.NodeText _t    -> "text"
			 XML.NodeComment _c -> "comment"
			 XML.NodePI n _t    -> "processing-instruction "<>show n<>""
			 XML.NodeCDATA _t   -> "cdata"
		
		showCell (XML.Sourced path@(XML.FileRange{XML.fileRange_file} NonEmpty.:| _) a) f =
			if null fileRange_file
			then f a
			else f a <> foldMap (\p -> "\n in "<>show p) path

-- | @subParser p xs@ returns a parser parsing @xs@ entirely with @p@,
-- updating 'P.stateOffset' and re-raising any exception.
subParser :: Ord err => P.Parsec err XMLs a -> XMLs -> P.Parsec err XMLs a
subParser p xs = do
	st <- P.getParserState
	let (st', res) = P.runParser' (p <* P.eof) st
		 { P.stateInput = xs
		 , P.stateOffset = P.stateOffset st
		 }
	P.updateParserState (\s -> s{P.stateOffset = P.stateOffset st'})
	case res of
	 Right a -> return a
	 Left (P.ParseErrorBundle errs _) ->
		case NonEmpty.head errs of
		 P.TrivialError _o us es -> P.failure us es
		 P.FancyError _o es -> P.fancyFailure es