{-# 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 (Line,Column)
p_Position = (<$> P.getPosition) $ \p ->
	( 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.string "- " $> KeyDash
		 -- TODO: KeyNum
		 -- TODO: KeyComment
		 , P.try $ P.some (P.char '#') <* P.lookAhead (P.try $ P.char ' ') >>= \hs ->
			return $ KeySection $ List.length hs
		 , do
			name <-
				Text.pack
				 <$> many (P.satisfy $ \c ->
					Char.isAlphaNum c || c=='-' || c=='_')
			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'
	 KeyColon{}   -> p_Row     row'
	 KeyGreat{}   -> p_Row     row'
	 KeyEqual{}   -> p_CellEnd row'
	 KeyBar{}     -> p_CellEnd row'
	 KeyLower{}   -> undefined -- NOTE: handled in 'p_CellLower'

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

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 (Cell (0,0) (0,0) KeyDash) mempty
	unRoot (TreeN (unCell -> KeyDash) roots) = roots
	unRoot _ = undefined