{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# 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.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Foldable (null, foldl')
import Data.Function (($), (.), const, id)
import Data.Functor ((<$>), (<$))
import Data.Int (Int)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Proxy (Proxy(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (ViewL(..))
import Data.String (String)
import Data.Text (Text)
import Data.Tuple (snd)
import GHC.Exts (toList)
import Text.Read (readMaybe)
import Text.Show (Show(..))
import qualified Data.List as List
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Text.Megaparsec as P
import qualified Text.Megaparsec.Perm as P

import Language.TCT hiding (Parser)
import Language.TCT.Write.XML (XML,XMLs,XmlLeaf(..))
import Language.DTC.Document (Nat(..), Nat1(..))
import qualified Language.DTC.Document as DTC
import qualified Language.DTC.Sym as DTC
import qualified Language.RNC.Sym as RNC
import qualified Language.TCT.Write.XML as XML

-- * Type 'Parser'
type Parser = P.Parsec Error 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
	any  = P.label "any" $ p_satisfyMaybe $ const $ Just ()
	anyElem p = P.dbg "anyElem" $ P.label "anyElem" $ do
		(n,ts) <- P.token check $ Just expected
		parserXMLs (p n) ts
		where
		expected = TreeN (cell0 "") mempty
		check (TreeN (unCell -> n) ts) = Right (n,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
		parserXMLs p ts
		where
		expected = TreeN (cell0 n) mempty
		check (TreeN (unCell -> 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 $ XML.XmlAttr n "")
		check (TreeN (unCell -> e) ts) | e == n = Right ts
		check (Tree0 (Cell bp ep (XML.XmlAttr k v))) | k == n =
			Right $ Seq.singleton $ Tree0 $ Cell bp ep $ XML.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 $ XML.XmlComment "")
	text = do
		P.token check (Just expected)
		 <* fixPos
		where
		expected = Tree0 (cell0 $ XML.XmlText "")
		check (Tree0 (unCell -> XML.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 (Text.unpack t) of
		 Just i -> return i
		 Nothing -> P.fancyFailure $
			Set.singleton $ P.ErrorCustom $ Error_Not_Int t
	nat = RNC.rule "nat" $ RNC.int >>= \i ->
		if i >= 0
		then return $ Nat i
		else P.fancyFailure $ Set.singleton $
			P.ErrorCustom $ Error_Not_Nat i
	nat1 = RNC.rule "nat1" $ RNC.int >>= \i ->
		if i > 0
		then return $ Nat1 i
		else P.fancyFailure $ Set.singleton $
			P.ErrorCustom $ Error_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

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

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

-- | @parserXMLs pos p xs@ returns a 'Parser' parsing @xs@ with @p@.
parserXMLs ::
 DTC.Sym_DTC Parser =>
 Parser a -> XMLs -> Parser a
parserXMLs p xs = do
	pos <- P.getPosition
	case parseXMLs 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 c =
	P.SourcePos ""
	 (P.mkPos $ lineCell c)
	 (P.mkPos $ columnCell c)

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

-- ** Type 'XMLs'
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 t =
		fromMaybe pos $ sourcePos $
		case t of
		 TreeN c _ -> posCell c
		 Tree0 c   -> posCell c
	positionAtN s pos ts =
		case Seq.viewl ts of
		 t :< _ -> P.positionAt1 s pos t
		 _ -> pos
	advance1 _s _indent pos t =
		-- WARNING: the end of a 'Cell' is not necessarily
		-- the beginning of the next 'Cell'.
		fromMaybe pos $ sourcePos $
		case t of
		 TreeN c _ -> posEndCell c
		 Tree0 c   -> posEndCell c
	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 = \case
		 Tree0 c     -> showCell c showXmlLeaf
		 TreeN c _ts -> showCell c showXmlName
		
		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
		
		showXmlLeaf = \case
		 XmlAttr n _v  -> show n<>"="
		 XmlText _t    -> "text"
		 XmlComment _c -> "comment"
		showXmlName n = "<"<>show n<>">"

-- ** Type 'Error'
data Error
 =   Error_EndOfInput
 |   Error_Not_Int Text
 |   Error_Not_Nat Int
 |   Error_Not_Nat1 Int
 -- |   Error_Unexpected P.sourcePos XML
 deriving (Eq,Ord,Show)
instance P.ShowErrorComponent Error where
	showErrorComponent = show