{-# 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.TextLexemePlain 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 "")
	-}
	text = 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
{-

-- * Type 'State'
data State = State
 { state_posXML :: XML.Pos
 , state_source :: XML.FileSource
   -- ^ Unfortunately Megaparsec's 'P.statePos'
   -- is not a good fit to encode 'XML.Source'.
 } deriving (Eq,Show)
instance Default State where
	def = State
	 { state_posXML = def
	 , state_source = def
	 }

-- * Type 'Parser'
type Parser = S.StateT State (P.Parsec ErrorRead XMLs)

instance RNC.Sym_Rule Parser where
	-- rule n p = P.dbg s p {-(p P.<?> s)-} where s = Text.unpack n
	rule _n = id
instance RNC.Sym_RNC Parser where
	{-
	none = P.label "none" $ P.eof
	-}
	fail = P.label "fail" $ P.failure Nothing mempty
	any  = P.label "any" $ p_satisfyMaybe $ const $ Just ()
	anyElem p = P.label "anyElem" $ do
		XML.Sourced state_source (n,ts) <- P.token check $ Just expected
		parserElement n (p n) (XML.Sourced state_source ts)
		where
		expected = XML.Tree (XML.notSourced $ XML.NodeElem "*") mempty
		check (XML.Tree cell@(XML.unSourced -> XML.NodeElem e) ts) = Right $ (e,ts) <$ cell
		check t = Left
		 ( Just $ P.Tokens $ pure t
		 , Set.singleton $ P.Tokens $ pure expected )
	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 cell@(XML.unSourced -> XML.NodeElem e) ts) | e == n = Right (ts <$ cell)
		check t = Left
		 ( Just $ P.Tokens $ pure t
		 , Set.singleton $ P.Tokens $ pure expected )
	attribute n p = do
		v <- P.token check $ Just expected
		stateParser p $ Seq.singleton $ Tree0 v
		where
		expected = Tree0 (XML.notSourced $ XML.NodeAttr n "")
		check (XML.Tree0 cell@(XML.unSourced -> XML.NodeAttr k v)) | k == n =
			Right $ XML.NodeText v <$ cell
		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 <$ 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 = Tree0 (XML.notSourced $ XML.NodeComment "")
	-}
	text = do
		P.token check (Just expected)
		 <* setFilePosToNextNode
		where
		expected = 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

parserElement :: XML.Name -> Parser a -> XML.Sourced XMLs -> Parser a
parserElement n p (XML.Sourced state_source ts) = do
	let mayNameOrFigureName
		| n == "aside" = Nothing
		-- NOTE: skip aside.
		| n == "figure"
		-- NOTE: special case renaming the current XML.XmlPos
		-- using the @type attribute to have positions like this:
		--   section1.Quote1
		--   section1.Example1
		--   section1.Quote2
		-- instead of:
		--   section1.figure1
		--   section1.figure2
		--   section1.figure3
		, Just ty <- getFirst $ (`foldMap` ts) $ \case
		 XML.Tree0 (XML.unSourced -> XML.NodeAttr "type" ty) -> First $ Just ty
		 _ -> First Nothing
		= Just $ XML.qName $ ty
		| otherwise = Just n
	case mayNameOrFigureName of
	 Nothing -> do
		st <- S.get
		S.put st{state_source}
		res <- stateParser p ts
		S.put st
		return res
	 Just nameOrFigureName -> do
		st@State{state_posXML} <- S.get
		let incrPrecedingSibling name =
			maybe (Nat1 1) succNat1 $
			Map.lookup name $
			XML.pos_precedingSiblings state_posXML
		S.put State
		 { state_posXML = state_posXML
			 -- NOTE: in children, push current name incremented on ancestors
			 -- and reset preceding siblings.
			 { XML.pos_precedingSiblings = mempty
			 , XML.pos_ancestors = XML.pos_ancestors state_posXML |> (n, incrPrecedingSibling n)
			 , XML.pos_ancestorsWithFigureNames =
				XML.pos_ancestorsWithFigureNames state_posXML |>
				( nameOrFigureName
				, incrPrecedingSibling nameOrFigureName )
			 }
		 , state_source
		 }
		res <- stateParser p ts
		S.put st
		 { state_posXML = state_posXML
			 -- NOTE: after current, increment current name
			 -- and reset ancestors.
			 { XML.pos_precedingSiblings =
				(if n == nameOrFigureName then id
				else Map.insertWith (const succNat1) nameOrFigureName (Nat1 1)) $
				Map.insertWith (const succNat1) n (Nat1 1) $
				XML.pos_precedingSiblings state_posXML
			 }
		 }
		return res

type instance RNC.Perm Parser = P.PermParser XMLs Parser
instance RNC.Sym_Interleaved Parser where
	interleaved = P.makePermParser
	(<$$>) = (P.<$$>)
	(<||>) = (P.<||>)
	(<$?>) = (P.<$?>)
	(<|?>) = (P.<|?>)
	f <$*> a = f P.<$?> ([],P.some a)
	f <|*> a = f P.<|?> ([],P.some a)
{-
instance DTC.Sym_DTC Parser where
	positionXML = S.gets state_posXML
	locationTCT = S.gets state_source
-}




-- ** Type 'ErrorRead'
data ErrorRead
 =   ErrorRead_EndOfInput
 |   ErrorRead_Not_Bool TL.Text
 |   ErrorRead_Not_Int TL.Text
 |   ErrorRead_Not_Nat Int
 |   ErrorRead_Not_Nat1 Int
 |   ErrorRead_Not_Rational TL.Text
 |   ErrorRead_Not_Positive TL.Text
 {-     ErrorRead_Unexpected P.sourcePos XML -}
 deriving (Eq,Ord,Show)
instance P.ShowErrorComponent ErrorRead where
	showErrorComponent = show
-}