{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
module Language.TCT.Tree
 ( module Language.TCT.Tree
 , Tree(..), Trees
 ) where

import Control.Monad (Monad(..))
import Data.Bool
import Data.Char (Char)
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Function (($))
import Data.Int (Int)
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Ord (Ordering(..), Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence ((|>), (<|), ViewR(..))
import Data.TreeSeq.Strict (Tree(..), Trees)
import Prelude (undefined, Num(..))
import System.FilePath (FilePath)
import Text.Show (Show(..))
import qualified Data.List as List
import qualified Data.Sequence as Seq
import qualified Data.Text.Lazy as TL

import Language.TCT.Cell
import Language.TCT.Elem
import Language.TCT.Debug

-- * Type 'Root'
-- | A single 'Tree' to rule all the 'Node's simplifies the navigation.
-- For error reporting, each 'Node' is annotated with a 'Cell'
-- spanning over all its content (sub-'Trees' included).
type Root  = Tree  (Cell Node)
type Roots = Trees (Cell Node)

pattern Tree0 :: a -> Tree a
pattern Tree0 a <- Tree a (null -> True)
 where  Tree0 a = Tree a mempty

-- * Type 'Node'
data Node
 =   NodeHeader !Header  -- ^ node, from first parsing (indentation-sensitive)
 |   NodeText   !TL.Text -- ^ leaf verbatim text, from first parsing (indentation-sensitive)
 |   NodePair   !Pair    -- ^ node, from second parsing (on some 'NodeText's)
 |   NodeToken  !Token   -- ^ leaf, from second parsing (on some 'NodeText's)
 |   NodeLower  !Name !ElemAttrs -- ^ node, @<name a=b@
 |   NodePara  -- ^ node, gather trees by paragraph,
               --   useful to know when to generate a <para> XML node
 |   NodeGroup -- ^ node, group trees into a single tree,
               --   useful to return many trees when only one is expected
 deriving (Eq,Show)

-- * Type 'Header'
data Header
 =   HeaderColon !Name !White     -- ^ @name: @
 |   HeaderEqual !Name !White     -- ^ @name=@
 |   HeaderBar   !Name !White     -- ^ @name|@
 |   HeaderGreat !Name !White     -- ^ @name>@
 |   HeaderDot   !Name            -- ^ @1. @
 |   HeaderDash                   -- ^ @- @
 |   HeaderDashDash               -- ^ @-- @
 |   HeaderSection  !LevelSection -- ^ @# @
 |   HeaderBrackets !Name         -- ^ @[name]@
 |   HeaderDotSlash !FilePath     -- ^ @./file @
 deriving (Eq, Ord, Show)

-- ** Type 'Name'
type Name = TL.Text

-- ** Type 'LevelSection'
type LevelSection = Int

-- * Type 'Pair'
data Pair
 =   PairElem !ElemName !ElemAttrs -- ^ @<elem n0=v0 n1=v1>value</elem>@
 |   PairHash        -- ^ @#value#@
 |   PairStar        -- ^ @*value*@
 |   PairSlash       -- ^ @/value/@
 |   PairUnderscore  -- ^ @_value_@
 |   PairDash        -- ^ @-value-@
 |   PairBackquote   -- ^ @`value`@
 |   PairSinglequote -- ^ @'value'@
 |   PairDoublequote -- ^ @"value"@
 |   PairFrenchquote -- ^ @«value»@
 |   PairParen       -- ^ @(value)@
 |   PairBrace       -- ^ @{value}@
 |   PairBracket     -- ^ @[value]@
 deriving (Eq,Ord,Show)
instance Pretty Pair

-- * Type 'Token'
data Token
 =   TokenText   !TL.Text
 |   TokenEscape !Char
 |   TokenLink   !Link
 |   TokenTag    !Tag
 deriving (Eq,Show)

-- ** Type 'Tag'
type Tag = TL.Text

-- ** Type 'Link'
type Link = TL.Text

-- * Type 'Row'
-- | In normal order: a list of 'Header's, maybe ended by 'Value', all read on the same line.
type Row = [Root]

-- ** Type 'Rows'
-- | In reverse order: a list of nodes in scope
-- (hence to which the next line can append to).
type Rows = [Root]

-- | @appendRow rows row@ appends @row@ to @rows@.
--
-- [@rows@] parent 'Rows', from closest to farthest (non-strictly descending)
-- [@row@]  next 'Row', from leftest column to rightest (non-stricly ascending)
appendRow :: Rows -> Row -> Rows
appendRow [] row = List.reverse row
appendRow rows [] = rows
appendRow rows@(old@(Tree (Cell bo eo o) os):olds)
           row@(new@(Tree (Cell bn en n) ns):news) =
	debug2_ "appendRow" ("row",row) ("rows",rows) $
	case debug0 "colOld" (pos_column bo) `compare`
	     debug0 "colNew" (pos_column bn) of
	 LT -> mergeNodeText lt
	 EQ ->
		mergeNodeText $
		case (o,n) of
		 (_, NodeHeader (HeaderSection secNew))
		  | Just (secOld, s0:ss) <- collapseSection (pos_column bn) rows ->
			case debug0 "secOld" secOld `compare`
			     debug0 "secNew" secNew of
			 LT -> appendRow (new:s0:ss) news
			 EQ -> appendRow (new:appendChild ss s0) news
			 GT -> gt
		 (NodeHeader HeaderSection{}, _) -> lt
		 (_, NodeText tn) | TL.null tn -> gt
		 (NodePara, _) | not newPara -> lt
		 _ | newPara -> gt
		 _ -> eq
	 GT -> gt
	where
	newPara = pos_line bn - pos_line eo > 1
	lt = debug "appendRow/lt" $ List.reverse row <> rows
	eq = debug "appendRow/eq" $ appendRow (new : appendChild olds old) news
	gt = debug "appendRow/gt" $ appendRow (      appendChild olds old) row
	
	-- | Find the first section (if any), returning its level, and the path collapsed upto it.
	collapseSection :: ColNum -> Rows -> Maybe (LevelSection,Rows)
	collapseSection col xxs@(x:xs) | pos_column (cell_begin (unTree x)) == col =
		case x of
		 Tree (unCell -> NodeHeader (HeaderSection lvl)) _ -> Just (lvl, xxs)
		 _ -> do
			(lvl, cs) <- collapseSection col xs
			return (lvl, appendChild cs x)
	collapseSection _ _ = Nothing
	
	mergeNodeText :: Rows -> Rows
	mergeNodeText rs
	 | newPara = rs
	 | otherwise =
		case (o,n) of
		 (NodeText to, NodeText tn)
			| null os
			, not (TL.null to)
			, not (TL.null tn) ->
			-- debug "appendRow" "action" ("mergeNodeText"::TL.Text) $
			debug0 "mergeNodeText" $
			appendRow (merged : olds) news
			where
			merged = Tree (Cell bo en $ NodeText $ to<>tp<>tn) ns
			tp = fromPad Pos
				 { pos_line   = pos_line   bn - pos_line   eo
				 , pos_column = pos_column bn - pos_column bo
				 }
		 _ -> rs

appendChild :: Rows -> Root -> Rows
appendChild rows new@(Tree (Cell bn en n) ns) =
	debug2_ "appendChild" ("new",Seq.singleton new) ("rows",rows) $
	case rows of
	 [] -> [new]
	 old@(Tree (Cell bo eo o) os) : olds ->
		(: olds) $
		if newPara
		then
			case (o,n) of
			 (NodePara,NodePara) -> Tree (Cell bo en NodeGroup) $ Seq.fromList [old,new]
			 (NodePara,_)        -> Tree (Cell bo en NodeGroup) $ Seq.fromList [old,Tree (Cell bn en NodePara) $ return new]
			 (_,NodePara)        -> Tree (Cell bo en o) $ os|>new
			 (NodeText{},_)      -> Tree (Cell bo en NodeGroup) $ Seq.fromList [old,new]
			 _                   -> Tree (Cell bo en o) $ os|> newTree
		else
			case (o,n) of
			 (NodePara,NodePara) -> Tree (Cell bo en NodePara) $ os<>ns
			 (NodePara,_)        -> Tree (Cell bo en NodePara) $ os|>new
			 (_,NodePara)        -> Tree (Cell bo en NodePara) $ old<|ns
			 (NodeText{},_)      -> Tree (Cell bo en NodeGroup) $ Seq.fromList [old,new]
			 _ ->
				case Seq.viewr os of
				 EmptyR -> Tree (Cell bo en o) $ return newTree
				 ls :> Tree (Cell br _er r) rs ->
					case r of
					 NodePara
					  | pos_column br == pos_column bn
					              -> Tree (Cell bo en o) $ ls |> Tree (Cell br en NodePara) (rs |> new)
					  | otherwise -> Tree (Cell bo en o) $ os |> newTree
					 _ ->  Tree (Cell bo en o) $ os |> new
		where
		newPara = pos_line bn - pos_line eo > 1
		newTree =
			case n of
			 NodeHeader{} -> new
			 NodeLower{}  -> new
			 _            -> Tree (Cell bn en NodePara) (return new)

collapseRows :: Rows -> Root
collapseRows =
	debug1 "collapseRows" "rs" $ \case
	 [] -> undefined
	 [child] -> child
	 child:parents -> collapseRows $ appendChild parents child