{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Read DTC from TCT.
module Textphile.DTC.Read.TCT where
import Control.Applicative (Applicative(..), optional)
import Control.Monad (Monad(..))
import Data.Bool
import Data.Default.Class (Default(..))
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..), all)
import Data.Function (($), (.), const, id)
import Data.Functor ((<$>))
import Data.Int (Int)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (Monoid(..), First(..))
import Data.Ord (Ord(..))
import Data.Ratio ((%))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (ViewL(..), (|>))
import Data.String (String)
import Data.Tuple (fst, snd)
import Prelude (error)
import Text.Blaze.DTC (xmlns_dtc)
import Text.Read (readMaybe, Read(..))
import Text.Show (Show(..))
import qualified Control.Monad.Trans.State as S
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map.Strict as Map
import qualified Data.Ratio as Ratio
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import qualified Data.Text.Lazy as TL
import qualified GHC.Read as Read (expectP)
import qualified Symantic.RNC as RNC
import qualified Symantic.XML as XML
import qualified Text.Megaparsec as P
import qualified Text.Read as Read

import Textphile.TCT hiding (Parser, ErrorRead)
import Textphile.XML (XML, XMLs)
import Textphile.Utils (Nat(..), Nat1(..), succNat1)
import qualified Textphile.DTC.Document as DTC
import qualified Textphile.DTC.Sym as DTC
import qualified Textphile.RNC as RNC
import qualified Textphile.XML as XML
import qualified Textphile.TCT.Cell as TCT

readDTC ::
 DTC.Sym_DTC Parser =>
 XMLs ->
 Either (P.ParseErrorBundle XMLs ErrorRead) DTC.Document
readDTC stateInput = (fst <$>) $ snd $
	P.runParser' (S.runStateT (DTC.document <* P.eof) (def::State)) P.State
	 { P.stateInput
	 , P.stateOffset = 0
	 , P.stateParseErrors = []
	 , 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.
	 }

-- * Type 'State'
data State = State
 { state_posXML :: XML.Pos
 , state_locTCT :: TCT.Location
 } deriving (Eq,Show)
