{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Symantic.RNC.Validate where

import Control.Applicative (Applicative(..))
import Data.Bool
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..), all)
import Data.Function (($), const, id)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import qualified Data.Char as Char
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import qualified Data.Text.Lazy as TL
import qualified Text.Megaparsec as P
import qualified Text.Megaparsec.Perm as P

import           Language.Symantic.XML (XMLs)
import qualified Language.Symantic.XML as XML
import qualified Language.Symantic.RNC.Sym as RNC

validateXML :: Ord e => P.Parsec e XMLs a -> XMLs -> Either (P.ParseError (P.Token XMLs) e) a
validateXML p = XML.runParser p (P.initialPos "":|[])

type instance RNC.Perm (P.ParsecT e XMLs m) = P.PermParser XMLs (P.ParsecT e XMLs m)
instance Ord e => RNC.Sym_Interleaved (P.ParsecT e XMLs m) where
	interleaved = P.makePermParser
	(<$$>) = (P.<$$>)
	(<||>) = (P.<||>)
	(<$?>) = (P.<$?>)
	(<|?>) = (P.<|?>)
	f <$*> a = f P.<$?> ([],P.some a)
	f <|*> a = f P.<|?> ([],P.some a)
instance Ord e => RNC.Sym_Rule (P.ParsecT e XMLs m) where
	-- rule n p = P.dbg s p {-(p P.<?> s)-} where s = Text.unpack n
	rule _n = id
	arg _n = pure ()

-- | Like 'P.satisfy' but with a predicate returning 'Maybe' instead of 'Bool'.
p_satisfyMaybe :: P.MonadParsec e s m => (P.Token s -> Maybe a) -> m a
p_satisfyMaybe f = check `P.token` Nothing
	where
	check c =
		case f c of
		 Just a  -> Right a
		 Nothing -> Left (Just $ P.Tokens $ c:|[], Set.empty)

instance Ord e => RNC.Sym_RNC (P.Parsec e XMLs) where
	{-
	none = P.label "none" $ P.eof
	-}
	namespace _p _n = pure ()
	element n p = do
		ts <- P.token check $ Just expected
		parserElement n p ts
		where
		expected = XML.Tree (XML.notSourced $ XML.NodeElem n) mempty
		check (XML.Tree (XML.unSourced -> XML.NodeElem e) ts)
		 | e == n
		 = Right $ removePI $ removeXMLNS $ removeSpaces ts
			where
			removePI xs =
				(`Seq.filter` xs) $ \case
					 XML.Tree (XML.unSourced -> XML.NodePI{}) _ts -> False
					 _ -> True
			removeSpaces xs =
				if (`all` xs) $ \case
				 XML.Tree (XML.unSourced -> XML.NodeText txt) _ts ->
					all (\case
					 XML.EscapedPlain t -> TL.all Char.isSpace t
					 _ -> False) txt
				 _ -> True
				then (`Seq.filter` xs) $ \case
					 XML.Tree (XML.unSourced -> XML.NodeText{}) _ts -> False
					 _ -> True
				else xs
			removeXMLNS xs =
				let (attrs,rest) = (`Seq.spanl` xs) $ \case
					 XML.Tree (XML.unSourced -> XML.NodeAttr{}) _ts -> True
					 _ -> False in
				let attrs' = (`Seq.filter` attrs) $ \case
					 XML.Tree (XML.unSourced -> XML.NodeAttr a) _ts ->
						case a of
						 XML.QName "" "xmlns" -> False
						 XML.QName ns _l -> ns /= XML.xmlns_xmlns
					 _ -> True in
				attrs' <> rest
		check t = Left
		 ( Just $ P.Tokens $ pure t
		 , Set.singleton $ P.Tokens $ pure expected )
	attribute n p = do
		v <- P.token check $ Just expected
		XML.parser p v
		where
		expected = XML.Tree0 (XML.notSourced $ XML.NodeAttr n)
		check (XML.Tree (XML.unSourced -> XML.NodeAttr k)
		      v@(toList -> [XML.Tree0 (XML.unSourced -> XML.NodeText _v)])) | k == n =
			Right v
		check t = Left
		 ( Just $ P.Tokens $ pure t
		 , Set.singleton $ P.Tokens $ pure expected )
	any  = P.label "any" $ p_satisfyMaybe $ const $ Just ()
	anyElem ns p = P.label "anyElem" $ do
		(n,ts) <- P.token check $ Just expected
		parserElement n (p $ XML.qNameLocal n) ts
		where
		expected = XML.Tree (XML.notSourced $ XML.NodeElem $ XML.QName ns $ XML.NCName "*") mempty
		check (XML.Tree (XML.unSourced -> XML.NodeElem e) ts)
		 | XML.qNameSpace e == ns
		 = Right $ (e,ts)
		check t = Left
		 ( Just $ P.Tokens $ pure t
		 , Set.singleton $ P.Tokens $ pure expected )
	{-
	comment = do
		s <- P.getInput
		case Seq.viewl s of
		 XML.Tree0 (XML.unSourced -> XML.NodeComment c) :< ts -> do
			P.setInput ts
			c <$ XML.setFilePosToNextNode
		 t :< _ts -> P.failure (Just $ P.Tokens $ pure t) ex
		 EmptyL -> P.failure Nothing ex
		where
		ex = Set.singleton $ P.Tokens $ pure expected
		expected = XML.Tree0 (XML.notSourced $ XML.NodeComment "")
	-}
	escapedText = do
		P.token check (Just expected)
		 <* XML.setFilePosToNextNode
		where
		expected = XML.Tree0 (XML.notSourced $ XML.NodeText [])
		check (XML.Tree0 (XML.unSourced -> XML.NodeText t)) = Right t
		check t = Left
		 ( Just $ P.Tokens $ pure t
		 , Set.singleton $ P.Tokens $ pure expected )
	optional = P.optional
	option   = P.option
	choice   = P.choice
	try      = P.try
	fail     = P.label "fail" $ P.failure Nothing mempty

parserElement :: Ord e => XML.QName -> P.Parsec e XMLs a -> XMLs -> P.Parsec e XMLs a
parserElement _n = XML.parser