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

import Control.Applicative (Applicative(..))
import Data.Bool
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Foldable (foldr)
import Data.Function (($), (.))
import Data.Functor (Functor, (<$>))
import Data.Maybe (Maybe(..))
import Data.Ord (Ordering(..), Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (Seq, ViewL(..), (|>))
import Data.Text (Text)
import Data.Traversable (Traversable(..))
import Data.Tuple (fst,snd)
import Prelude (undefined, Int, Num(..))
import Text.Show (Show(..))
import qualified Data.List as List
import qualified Data.Sequence as Seq
import qualified Data.Text as Text

import Language.TCT.Elem

-- * Type 'Tree'
data Tree k a
 =   TreeN k (Trees k a)
 |   Tree0 a
 deriving (Eq, Show, Functor)

instance Traversable (Tree k) where
	traverse f (TreeN k ts) = TreeN k <$> traverse (traverse f) ts
	traverse f (Tree0 a)    = Tree0 <$> f a
instance Foldable (Tree k) where
	foldMap f (TreeN _k ts) = foldMap (foldMap f) ts
	foldMap f (Tree0 k)     = f k

mapTreeWithKey :: (Maybe k -> a -> b) -> Tree k a -> Tree k b
mapTreeWithKey = go Nothing
	where
	go _k f (TreeN k ts) = TreeN k (go (Just k) f <$> ts)
	go k f (Tree0 a) = Tree0 (f k a)

traverseTreeWithKey :: Applicative f => (Maybe k -> a -> f b) -> Tree k a -> f (Tree k b)
traverseTreeWithKey = go Nothing
	where
	go _p f (TreeN k ts) = TreeN k <$> traverse (go (Just k) f) ts
	go p  f (Tree0 a)    = Tree0 <$> f p a

-- ** Type 'Trees'
type Trees k a = Seq (Tree k a)

newtype PrettyTree k a = PrettyTree (Trees k a)
instance (Show k, Show a) => Show (PrettyTree k a) where
	show (PrettyTree t) = Text.unpack $ prettyTrees t

prettyTree :: (Show k, Show a) => Tree k a -> Text
prettyTree = Text.unlines . pretty

prettyTrees :: (Show k, Show a) => Trees k a -> Text
prettyTrees = foldr (\t acc -> prettyTree t <> "\n" <> acc) ""

pretty :: (Show k, Show a) => Tree k a -> [Text]
pretty (Tree0 a) = [Text.pack (show a)]
pretty (TreeN k ts0) = Text.pack (show k) : prettySubTrees ts0
	where
	prettySubTrees s =
		case Seq.viewl s of
		 Seq.EmptyL -> []
		 t:<ts | Seq.null ts -> "|" : shift "`- " "   " (pretty t)
		       | otherwise   -> "|" : shift "+- " "|  " (pretty t) <> prettySubTrees ts
	shift first other = List.zipWith (<>) (first : List.repeat other)

-- * Type 'Pos'
type Pos = (Line,Column)

posTree :: Tree (Cell k) (Cell a) -> Pos
posTree (TreeN c _) = posCell c
posTree (Tree0 c)   = posCell c

posEndTree :: Tree (Cell k) (Cell a) -> Pos
posEndTree (TreeN c _) = posEndCell c
posEndTree (Tree0 c)   = posEndCell c


-- ** Type 'Line'
-- | Line in the source file, counting from 1.
type Line = Int
linePos :: Pos -> Line
linePos = fst

-- ** Type 'Column'
-- | Column in the source file, counting from 1.
type Column = Int
columnPos :: Pos -> Column
columnPos  = snd

-- * Type 'Row'
-- | A list of 'Key's, maybe ended by 'Value', all read on the same 'Line'.
type Row = [Tree (Cell Key) (Cell Text)]

-- ** Type 'Cell'
-- | NOTE: every 'Cell' as a 'Pos',
--         which is useful to indicate matches/errors/warnings/whatever,
--         or outputing in a format somehow preserving
--         the original input style.
data Cell a = Cell Pos Pos a
              deriving (Eq, Show)

unCell :: Cell a -> a
unCell (Cell _ _ a) = a

posCell :: Cell a -> Pos
posCell (Cell pos _ _) = pos

posEndCell :: Cell a -> Pos
posEndCell (Cell _ pos _) = pos

lineCell :: Cell a -> Line
lineCell = fst . posCell
columnCell :: Cell a -> Column
columnCell = snd . posCell

-- * Type 'Key'
data Key = KeyColon Name White     -- ^ @name:@ begin 'Cell'
         | KeyEqual Name White     -- ^ @name=@ begin 'Value'
         | KeyBar   Name White     -- ^ @name|@ continue 'Value'
         | KeyGreat Name White     -- ^ @name>@ continue 'Cell'
         | KeyLower Name Attrs     -- ^ @<name a=b@ begin HereDoc
         | KeyDash                 -- ^ @- @    begin item
         | KeySection LevelSection -- ^ @### @  begin section
         deriving (Eq, Show)

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

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

-- * Type 'Rows'
type Rows = [Tree (Cell Key) (Cell Text)]

-- | @appendRow rows row@ appends @row@ to @rows@.
--
-- [@rows@] parent 'Rows', from closed to farest (non-strictly descending)
-- [@row@]  next 'Row', from leftest column to rightest (non-stricly ascending)
appendRow :: Rows -> Row -> Rows
appendRow [] row = List.reverse row
appendRow parents [] = parents
appendRow ps@(parent:parents) rs@(row:rows) =
	trac ("appendRow: ps=" <> show ps) $
	trac ("appendRow: rs=" <> show rs) $
	dbg "appendRow" $
	let colParent = columnPos $ posTree parent in
	let colRow    = columnPos $ posTree row in
	case dbg "colParent" colParent`compare`dbg "colRow" colRow of
	 LT ->
		case (dbg "parent" parent,dbg "row" row) of
		 (Tree0{}, TreeN{}) -> eq
		 (Tree0 p, Tree0{}) | Text.null (unCell p) -> eq -- FIXME: useful?
		 (Tree0 p, Tree0 r) -> appendTree0 p r
		 _ -> lt
	 EQ ->
		case (dbg "parent" parent,dbg "row" row) of
		 (Tree0 p, Tree0 r) -> appendTree0 p r
		 (_, TreeN (unCell -> KeySection sectionRow) _)
		  | Just (sectionParent, secPar:secPars) <- collapseSection colRow ps ->
			case dbg "sectionParent" sectionParent`compare`dbg "sectionRow" sectionRow of
			 LT -> appendRow (row:secPar:secPars) rows
			 EQ -> appendRow (row:insertChild secPar secPars) rows
			 GT -> gt
		 (TreeN (unCell -> KeySection{}) _, Tree0{}) -> lt
		 (TreeN (unCell -> KeySection{}) _, TreeN{}) -> lt
		 (Tree0{}, TreeN{}) -> eq
		 (TreeN{}, TreeN{}) -> eq
		 (TreeN{}, Tree0{}) -> eq
	 GT -> gt
	where
	appendTree0 p r = appendRow (Tree0 (appendCellText p r):parents) rows
	lt = appendRow [] rs <> ps
	eq = appendRow (row:insertChild parent parents) rows
	gt = appendRow (insertChild parent parents) rs
	-- | Find the first section (if any), returning its level, and the path collapsed upto it.
	collapseSection :: Column -> Rows -> Maybe (Int,Rows)
	collapseSection col xxs@(x:xs) | columnPos (posTree x) == col =
		case x of
		 TreeN (unCell -> KeySection lvl) _ -> Just (lvl,xxs)
		 _ -> (\(lvl,cs) -> (lvl,insertChild x cs)) <$> collapseSection col xs
	collapseSection _ _ = Nothing

appendCellText :: Cell Text -> Cell Text -> Cell Text
appendCellText (Cell posPar posEndPar p)
               (Cell posRow posEndRow r) =
	trac ("appendCellText: p="<>show p) $
	trac ("appendCellText: r="<>show r) $
	dbg "appendCellText" $
	Cell posPar posEndRow $ p <> pad <> r
	where
	pad =
		let ns = linePos posRow - linePos posEndPar in
		if ns == 0
		then padding (columnPos posEndPar) (columnPos posRow)
		else Text.replicate ns "\n" <> padding (columnPos posPar) (columnPos posRow)
	padding x y = Text.replicate (y - x) " "

insertChild :: Tree (Cell Key) (Cell Text) -> Rows -> Rows
insertChild child ps@[] =
	trac ("insertChild: child="<>show child) $
	trac ("insertChild: ps="<>show ps) $
	dbg "insertChild" $
	[child]
insertChild _child (Tree0{}:_) = undefined
insertChild child ps@(TreeN parent treesParent:parents) =
	trac ("insertChild: child="<>show child) $
	trac ("insertChild: ps="<>show ps) $
	dbg "insertChild" $
	case dbg "colParent" (columnCell parent)`compare`dbg "colChild" (columnPos $ posTree child) of
	 LT -> TreeN parent (treesParent |> child) : parents
	 EQ -> TreeN parent (treesParent |> child) : parents
	 GT -> undefined

collapseRows :: Rows -> Tree (Cell Key) (Cell Text)
collapseRows [] = undefined
collapseRows [child] = dbg "collapseRows" $ child
collapseRows (child:parents) = dbg "collapseRows" $ collapseRows $ insertChild child parents

-- * Type 'TCT'
type TCT a = Trees (Cell Key) a