{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
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.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String)
import Data.Text (Text)
import Prelude (undefined, Int, Num(..), toInteger)
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Sequence as Seq
import qualified Data.Text as Text
import qualified Text.Megaparsec as P

import Language.TCT.Tree
import Language.TCT.Token
import Language.TCT.Read.Elem

p_Position :: Parser e s Pos
p_Position = (<$> P.getPosition) $ \p ->
	Pos
	 (intOfPos $ P.sourceLine p)
	 (intOfPos $ P.sourceColumn p)
intOfPos :: P.Pos -> Int
intOfPos = fromInteger . toInteger . P.unPos

p_Line :: Parser e s Line
p_Line = intOfPos . P.sourceLine <$> P.getPosition

p_Column :: Parser e s Column
p_Column = intOfPos . P.sourceColumn <$> P.getPosition

p_CellKey :: Row -> Parser e s Row
p_CellKey row = pdbg "CellKey" $ do
	P.skipMany $ P.char ' '
	pos <- p_Position
	key <- pdbg "Key" $
		P.choice $
		 [ P.try $ P.char '-' >>
			P.char ' ' $> KeyDash <|>
			P.string "- " $> KeyDashDash
		 , P.try $ KeyDot . Text.pack
			 <$> P.some (P.satisfy Char.isDigit)
			 <* P.char '.'
			 <* P.lookAhead (P.try $ P.eof <|> void (P.satisfy $ \c -> c=='\n'||c==' '))
		 -- TODO: KeyComment
		 , P.try $ P.some (P.char '#') <* P.lookAhead (P.try $ P.char ' ') >>= \hs ->
			return $ KeySection $ List.length hs
		 , do
			name <- p_Name
			wh <- Text.pack <$> P.many (P.char ' ')
			P.choice
			 [ P.try $ KeyColon name wh
				 <$ P.char ':'
				 <* P.lookAhead (P.try $ P.eof <|> void (P.satisfy $ \c -> c=='\n'||c==' '))
			 , P.char '>' $> KeyGreat name wh
			 , P.char '=' $> KeyEqual name wh
			 , P.char '|' $> KeyBar   name wh
			 -- TODO: KeyAt
			 ]
		 ]
	posEnd <- p_Position
	let row' = TreeN (Cell pos posEnd key) mempty : row
	case key of
	 KeySection{}  -> p_CellEnd  row'
	 KeyDash{}     -> p_Row      row'
	 KeyDashDash{} -> p_CellText row'
	 KeyDot{}      -> p_Row      row'
	 KeyColon{}    -> p_Row      row'
	 KeyGreat{}    -> p_Row      row'
	 KeyEqual{}    -> p_CellEnd  row'
	 KeyBar{}      -> p_CellEnd  row'
	 KeyLower{}    -> undefined -- NOTE: handled in 'p_CellLower'

p_Name :: Parser e s Name
p_Name =
	(\h t -> Text.pack (h:t))
	 <$> (P.satisfy $ \c ->
		Char.isAlphaNum c || c=='_')
	 <*> many (P.satisfy $ \c ->
		Char.isAlphaNum c || c=='-' || c=='_')

p_CellLower :: Row -> Parser e s Row
p_CellLower row = pdbg "CellLower" $ do
	P.skipMany $ P.char ' '
	pos <- p_Position
	void $ P.char '<'
	name <- p_Name
	attrs <- p_attrs
	posClose <- p_Position
	let treeHere =
		TreeN (Cell pos posClose $ KeyLower name attrs) .
		Seq.singleton . Tree0
	let treeElem toks (Cell _ p c) =
		let (o,_) = pairBorders (PairElem name attrs) toks in
		Tree0 $ Cell pos p (o<>c)
	let indent = List.replicate (columnPos pos - 1) ' '
	tree <-
		P.try (P.char '>' >> treeElem (tokens [TokenPlain ""]) <$> p_CellLinesUntilElemEnd indent name) <|>
		P.try (P.char '\n' >> P.string indent >> treeHere <$> p_CellLines indent) <|>
		P.try (P.string "/>" >> treeElem mempty <$> p_CellLine) <|>
		(P.eof $> treeHere (Cell posClose posClose ""))
	return (tree:row)
	where
	p_attrs = P.many $ P.try $
		(,)
		 <$> (Text.pack <$> P.some (P.char ' '))
		 <*> p_Attr
	p_line :: Parser e s Text
	p_line = Text.pack <$> P.many (P.satisfy (/='\n'))
	p_CellLine :: Parser e s (Cell Text)
	p_CellLine = do
		pos     <- p_Position
		content <- p_line
		posEnd  <- p_Position
		return $ Cell pos posEnd content
	p_CellLines :: String -> Parser e s (Cell Text)
	p_CellLines indent = do
		pos <- p_Position
		content <-
			Text.intercalate "\n"
			 <$> P.sepBy (P.try p_line) (P.try $ P.char '\n' >> P.string indent)
		posEnd <- p_Position
		return $ Cell pos posEnd content
	p_CellLinesUntilElemEnd :: String -> Text -> Parser e s (Cell Text)
	p_CellLinesUntilElemEnd indent name = do
		pos     <- p_Position
		content <- Text.intercalate "\n" . List.reverse <$> go []
		posEnd  <- p_Position
		return $ Cell pos posEnd content
		where
		go :: [Text] -> Parser e s [Text]
		go ls =
			P.try ((\w p l -> Text.pack w <> Text.pack p <> l : ls)
			 <$> P.many (P.char ' ')
			 <*> P.string ("</"<>Text.unpack name)
			 <*> p_line) <|>
			(p_line >>= \l -> P.try $
				P.char '\n' >>
				P.string indent >>
				go (l:ls))

p_CellText :: Row -> Parser e s Row
p_CellText row = pdbg "CellText" $ do
	P.skipMany $ P.char ' '
	pos <- p_Position
	line <- Text.pack <$> P.some (P.satisfy (/='\n'))
	posEnd <- p_Position
	return $ Tree0 (Cell pos posEnd line) : row

p_CellSpaces :: Row -> Parser e s Row
p_CellSpaces row = pdbg "CellSpaces" $ do
	P.skipSome $ P.char ' '
	pos <- p_Position
	return $ Tree0 (Cell pos pos "") : row

p_CellEnd :: Row -> Parser e s Row
p_CellEnd row = pdbg "Row" $
	P.try (p_CellLower row) <|>
	P.try (p_CellText row) <|>
	p_CellSpaces row <|>
	return row

p_Row :: Row -> Parser e s Row
p_Row row = pdbg "Row" $
	P.try (p_CellKey row) <|>
	p_CellEnd row

p_Rows :: Rows -> Parser e s Rows
p_Rows rows =
	p_Row [] >>= \row ->
		let rows' = appendRow rows (List.reverse row) in
		(P.eof $> rows') <|>
		(P.newline >> p_Rows rows')

p_Trees :: Parser e s (Trees (Cell Key) (Cell Text))
p_Trees = unRoot . collapseRows <$> p_Rows [root]
	where
	root = TreeN (cell0 KeyDashDash) mempty
	unRoot (TreeN (unCell -> KeyDashDash) roots) = roots
	unRoot _ = undefined