{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Hdoc.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.List.NonEmpty (NonEmpty(..))
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.TreeSeq.Strict (Tree(..), Trees, tree0)
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 Hdoc.TCT.Debug
import Hdoc.TCT.Cell
import Hdoc.TCT.Tree
import Hdoc.TCT.Read.Cell
import Hdoc.TCT.Read.Elem
import Hdoc.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 ' '
	Cell 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.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
				 ]
			 ]
	let row' = Tree (Cell 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'

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
	Cell ssp@(Span fp bp ep:|sp) (name,attrs) <-
		p_Cell $ do
			void $ P.char '<'
			(,) <$> p_Name <*> p_ElemAttrs
	let treeHere =
		Tree (Cell ssp $ NodeLower name attrs) .
		Seq.singleton . tree0 . (NodeText <$>)
	let treeElem hasContent nod (Cell (Span _fp _bp ep':|_sp) t) =
		let (o,_) = bs $ PairElem name attrs in
		tree0 $ Cell (Span 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 (Cell (Span 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 -> 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 :: 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