{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Read DTC from TCT.
module Language.DTC.Read.TCT where

import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..))
import Data.Bool
import Data.Default.Class (Default(..))
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), (.), const, id)
import Data.Functor ((<$>), (<$))
import Data.Int (Int)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.Monoid (Monoid(..), First(..))
import Data.Ord (Ord(..))
import Data.Proxy (Proxy(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (ViewL(..), (|>))
import Data.String (String)
import Data.Tuple (snd)
import Prelude (Num(..))
import Text.Read (readMaybe)
import Text.Show (Show(..))
import qualified Control.Monad.Trans.State as S
import qualified Data.List as List
import qualified Data.Map.Strict as Map
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.TCT hiding (Parser, ErrorRead)
import Language.XML
import qualified Language.DTC.Document as DTC
import qualified Language.DTC.Sym as DTC
import qualified Language.RNC.Sym as RNC

-- * Type 'State'
type State = DTC.Pos

-- * Type 'Parser'
-- type Parser = P.Parsec ErrorRead XMLs
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
		(n,ts) <- P.token check $ Just expected
		parserXMLs (p n) ts
		where
		expected = Tree (cell0 $ XmlElem "*") mempty
		check (Tree (unCell -> XmlElem e) ts) = Right (e,ts)
		check t = Left
		 ( Just $ P.Tokens $ pure t
		 , Set.singleton $ P.Tokens $ pure expected )
	element n p = do
		ts <- P.token check $ Just expected
		pos <- S.get
		let nameOrFigureName
			| n == "figure"
			-- NOTE: special case renaming the current DTC.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
			 Tree0 (unCell -> XmlAttr "type" ty) -> First $ Just ty
			 _ -> First Nothing
			= xmlLocalName $ ty
			| otherwise = n
		let anc name = maybe 1 (+1) $ Map.lookup name $ DTC.posPrecedingsSiblings pos
		S.put pos
		 { DTC.posAncestors = DTC.posAncestors pos |> (n,anc n)
		 , DTC.posAncestorsWithFigureNames =
			DTC.posAncestorsWithFigureNames pos |>
			(nameOrFigureName,anc nameOrFigureName)
		 , DTC.posPrecedingsSiblings = mempty
		 }
		parserXMLs p ts <* S.put pos
		 { DTC.posPrecedingsSiblings=
			(if n /= nameOrFigureName
			then Map.insertWith (\_new old -> old + 1) nameOrFigureName 1
			else id) $
			Map.insertWith (\_new old -> old + 1) n 1 $
			DTC.posPrecedingsSiblings pos
		 }
		where
		expected = Tree (cell0 $ XmlElem n) mempty
		check (Tree (unCell -> XmlElem e) ts) | e == n = Right ts
		check t = Left
		 ( Just $ P.Tokens $ pure t
		 , Set.singleton $ P.Tokens $ pure expected )
	attribute n p = do
		v <- P.token check $ Just expected
		parserXMLs p v
		where
		expected = Tree0 (cell0 $ XmlAttr n "")
		check (Tree0 (Cell bp ep (XmlAttr k v))) | k == n =
			Right $ Seq.singleton $ Tree0 $ Cell bp ep $ XmlText v
		check t = Left
		 ( Just $ P.Tokens $ pure t
		 , Set.singleton $ P.Tokens $ pure expected )
	comment = do
		s <- P.getInput
		case Seq.viewl s of
		 Tree0 (unCell -> XmlComment c) :< ts -> do
			P.setInput ts
			c <$ fixPos
		 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 $ XmlComment "")
	text = do
		P.token check (Just expected)
		 <* fixPos
		where
		expected = Tree0 (cell0 $ XmlText "")
		check (Tree0 (unCell -> XmlText t)) = Right t
		check t = Left
		 ( Just $ P.Tokens $ pure t
		 , Set.singleton $ P.Tokens $ pure expected )
	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
	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
	(<|>)    = (P.<|>)
	many     = P.many
	some     = P.some
	optional = P.optional
	option   = P.option
	choice   = P.choice
	try      = P.try
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
	position = S.get

readDTC ::
 DTC.Sym_DTC Parser =>
 XMLs ->
 Either (P.ParseError (P.Token XMLs) ErrorRead) DTC.Document
readDTC = parseXMLs def (P.initialPos "") DTC.document

parseXMLs ::
 DTC.Sym_DTC Parser =>
 State ->
 P.SourcePos -> Parser a -> XMLs ->
 Either (P.ParseError (P.Token XMLs) ErrorRead) a
parseXMLs st pos p i =
	snd $
	P.runParser' ((`S.evalStateT` st) $ p <* RNC.none)
	 P.State
		 { P.stateInput = i
		 , P.statePos = pure $
			case Seq.viewl i of
			 Tree c _ :< _ -> sourcePosCell c
			 _ -> pos
		 , P.stateTabWidth = P.pos1
		 , P.stateTokensProcessed = 0
		 }

-- | @parserXMLs st pos p xs@ returns a 'Parser' parsing @xs@ with @p@ from state @st@.
parserXMLs ::
 DTC.Sym_DTC Parser =>
 Parser a -> XMLs -> Parser a
parserXMLs p xs = do
	pos <- P.getPosition
	st <- S.get
	case parseXMLs st pos p xs of
	 Left (P.TrivialError (posErr:|_) un ex) -> do
		P.setPosition posErr
		P.failure un ex
	 Left (P.FancyError (posErr:|_) errs) -> do
		P.setPosition posErr
		P.fancyFailure errs
	 Right a -> a <$ fixPos

-- | Adjust the current 'P.SourcePos'
-- to be the begining of the following-sibling 'XML' node
-- so that on error 'P.toHints' keeps expected 'P.Token's in the list,
-- and thus makes useful error messages.
--
-- This is needed because the end of a 'Cell'
-- is not necessarily the begin of the next 'Cell'.
fixPos :: Parser ()
fixPos = do
	P.State
	 { P.stateInput = inp
	 , P.statePos   = pos :| _
	 } <- P.getParserState
	case Seq.viewl inp of
	 EmptyL -> return ()
	 t :< _ -> P.setPosition $
		P.positionAt1 (Proxy::Proxy XMLs) pos t

sourcePosCell :: Cell a -> P.SourcePos
sourcePosCell (cell_begin -> bp) =
	P.SourcePos ""
	 (P.mkPos $ pos_line bp)
	 (P.mkPos $ pos_column bp)

sourcePos :: Pos -> Maybe P.SourcePos
sourcePos (Pos l c) | l>0 && c>0 = Just $ P.SourcePos "" (P.mkPos l) (P.mkPos c)
sourcePos _ = Nothing

instance P.Stream XMLs where
	type Token  XMLs = XML
	type Tokens XMLs = XMLs
	take1_ s =
		case Seq.viewl s of
		 Tree0 (unCell -> XmlComment{}) :< ts -> P.take1_ ts
		 t:<ts  -> Just (t,ts)
		 EmptyL -> Nothing
	positionAt1 _s pos =
		fromMaybe pos . sourcePos .
		cell_begin . unTree
	positionAtN s pos ts =
		case Seq.viewl ts of
		 t :< _ -> P.positionAt1 s pos t
		 _ -> pos
	advance1 _s _indent pos =
		-- WARNING: the end of a 'Cell' is not necessarily
		-- the beginning of the next 'Cell'.
		fromMaybe pos . sourcePos .
		cell_end . unTree
	advanceN s = foldl' . P.advance1 s
	takeN_ n s
	 | n <= 0    = Just (mempty, s)
	 | null s    = Nothing
	 | otherwise = Just (Seq.splitAt n s) -- FIXME: handle XmlComment
	tokensToChunk _s = Seq.fromList
	chunkToTokens _s = toList
	chunkLength _s   = Seq.length
	takeWhile_       = Seq.spanl
instance P.ShowToken XML where
	showTokens toks = List.intercalate ", " $ toList $ showTree <$> toks
		where
		showTree :: XML -> String
		showTree (Tree a _ts) =
			showCell a $ \case
			 XmlElem n     -> "<"<>show n<>">"
			 XmlAttr n _v  -> show n<>"="
			 XmlText _t    -> "text"
			 XmlComment _c -> "comment"
		
		showCell (Cell (Pos 0 0) (Pos 0 0) a) f = f a
		showCell (Cell bp ep a) f = f a<>" at "<>show bp<>"-"<>show ep

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