{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
module Language.TCT where

import Data.Bool
import Control.Applicative (Applicative(..), Alternative(..))
import qualified Data.Char as Char
import qualified Data.List as List
import Data.Semigroup ((<>))
-- import Data.Tuple (fst,snd)
import Data.Maybe (Maybe(..))
import Data.Ord (Ordering(..), Ord(..))
import Data.Function (($), (.))
import Data.Functor ((<$>))
import Control.Monad (Monad(..))
import Data.Eq (Eq(..))
import Data.Text (Text)
import qualified Data.Text as T
import Text.Show (Show(..))
import Data.String (String)
import Text.Megaparsec.Text
import Prelude (undefined, Int, Num(..), toInteger)
import qualified Text.Megaparsec as P

import Data.Tree
import Debug.Trace ()

trac :: String -> a -> a
trac _m x = x

dbg :: Show a => String -> a -> a
dbg m x = trac (m <> ": " <> show x) x

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

column :: Parser Col
column = fromInteger . toInteger . P.unPos . P.sourceColumn <$> P.getPosition

type Col = Int
type Name = Text
data Token = Key   Key
           | Value Text
           deriving (Eq, Show)
data Key = Great Name
         | Equal Name
         | Colon Name
         | Bar   Name
         | Dash
         | Section Int Value
         deriving (Eq, Show)
data Value = Verbatim Text
           | Tag Text
           | Decoration Decoration Value
           deriving (Eq, Show)
data Decoration = Bold
                | Italic
                | Underline
                | Crossed
                | Code
                deriving (Eq, Show)

appendRow ::
 [(Col,Tree Token)] -> -- ^ parents, from closed to farest (non-strictly descending)
 [(Col,Token)] ->      -- ^ next row, from leftest column to rightest (non-stricly ascending)
 [(Col,Tree Token)]    -- ^ new parents
appendRow [] row = ((`Node` []) <$>) <$> List.reverse row
appendRow parents [] = parents
appendRow ps@((colParent,parent@(Node tokParent nodesParent)):parents)
          rs@((colRow,tokRow):rows) =
	trac ("appendRow: ps=" <> show ps) $
	trac ("appendRow: rs=" <> show rs) $
	dbg "appendRow" $
	case dbg "colParent" colParent`compare`dbg "colRow" colRow of
	 LT -> lt
	 EQ ->
		case (dbg "tokParent" tokParent,dbg "tokRow" tokRow) of
		 (Value p, Value r) -> appendRow ((colRow, Node tok nodesParent) : parents) rows
		                       where tok = Value $ p <> T.singleton '\n' <> padding colParent colRow <> r
		                             padding x y = T.replicate (fromInteger $ toInteger $ y - x) (T.singleton ' ')
		 (_, Key (Section sectionRow _)) | Just (sectionParent, sp:pars) <- collapseSection colRow ps ->
			case dbg "sectionParent" sectionParent`compare`dbg "sectionRow" sectionRow of
			 LT -> appendRow ((colRow,Node tokRow []):sp:pars) rows
			 EQ -> appendRow ((colRow,Node tokRow []):insertChild sp pars) rows
			 GT -> gt
		 (Key (Section{}), Value{}) -> lt
		 (Key (Section{}), Key{})   -> lt
		 (Value{}, Key{}) -> eq
		 (Key{}, Key{})   -> eq
		 (Key{}, Value{}) -> eq
	 GT -> gt
	where
	lt = appendRow [] rs <> ps
	eq = appendRow ((colRow,Node tokRow []):insertChild (colParent,parent) parents) rows
	gt = appendRow (insertChild (colParent,parent) parents) rs
	-- | Find the first section (if any), returning its level, and the path collpased upto it.
	collapseSection :: Col -> [(Col,Tree Token)] -> Maybe (Int,[(Col,Tree Token)])
	collapseSection col pars@((c,x):xs) | c==col =
		case x of
		 Node (Key (Section s _)) _ -> Just (s,pars)
		 _ -> (\(s,cs) -> (s,insertChild (c,x) cs)) <$> collapseSection col xs
	collapseSection _ _ = Nothing

insertChild :: (Col,Tree Token) -> [(Col,Tree Token)] -> [(Col,Tree Token)]
insertChild c ps@[] =
	trac ("insertChild: c="<>show c) $
	trac ("insertChild: ps="<>show ps) $
	dbg "insertChild" $
	[c]
insertChild c@(colChild,child) ps@((colParent,Node tokParent nodesParent):parents) =
	trac ("insertChild: c="<>show c) $
	trac ("insertChild: ps="<>show ps) $
	dbg "insertChild" $
	case dbg "colParent" colParent`compare`dbg "colChild" colChild of
	 LT -> (colParent,Node tokParent (nodesParent <> [child])) : parents
	 EQ -> (colParent,Node tokParent (nodesParent <> [child])) : parents
	 GT -> undefined

collapsePath :: [(Col,Tree Token)] -> Tree Token
collapsePath [] = undefined
collapsePath [(_,child)] = dbg "collapsePath" $ child
collapsePath (child:parents) = dbg "collapsePath" $ collapsePath $ insertChild child parents

p_Row :: [(Col,Token)] -> Parser [(Col,Token)]
p_Row path = pdbg "Path" $ do
	P.skipMany $ P.char ' '
	P.try p_Key <|> p_Value path
	where
	p_Key = do
		colKey <- column
		P.choice
		 [ P.string "- " >>
			P.try (p_Row ((colKey,Key Dash):path)) <|>
			p_Value ((colKey,Key Dash):path)
		 , P.try $ do
			hs <- List.length <$> P.some (P.char '#') <* P.char ' '
			v  <- p_line
			p_Value $ (colKey,Key $ Section hs $ Verbatim v):path
		 , do
			name <- T.pack <$> some (P.satisfy $ \c -> Char.isAlphaNum c || c=='-' || c=='_')
			P.choice
			 [ P.char ':' >>
				P.try (p_Row ((colKey,Key $ Colon name):path)) <|>
				p_Value ((colKey,Key $ Colon name):path)
			 , P.char '>' >>
				P.try (p_Row ((colKey,Key $ Great name):path)) <|>
				p_Value ((colKey,Key $ Great name):path)
			 , P.char '=' >> p_Value ((colKey,Key $ Equal name):path)
			 , P.char '|' >> p_Value ((colKey,Key $ Bar   name):path)
			 ]
		 ]
	p_Value pth = pdbg "Value" $ do
		colValue  <- column
		P.option pth . P.try $ do
			(\v -> (colValue, Value v) : pth)
			 <$> p_line
	p_line = T.pack <$> some (P.notFollowedBy (P.newline) *> P.anyChar)

p_TCT :: Parser [Tree Token]
p_TCT = do
	tree <- collapsePath <$> go [(0,Node (Value T.empty) [])]
	return $
		case tree of
		 Node (Value v) roots | T.null v -> roots
		 _ -> undefined
	where
	go :: [(Col,Tree Token)] -> Parser [(Col,Tree Token)]
	go acc = pdbg "go" $ do
		P.skipMany $ P.char ' ' <|> P.char '\n'
		p_Row [] >>= \case
		 [] -> return acc
		 row -> go $ appendRow acc (List.reverse row)

parser :: Parser [Tree Token]
parser = p_TCT <* P.eof