{-# 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(..), Alternative(..), optional)
import Control.Monad (Monad(..))
import Data.Bool
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..), all)
import Data.Function (($), const, id)
import Data.Functor (Functor(..), (<$>))
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.Tuple (snd)
import Prelude (error)
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 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 src) a -> XMLs src ->
 Either (P.ParseErrorBundle (XMLs src) e) a
validateXML p stateInput =
	snd $
	P.runParser' p P.State
	 { P.stateInput
	 , P.stateOffset = 0
	 , P.statePosState = error "[BUG] validateXML: getSourcePos is not helpful here, please use annotated source locations"
	  -- NOTE: reporting the node number is less helpful
		-- than the source text line and number where the node is;
		-- P.statePosState is only used by P.getSourcePos.
	 }

-- | 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 = (`P.token` Set.empty)

instance (Ord err, Ord src, XML.NoSource src) => RNC.Sym_RNC (P.Parsec err (XMLs src)) where
	{-
	none = P.label "none" $ P.eof
	-}
	namespace _p _n = pure ()
	element n p = do
		ts <- P.token check $ Set.singleton $ P.Tokens $ pure expected
		XML.subParser p ts
		where
		expected = XML.Tree (XML.notSourced $ XML.NodeElem n) mempty
		check (XML.Tree (XML.unSourced -> XML.NodeElem e) ts)
		 | e == n
		 = Just $ 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 (XML.EscapedText et)) _ts ->
					all (\case
					 XML.EscapedPlain t -> TL.all Char.isSpace t
					 _ -> False) et
				 _ -> 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 = Nothing
	attribute n p = do
		v <- P.token check $ Set.singleton $ P.Tokens $ pure expected
		XML.subParser 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 =
			Just v
		check _t = Nothing
	any  = P.label "any" $ p_satisfyMaybe $ const $ Just ()
	anyElem ns p = P.label "anyElem" $ do
		(n,ts) <- P.token check $ Set.singleton $ P.Tokens $ pure expected
		XML.subParser (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
		 = Just $ (e,ts)
		check _t = Nothing
	{-
	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 $ Set.singleton $ P.Tokens $ pure expected
		where
		expected = XML.Tree0 (XML.notSourced $ XML.NodeText $ XML.EscapedText mempty)
		check (XML.Tree0 (XML.unSourced -> XML.NodeText t)) = Just t
		check _t = Nothing
	optional = P.optional
	option   = P.option
	choice   = P.choice
	try      = P.try
	fail     = P.label "fail" $ P.failure Nothing mempty

instance (Ord err, Ord src) => RNC.Sym_Permutation (P.ParsecT err (XMLs src) m) where
	runPermutation (P value parser) = optional parser >>= f
		where
		-- NOTE: copy Control.Applicative.Permutations.runPermutation
		-- to replace the commented empty below so that P.TrivialError
		-- has the unexpected token.
		f  Nothing = maybe {-empty-}(P.token (const Nothing) Set.empty) pure value
		f (Just p) = RNC.runPermutation p
	toPermutation p = P Nothing $ pure <$> p
	toPermutationWithDefault v p = P (Just v) $ pure <$> p

-- | Unprivatized 'Control.Applicative.Permutations.Permutation' to fix 'runPermutation'.
-- so that the 'P.TrivialError' has an unexpected token
-- which is an 'XML.Node' containing a 'XML.FileSource' useful when reporting errors.
data Permutation m a = P (Maybe a) (m (Permutation m a))
type instance RNC.Permutation (P.ParsecT err (XMLs src) m) = Permutation (P.ParsecT err (XMLs src) m)
instance Functor m => Functor (Permutation m) where
	fmap f (P v p) = P (f <$> v) (fmap f <$> p)
instance Alternative m => Applicative (Permutation m) where
	pure value = P (Just value) empty
	lhs@(P f v) <*> rhs@(P g w) = P (f <*> g) (lhsAlt <|> rhsAlt)
		where
		lhsAlt = (<*> rhs) <$> v
		rhsAlt = (lhs <*>) <$> w

instance (Ord err, Ord src) => RNC.Sym_Rule (P.ParsecT err (XMLs src) m) where
	-- rule n p = P.dbg s p {-(p P.<?> s)-} where s = Text.unpack n
	rule _n = id
	arg _n = pure ()