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

import Control.Applicative (Applicative(..), Alternative(..))
import Control.Monad (Monad(..), void)
import Data.Bool
import Data.Char (Char)
import Data.Eq (Eq(..))
import Data.Monoid (Monoid(..))
import Data.Function (($), (.))
import Data.Functor ((<$>), ($>))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (ViewR(..))
import Data.String (String)
import Prelude (undefined, Int, Num(..), toInteger)
import Data.Text (Text)
import Text.Megaparsec.Text
import Text.Show (Show(..))
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

pdbg :: (Show a, P.ShowErrorComponent e, 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 'Pos'
p_Position :: Parser (Line,Column)
p_Position = (\p -> (intOfPos $ P.sourceLine p, intOfPos $ P.sourceColumn p)) <$> P.getPosition
intOfPos :: P.Pos -> Int
intOfPos = fromInteger . toInteger . P.unPos

-- ** Type 'Line'
p_Line :: Parser Line
p_Line = intOfPos . P.sourceLine <$> P.getPosition

-- ** Type 'Column'
p_Column :: Parser Column
p_Column = intOfPos . P.sourceColumn <$> P.getPosition

-- * Type 'Row'
p_Row :: Row -> Parser Row
p_Row row = pdbg "Row" $
	P.try (p_CellKey row) <|>
	P.try (p_CellValue row) <|>
	p_PlainLine row -- <|>
	-- (P.newline $> row) <|>
	-- (P.eof $> row)

-- ** Type 'Key'
p_CellKey :: Row -> Parser 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' = Key pos posEnd key : row
	case key of
	 KeySection{} -> P.try (p_CellValue row') <|> p_PlainLine row'
	 KeyDash{}    -> p_Row row'
	 KeyColon{}   -> p_Row row'
	 KeyGreat{}   -> p_Row row'
	 KeyEqual{}   -> p_PlainLine row'
	 KeyBar{}     -> p_PlainLine row'

-- | Parse up to an end-of-line or end-of-file.
p_PlainLine :: Row -> Parser Row
p_PlainLine row = pdbg "PlainLine" $ do
	P.skipMany $ P.char ' '
	pos <- p_Position
	line <- many $ P.satisfy (/='\n')
	posEnd <- p_Position
	P.newline $> Value pos posEnd (Text.pack line) : row
	 <|> P.eof $> row

-- *** Type 'Group'
p_CellValue :: Row -> Parser Row
p_CellValue row = pdbg "CellValue" $ do
	P.skipMany $ P.char ' '
	pos <- p_Position
	val <- Text.pack <$> P.some (P.satisfy (/='\n'))
	posEnd <- p_Position
	return $ Value pos posEnd val : row

p_Value :: Parser Value
p_Value = pdbg "Value" $
	-- (List.foldl' (<>) (Plain "") <$>) $
	-- some $ 
	Plain . Text.pack
	 <$> P.some (P.satisfy (/='\n'))
	{-
	P.choice $
	 [ -- P.try p_Escape
	 -- , P.try p_Tag
	 -- , P.try p_Group
	 , p_Plain
	 ]
	-}

p_Tag :: Parser Value
p_Tag = pdbg "Tag" $ P.try p_TagGroup <|> p_TagOpen
	where
	p_TagGroup = P.char '#' *> p_TagName <* P.char '#'
		where
		p_TagName :: Parser Value
		p_TagName =
			(\w ws -> Tag $ Text.concat $ w : ws)
			 <$> p_TagNameWord
			 <*> many ((<>) <$> (Text.pack <$> many (P.char ' ')) <*> p_TagNameWord)
		p_TagNameWord = Text.pack <$> some (P.satisfy $ \c -> c/=' ' && c/='#' && Char.isPrint c)
	p_TagOpen = P.char '#' *> p_TagName
		where
		p_TagName = Tag . Text.pack <$> some (P.satisfy isTagNameShortChar)

isTagNameShortChar :: Char -> Bool
isTagNameShortChar c | Char.isAlphaNum c = True
isTagNameShortChar '-' = True
isTagNameShortChar '_' = True
isTagNameShortChar _   = False

p_Escape :: Parser Value
p_Escape = do
	void $ P.char '\\'
	P.option (Plain $ "\\") $ P.try $ do
		P.choice
		 [ P.char c >> pure (Plain $ Text.singleton c)
		 | c <- "<>=|@#*_\\/`'\"«»-"
		 ]

p_Group :: Parser Value
p_Group =
	P.choice
	 [ p_Group1 Star        '*'
	 , p_Group1 Slash       '/'
	 , p_Group1 Underscore  '_'
	 , p_Group1 Dash        '-'
	 , p_Group1 Backquote   '`'
	 , p_Group1 Singlequote '\''
	 , p_Group1 Doublequote '"'
	 -- , Group Frenchquote <$ p_Group2 '«' '»'
	 ]

p_Group1 :: Group -> Char -> Parser Value
p_Group1 g c = (if c == '/' then pdbg "Group1" else (\p -> p)) $ do
	void $ P.char c
	P.option (Plain $ Text.singleton c) $ P.try $ do
		P.notFollowedBy $ P.char ' '
		v <- (if c == '/' then pdbg "Group1: Value" else (\p -> p)) $ p_Value
		case lastCharOfValue v of
		 ' ' -> fail "grouped Value ends with space"
		 _   -> return ()
		void $ P.char c
		return $ Group g v

lastCharOfValue :: Value -> Char
lastCharOfValue = \case
 Plain t -> Text.last t
 Tag t | Text.all (\c -> Char.isAlphaNum c || c=='-' || c=='_') t -> Text.last t
 Tag _t -> '#'
 Group _ v -> lastCharOfValue v
 Values vs | _:>v <- Seq.viewr vs -> lastCharOfValue v
 Values{} -> undefined

p_Plain :: Parser Value
p_Plain = pdbg "Plain" $
	Plain . Text.pack
	 <$> P.some
		 (P.satisfy $ \case
			 '\n' -> False
			 '#'  -> False
			 '*'  -> False
			 '_'  -> False
			 '/'  -> False
			 '`'  -> False
			 '\'' -> False
			 '"'  -> False
			 '«'  -> False
			 '»'  -> False
			 _    -> True
		 )

-- * Type 'Rows'

-- | @a-- * Type 'TCT'

p_TCT :: Parser (TCT Text)
p_TCT = do
	tree <- collapsePath <$> go [Tree (Value (0,0) (0,0) "") mempty]
	return $
		case tree of
		 Tree (Value _ _ v) roots | Text.null v -> roots
		 _ -> undefined
	where
	go :: Rows -> Parser Rows
	go acc = pdbg "go" $
		p_Row [] >>= \case
		 []  -> return acc
		 row -> go $ appendRow acc (List.reverse row)