{-# 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 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 (Tree0 a)    = Tree0 <$> f a
	traverse f (TreeN k ts) = TreeN k <$> traverse (traverse f) ts
	sequenceA (Tree0 a)     = Tree0 <$> a
	sequenceA (TreeN k ts)  = TreeN k <$> traverse sequenceA ts
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)

mapTreeKey :: (k -> l) -> (Maybe k -> a -> b) -> Tree k a -> Tree l b
mapTreeKey fk fv = go Nothing
	where
	go _k (TreeN k ts) = TreeN (fk k) $ go (Just k) <$> ts
	go k  (Tree0 a)    = Tree0 (fv 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'
data Pos = Pos {-# UNPACK #-} !Line {-# UNPACK #-} !Column
 deriving (Eq, Show)

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

pos0 :: Pos
pos0 = Pos 0 0
pos1 :: Pos
pos1 = Pos 1 1

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

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

-- * 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 {-# UNPACK #-} !Pos {-# UNPACK #-} !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 = linePos . posCell
columnCell :: Cell a -> Column
columnCell = columnPos . posCell

cell0 :: a -> Cell a
cell0 = Cell pos0 pos0
cell1 :: a -> Cell a
cell1 = Cell pos1 pos1

-- * Type 'Key'
data Key = KeyColon !Name !White    -- ^ @name: @
         | KeyEqual !Name !White    -- ^ @name=@
         | KeyBar   !Name !White    -- ^ @name|@
         | KeyGreat !Name !White    -- ^ @name>@
         | KeyLower !Name !Attrs    -- ^ @<name a=b@
         | KeyDot   !Name           -- ^ @1. @
         | KeyDash                  -- ^ @- @
         | KeyDashDash              -- ^ @-- @
         | KeySection !LevelSection -- ^ @# @
         | KeyBrackets !Name        -- ^ @[ name ]@
         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 closest 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 rows@(parent:parents) row@(cell:cells) =
	trac ("appendRow: rows=" <> show rows) $
	trac ("appendRow: row=" <> show row) $
	dbg "appendRow" $
	let colParent = columnPos $ posTree parent in
	let colRow    = columnPos $ posTree cell in
	case dbg "colParent" colParent`compare`dbg "colRow" colRow of
	 LT ->
		case (dbg "parent" parent,dbg "cell" cell) 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 "cell" cell) of
		 (Tree0 p, Tree0 r) -> appendTree0 p r
		 (_, TreeN (unCell -> KeySection sectionRow) _)
		  | Just (sectionParent, secPar:secPars) <- collapseSection colRow rows ->
			case dbg "sectionParent" sectionParent`compare`dbg "sectionRow" sectionRow of
			 LT -> appendRow (cell:secPar:secPars) cells
			 EQ -> appendRow (cell:insertChild secPar secPars) cells
			 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 =
		case appendCellText p r of
		 Nothing -> appendRow (Tree0 r : insertChild (Tree0 p) parents) cells
		 Just c  -> appendRow (Tree0 c : parents) cells
	lt = appendRow [] row <> rows
	eq = appendRow (cell : insertChild parent parents) cells
	gt = appendRow (insertChild parent parents) row
	-- | 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 -> Maybe (Cell Text)
appendCellText (Cell posPar posEndPar p)
               (Cell posRow posEndRow r) =
	trac ("appendCellText: p="<>show p) $
	trac ("appendCellText: r="<>show r) $
	dbg "appendCellText" $
	case linePos posRow - linePos posEndPar of
	 0 -> Just $ Cell posPar posEndRow $ p <> pad <> r
		where pad = padding (columnPos posEndPar) (columnPos posRow)
	 1 -> Just $ Cell posPar posEndRow $ p <> pad <> r
		where pad = "\n" <> padding (columnPos posPar) (columnPos posRow)
	 _ -> Nothing
	where
	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