instance Default State where
	def = State
	 { state_posXML = def
	 , state_locTCT = 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
	arg _n = pure ()
instance RNC.Sym_RNC Parser where
	namespace _p _n = pure ()
	element n p = do
		ts <- P.token check (Set.singleton $ P.Tokens $ pure expected)
		p_element n p ts
		where
		expected = XML.Tree (XML.notSourced $ XML.NodeElem n) mempty
		check (XML.Tree (XML.Sourced src (XML.NodeElem e)) ts)
		 | e == n
		 = Just $ XML.Sourced src $ 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
		ts <- P.token check (Set.singleton $ P.Tokens $ pure expected)
		p_XMLs p ts
		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.token (const $ Just ())  Set.empty
	anyElem ns p = P.label "anyElem" $ do
		(n,ts) <- P.token check $ Set.singleton $ P.Tokens $ pure expected
		p_XMLs (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
	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
type instance RNC.Permutation Parser = RNC.Perm Parser
instance RNC.Sym_Permutation Parser where
	runPermutation (RNC.Perm 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 = RNC.Perm Nothing $ pure <$> p
	toPermutationWithDefault v p = RNC.Perm (Just v) $ pure <$> p

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
		  | RNC.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 (RNC.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 (Tree a _ts) =
			showSourced a $ \case
			 XML.NodeAttr n     -> show (remove_XMLNS_DTC n)<>"="
			 XML.NodeCDATA _t   -> "cdata"
			 XML.NodeComment _c -> "comment"
			 XML.NodeElem n     -> "<"<>show (remove_XMLNS_DTC n)<>">"
			 XML.NodePI n _t    -> "processing-instruction"<>show n
			 XML.NodeText _t    -> "text"
		remove_XMLNS_DTC n
		 | XML.qNameSpace n == xmlns_dtc = n{XML.qNameSpace=""}
		 | otherwise = n
		
		showSourced (Sourced path@(FileRange{fileRange_file} :| _) a) f =
			if null fileRange_file
			then f a
			else f a <> foldMap (\p -> "\n in "<>show p) path

-- | @p_XMLs p xs@ returns a parser parsing @xs@ entirely with @p@,
-- updating 'P.stateOffset' and re-raising any exception.
p_XMLs :: Parser a -> XMLs -> Parser a
p_XMLs p stateInput = do
	s <- S.get
	st <- P.getParserState
	let (st', res) = P.runParser' (S.runStateT (p <* P.eof) s) P.State
		 { P.stateInput  = stateInput
		 , P.stateOffset = P.stateOffset st
		 , P.stateParseErrors = []
		 , P.statePosState = P.PosState
			 { P.pstateInput      = stateInput
			 , P.pstateOffset     = P.stateOffset st
			 , P.pstateSourcePos  = P.pstateSourcePos $ P.statePosState st
			 , P.pstateTabWidth   = P.pos1
			 , P.pstateLinePrefix = ""
			 }
		 }
	P.updateParserState (\ps -> ps{P.stateOffset = P.stateOffset st'})
	case res of
	 Right (a, s') -> do
		S.put s'
		return a
	 Left (P.ParseErrorBundle errs _) ->
		case NonEmpty.head errs of
		 P.TrivialError _o us es -> P.failure us es
			{-
			lift $ P.ParsecT $ \ps _cok cerr _eok _eerr ->
				cerr (P.TrivialError o us es) ps
			-}
		 P.FancyError _o es -> P.fancyFailure es

p_element :: XML.QName -> Parser a -> Cell XMLs -> Parser a
p_element n p (Sourced state_locTCT ts) = do
	let mayNameOrFigureName
		| n == "aside" = Nothing
		-- NOTE: skip aside.
		| n == "figure"
		-- NOTE: special case renaming the current XML.Pos
		-- 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
		 Tree (unSourced -> XML.NodeAttr "type") xs
		  | [Tree (Sourced _ (XML.NodeText t)) _] <- toList xs
		  , Just ty <- XML.ncName $ XML.unescapeText t
		  -> First $ Just ty
		 _ -> First Nothing
		= Just $ XML.QName xmlns_dtc ty
		| otherwise = Just n
	case mayNameOrFigureName of
	 Nothing -> do
		st <- S.get
		S.put st{state_locTCT}
		res <- p_XMLs 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_locTCT
		 }
		res <- p_XMLs 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

instance RNC.Sym_RNC_Extra Parser where
	none = RNC.rule "none" $ P.eof
	comment = do
		s <- P.getInput
		case Seq.viewl s of
		 Tree0 (unSourced -> XML.NodeComment c) :< ts -> do
			P.setInput ts
			return c
		 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 (cell0 $ XML.NodeComment "")
	bool = RNC.rule "bool" $ RNC.text >>= \t ->
		case t of
		 "true"  -> return True
		 "false" -> return False
		 _ -> P.fancyFailure $
			Set.singleton $ P.ErrorCustom $ ErrorRead_Not_Bool t
	int = RNC.rule "int" $ RNC.text >>= \t ->
		case readMaybe (TL.unpack t) of
		 Just i -> return i
		 Nothing -> P.fancyFailure $
			Set.singleton $ P.ErrorCustom $ ErrorRead_Not_Int t
	rational = RNC.rule "rational" $ RNC.text >>= \t ->
		case readMaybe (TL.unpack t) of
		 Just (Rational i) | 0 <= i -> return i
		                   | otherwise -> P.fancyFailure $
			Set.singleton $ P.ErrorCustom $ ErrorRead_Not_Positive t
		 Nothing -> P.fancyFailure $
			Set.singleton $ P.ErrorCustom $ ErrorRead_Not_Rational t
	rationalPositive = RNC.rule "rationalPositive" $ RNC.text >>= \t ->
		case readMaybe (TL.unpack t) of
		 Just (Rational i) | 0 <= i -> return i
		                   | otherwise -> P.fancyFailure $
			Set.singleton $ P.ErrorCustom $ ErrorRead_Not_Positive t
		 Nothing -> P.fancyFailure $
			Set.singleton $ P.ErrorCustom $ ErrorRead_Not_Rational t
	nat = RNC.rule "nat" $ RNC.int >>= \i ->
		if i >= 0
		then return $ Nat i
		else P.fancyFailure $ Set.singleton $
			P.ErrorCustom $ ErrorRead_Not_Nat i
	nat1 = RNC.rule "nat1" $ RNC.int >>= \i ->
		if i > 0
		then return $ Nat1 i
		else P.fancyFailure $ Set.singleton $
			P.ErrorCustom $ ErrorRead_Not_Nat1 i
instance DTC.Sym_DTC Parser where
	positionXML = S.gets state_posXML
	locationTCT = S.gets state_locTCT


-- ** 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
 deriving (Eq,Ord,Show)
instance P.ShowErrorComponent ErrorRead where
	showErrorComponent = show

-- ** Type 'Rational'
-- | Wrapper to change the 'Read' instance.
newtype Rational = Rational Ratio.Rational
instance Read Rational where
	readPrec = do
		x <- Read.step readPrec
		Read.expectP (Read.Symbol "/")
		y <- Read.step readPrec
		return $ Rational (x % y)