{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoOverloadedLists #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
module Language.TCT.Tree 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.Token

-- ** Type 'TCT'
type Root  = Tree  Node
type Roots = Trees 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
 |   NodePair   !Pair
 |   NodeToken  !Token
 |   NodeText   !TL.Text
 |   NodeLower  !Name !ElemAttrs -- ^ @<name a=b@
 |   NodePara
 |   NodeGroup
 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)

-- ** 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 = [Tree (Cell Node)]

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

-- | @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) =
	debug "appendRow" "row"  row $
	debug "appendRow" "rows" rows $
	dbg "appendRow" $
	case dbg "colOld" (pos_column bo) `compare`
	     dbg "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 dbg "secOld" secOld `compare`
			     dbg "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" "action" ("lt"::TL.Text) $ List.reverse row <> rows
	eq = debug "appendRow" "action" ("eq"::TL.Text) $ appendRow (new : appendChild olds old) news
	gt = debug "appendRow" "action" ("gt"::TL.Text) $ 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) $
			dbg "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 -> Tree (Cell Node) -> Rows
appendChild rows new@(Tree (Cell bn en n) ns) =
	debug "appendChild" "new" new $
	debug "appendChild" "rows" rows $
	dbg "appendChild" $
	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|>Tree (Cell bn en NodePara) (return new)
		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) $
						os |> Tree (Cell bn en NodePara) (return new)
				 ls :> Tree (Cell br _er r) rs ->
					case r of
					 NodePara ->
						if pos_column br == pos_column bn
						then Tree (Cell bo en o) $ ls |> Tree (Cell br en NodePara) (rs |> new)
						else Tree (Cell bo en o) $ os |> Tree (Cell bn en NodePara) (return new)
					 _ ->  Tree (Cell bo en o) $ os |> new
		where newPara = pos_line bn - pos_line eo > 1

collapseRows :: Rows -> Tree (Cell Node)
collapseRows rs =
	debug "collapseRows" "rs" rs $
	dbg "collapseRows" $
	case rs of
	 [] -> undefined
	 [child] -> child
	 child:parents -> collapseRows $ appendChild parents child