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

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

import Language.TCT.Debug
import Language.TCT.Cell
import Language.TCT.Tree
import Language.TCT.Read.Cell
import Language.TCT.Read.Elem
import Language.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 ' '
	pos <- p_Position
	header <- 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.string "[") (P.string "]") p_Name
			 <*  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_Name
			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
			 , P.char '=' $> HeaderEqual name wh
			 , P.char '|' $> HeaderBar   name wh
			 ]
		 ]
	posEnd <- p_Position
	let row' = Tree (Cell pos posEnd $ NodeHeader header) mempty : row
	case header 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'
	 -- HeaderLower{}    -> undefined -- NOTE: handled in 'p_CellLower'
	 -- TODO: move to a NodeLower
	 -- HeaderPara       -> undefined -- NOTE: only introduced later in 'appendRow'

p_Name :: P.Tokens s ~ TL.Text => Parser e s Name
p_Name = 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
	pos      <- p_Position
	void     $  P.char '<'
	name     <- p_Name
	attrs    <- p_ElemAttrs
	posClose <- p_Position
	let treeHere =
		Tree (Cell pos posClose $ NodeLower name attrs) .
		Seq.singleton . Tree0 . (NodeText <$>)
	let treeElem hasContent nod (Cell _ p t) =
		let (o,_) = bs $ PairElem name attrs in
		Tree0 $ Cell pos p $ 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 (Cell posClose posClose ""))
	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 -> Name -> Parser e s (Cell TL.Text)
	p_CellLinesUntilElemEnd indent 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 :: Row -> Parser e s Row
p_CellSpaces1 row = debugParser "CellSpaces" $ do
	P.skipSome $ P.char ' '
	pos <- p_Position
	return $ Tree0 (Cell pos pos $ NodeText "") : 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 >> {-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