{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Textphile.TCT.Read.Tree where

import Control.Applicative (Applicative(..), Alternative(..))
import Control.Monad (Monad(..), void)
import Data.Bool
import Data.Char (Char)
import Data.Eq (Eq(..))
import Data.Function (($), (.))
import Data.Functor ((<$>), ($>), (<$))
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.TreeSeq.Strict (Tree(..), Trees, tree0)
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Sequence as Seq
import qualified Data.Text.Lazy as TL
import qualified Symantic.XML as XML
import qualified Text.Megaparsec as P
import qualified Text.Megaparsec.Char as P

import Textphile.TCT.Debug
import Textphile.TCT.Cell
import Textphile.TCT.Elem
import Textphile.TCT.Tree
import Textphile.TCT.Read.Cell
import Textphile.TCT.Read.Elem
import Textphile.TCT.Read.Token

p_CellHeader :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
p_CellHeader row = debugParser "CellHeader" $ do
	P.skipMany $ P.char ' '
	Sourced sp h <- p_Cell $ do
		debugParser "Header" $
			P.choice
			 [ P.try $ P.char '-' >>
				P.char ' ' $> HeaderDash <|>
				P.string "- " $> HeaderDashDash
			 , P.try $ HeaderDot
				 <$> p_Digits
				 <* P.char '.'
				 <* P.lookAhead (P.try $ P.eof <|> void (P.satisfy $ \c -> c=='\n'||c==' '))
			 , P.try $ P.some (P.char '#') <* P.lookAhead (P.try $ P.char ' ') >>= \hs ->
				return $ HeaderSection $ List.length hs
			 , P.try $
				HeaderBrackets
				 <$> P.between (P.char '[') (P.string "]:")
				      (P.takeWhile1P (Just "Reference") isReferenceChar)
				 -- <*  P.lookAhead (P.try $ P.eof <|> void (P.satisfy (=='\n')))
			 , P.try $
				(\f -> HeaderDotSlash $ "./"<>f)
				 <$  P.string "./"
				 <*> P.many (P.satisfy (/='\n'))
			 , do
				name <- P.optional p_ElemName
				wh <- p_HSpaces
				P.choice
				 [ P.try $ HeaderColon name wh
					 <$ P.char ':'
					 <* P.lookAhead (P.try $ P.eof <|> void (P.satisfy $ \c -> c=='\n'||c==' '))
				 , P.char '>' $> HeaderGreat name wh
				 , maybe empty (\n -> P.char '=' $> HeaderEqual n wh) name
				 , P.char '|' $> HeaderBar   name wh
				 ]
			 ]
	let row' = Tree (Sourced sp $ NodeHeader h) mempty : row
	case h of
	 HeaderSection{}  -> p_CellEnd  row'
	 HeaderDash{}     -> p_Row      row'
	 HeaderDashDash{} -> p_CellRaw  row'
	 HeaderDot{}      -> p_Row      row'
	 HeaderColon{}    -> p_Row      row'
	 HeaderBrackets{} -> p_Row      row'
	 HeaderGreat{}    -> p_Row      row'
	 HeaderEqual{}    -> p_CellRaw  row'
	 HeaderBar{}      -> p_CellRaw  row'
	 HeaderDotSlash{} -> p_CellEnd  row'

isReferenceChar :: Char -> Bool
isReferenceChar c =
	c /= '[' &&
	c /= ']' &&
	Char.isPrint c &&
	not (Char.isSpace c)

p_Name :: P.Tokens s ~ TL.Text => Parser e s ElemName
p_Name = XML.NCName <$> p_AlphaNums
	{-
	(\h t -> Text.pack (h:t))
	 <$> (P.satisfy $ \c -> Char.isAlphaNum c || c=='_')
	 <*> P.takeWhile1P (P.satisfy $ \c -> Char.isAlphaNum c || c=='-' || c=='_')
	-}

p_Line :: P.Tokens s ~ TL.Text => Parser e s TL.Text
p_Line = P.takeWhileP (Just "Line") (/='\n')

p_Line1 :: P.Tokens s ~ TL.Text => Parser e s TL.Text
p_Line1 = P.takeWhile1P (Just "Line") (/='\n')

p_CellLower :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
p_CellLower row = debugParser "CellLower" $ do
	indent <- p_HSpaces
	Sourced ssp@(FileRange fp bp ep:|sp) (name, attrs) <-
		p_Cell $ do
			void $ P.char '<'
			(,) <$> p_ElemName <*> p_ElemAttrs
	let treeHere =
		Tree (Sourced ssp $ NodeLower name attrs) .
		Seq.singleton . tree0 . (NodeText <$>)
	let treeElem hasContent nod (Sourced (FileRange _fp _bp ep':|_sp) t) =
		let (o,_) = bs $ PairElem name attrs in
		tree0 $ Sourced (FileRange fp bp ep':|sp) $ nod $ o<>t
		where
		bs | hasContent = pairBordersDouble
		   | otherwise  = pairBordersSingle
	cel <-
		P.try (P.char '>' >> treeElem True NodeText <$> p_CellLinesUntilElemEnd indent name) <|>
		P.try (P.char '\n' >> P.tokens (==) indent >> treeHere <$> p_CellLines indent) <|>
		P.try (P.tokens (==) "/>" >> treeElem False NodeText <$> p_CellLine) <|>
		(P.eof $> treeHere (Sourced (FileRange fp ep ep:|sp) ""))
	return $ cel : row
	where
	p_CellLine :: P.Tokens s ~ TL.Text => Parser e s (Cell TL.Text)
	p_CellLine = p_Cell p_Line
	p_CellLines :: P.Tokens s ~ TL.Text => P.Tokens TL.Text -> Parser e s (Cell TL.Text)
	p_CellLines indent =
		-- TODO: optimize special case indent == "" ?
		p_Cell $
			TL.intercalate "\n"
			 <$> P.sepBy (P.try p_Line)
				 (P.try $ P.char '\n' >> P.tokens (==) indent)
	p_CellLinesUntilElemEnd :: P.Tokens s ~ TL.Text => P.Tokens TL.Text -> ElemName -> Parser e s (Cell TL.Text)
	p_CellLinesUntilElemEnd indent (XML.NCName name) =
		p_Cell $ TL.intercalate "\n" . List.reverse <$> go []
		-- TODO: optimize merging, and maybe case indent == ""
		where
		go :: P.Tokens s ~ TL.Text => [TL.Text] -> Parser e s [TL.Text]
		go ls =
			let end = "</" <> name in
			P.try ((\w l -> w <> end <> l : ls)
			 <$> p_HSpaces
			 <*  P.tokens (==) end
			 <*> p_Line) <|>
			(p_Line >>= \l -> P.try $
				P.char '\n'
				 >> P.tokens (==) indent
				 >> go (l:ls))

p_CellText1 :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
p_CellText1 row = debugParser "CellText" $ do
	P.skipMany $ P.char ' '
	n <- p_Cell $ NodeText <$> p_Line1
	return $ tree0 n : row

p_CellRaw :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
p_CellRaw row = debugParser "CellRaw" $ do
	P.skipMany $ P.char ' '
	n <- p_Cell $ NodeText <$> p_Line
	return $ tree0 n : row

p_CellSpaces1 :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
p_CellSpaces1 row = debugParser "CellSpaces" $ do
	P.skipSome $ P.char ' '
	cell <- p_Cell $ NodeText <$> P.string ""
	return $ tree0 cell : row

p_CellEnd :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
p_CellEnd row = debugParser "CellEnd" $
	P.try (p_CellLower row) <|>
	P.try (p_CellText1 row) <|>
	p_CellSpaces1 row <|>
	return row

p_Row :: P.Tokens s ~ TL.Text => Row -> Parser e s Row
p_Row row = debugParser "Row" $
	P.try (p_CellHeader row) <|>
	p_CellEnd row

p_Rows :: P.Tokens s ~ TL.Text => Rows -> Parser e s Rows
p_Rows rows =
	p_Row [] >>= \row ->
		let rows' = rows `mergeRow` row in
		(P.eof $> rows') <|>
		(P.newline >> {- USELESS: P.eof $> rows' <|>-} p_Rows rows')

p_Trees :: P.Tokens s ~ TL.Text => Parser e s (Trees (Cell Node))
p_Trees = collapseRows <$> p_Rows initRows