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

import Control.Applicative (Applicative(..), Alternative(..))
import Control.Monad (Monad(..))
import Data.Bool
import Data.Eq (Eq(..))
import Data.Function (($), (.))
import Data.Functor ((<$>), ($>))
import Data.Monoid (Monoid(..))
import Data.Char (Char)
import Data.String (String)
import Data.Text (Text)
import Prelude (undefined, Int, Num(..), toInteger)
-- import Text.Megaparsec.Text
import Text.Show (Show(..))
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Text.Megaparsec as P

import Language.TCT.Tree

pdbg :: ( Show a
        , P.ErrorComponent e
        , P.Stream s
        , P.Token s ~ Char
        , P.ShowToken (P.Token s)
        , P.Stream s
        ) => String -> P.ParsecT e s m a -> P.ParsecT e s m a
-- pdbg m p = P.dbg m p
pdbg _m p = p

type Parser e s a = (P.ErrorComponent e, P.Stream s, P.Token s ~ Char) => P.Parsec e s a

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.char ' ' >>= \hs ->
			return (KeySection $ List.length hs)
		 , do
			name <- Text.pack <$> some (P.satisfy $ \c ->
				Char.isAlphaNum c || c=='-' || c=='_')
			P.skipMany $ P.char ' '
			P.choice
			 [ P.char ':' $> KeyColon name
			 , P.char '>' $> KeyGreat name
			 , P.char '=' $> KeyEqual name
			 , P.char '|' $> KeyBar   name
			 -- 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'

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 "CellEnd" $ 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_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 ->
		(P.eof $> rows) <|>
		(P.newline >> p_Rows (appendRow rows (List.reverse row)))

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