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

import Data.Bool
import Data.Eq (Eq(..))
import Data.Function (($), (.))
import Data.Functor (Functor, (<$>))
import Data.Foldable (foldr)
import Data.Monoid (Monoid(..))
import Data.Maybe (Maybe(..))
import Data.Ord (Ordering(..), Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (Seq, ViewL(..), ViewR(..), (|>), (<|))
import Data.String (String)
import Data.Text (Text)
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

data Tree a
 =   Tree a (Forest a)
 deriving (Eq, Show, Functor)
type Forest a = Seq (Tree a)

-- import Data.Tree
-- import Debug.Trace (trace)
trac :: String -> a -> a
dbg :: Show a => String -> a -> a
dbg m x = trac (m <> ": " <> show x) x

{-
trac m x = trace m x
pdbg m p = P.dbg m p
-}
trac _m x = x

newtype PrettyTree a = PrettyTree (Forest a)
instance Show a => Show (PrettyTree a) where
	show (PrettyTree t) = Text.unpack $ prettyForest t

-- | Neat 2-dimensional prettying of a tree.
prettyTree :: Show a => Tree a -> Text
prettyTree = Text.unlines . pretty

-- | Neat 2-dimensional prettying of a forest.
prettyForest :: Show a => Forest a -> Text
prettyForest = foldr (\t acc -> prettyTree t <> "\n" <> acc) ""

pretty :: Show a => Tree a -> [Text]
pretty (Tree x ts0) = Text.pack (show x) : 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 'TCT'
type TCT a = Forest (Cell a)

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

-- ** 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
colPos :: Pos -> Column
colPos  = snd

-- * Type 'Row'
-- | A list of 'Key's, maybe ended by 'Value', all read on the same 'Line'.
type Row = [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 = Key   Pos Pos Key
            | Value Pos Pos a
            deriving (Eq, Show)

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

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

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

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

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

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

-- ** Type 'Value'
data Value = Plain Text
           | Group Group Value
           | Tag Text
           | Values (Seq Value)
           deriving (Eq, Show)
instance Semigroup Value where
	Plain (Text.null -> True) <> y = y
	x <> Plain (Text.null -> True) = x
	Plain x <> Plain y = Plain (x<>y)
	Values (Seq.viewr -> xs:>x@Plain{}) <> y@Plain{} = Values (xs|>(x<>y))
	x@Plain{} <> Values (Seq.viewl -> y@Plain{}:<ys) = Values ((x<>y)<|ys)
	
	Values x <> Values y = Values (x<>y)
	Values x <> y = Values (x|>y)
	x <> Values y = Values (x<|y)
	
	x <> y = Values $ Seq.fromList [x,y]

-- *** Type 'Group'
data Group = Star        -- ^ @*value*@
           | Slash       -- ^ @/value/@
           | Underscore  -- ^ @_value_@
           | Dash        -- ^ @-value-@
           | Backquote   -- ^ @`value`@
           | Singlequote -- ^ @'value'@
           | Doublequote -- ^ @"value"@
           | Frenchquote -- ^ @«value»@
           | Paren       -- ^ @(value)@
           | Brace       -- ^ @{value}@
           | Bracket     -- ^ @[value]@
           deriving (Eq, Show)

-- * Type 'Rows'
type Rows = [Tree (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 = (`Tree` mempty) <$> List.reverse row
appendRow parents [] = parents
appendRow ps@(parent@(Tree cellParent treesParent):parents)
          rs@(cellRow:rows) =
	trac ("appendRow: ps=" <> show ps) $
	trac ("appendRow: rs=" <> show rs) $
	dbg "appendRow" $
	let colParent = columnCell cellParent in
	let colRow    = columnCell cellRow in
	case dbg "colParent" colParent`compare`dbg "colRow" colRow of
	 LT ->
		case (dbg "cellParent" cellParent,dbg "cellRow" cellRow) of
		 (Value{}, Key{}) -> eq
		 (Value _ _ p, Value{}) | Text.null p -> eq -- FIXME: useful?
		 (Value _ _ p, Value _ _ r) -> appendValues p r
		 _ -> lt
	 EQ ->
		case (dbg "cellParent" cellParent,dbg "cellRow" cellRow) of
		 (Value _ _ p, Value _ _ r) -> appendValues p r
		 (_, Key _ _ (KeySection sectionRow))
		  | Just (sectionParent, secPar:secPars) <- collapseSection colRow ps ->
			case dbg "sectionParent" sectionParent`compare`dbg "sectionRow" sectionRow of
			 LT -> appendRow (Tree cellRow mempty:secPar:secPars) rows
			 EQ -> appendRow (Tree cellRow mempty:insertChild secPar secPars) rows
			 GT -> gt
		 (Key _ _ KeySection{}, Value{}) -> lt
		 (Key _ _ KeySection{}, Key{})   -> lt
		 (Value{}, Key{}) -> eq
		 (Key{}, Key{})   -> eq
		 (Key{}, Value{}) -> eq
	 GT -> gt
		{-
		case (dbg "cellParent" cellParent,dbg "cellRow" cellRow) of
		 (Value _ _ p, Value _ _ r) -> appendValues p r
		 _ -> gt
		-}
	where
	appendValues p r =
		trac ("appendValues: p="<>show cellParent) $
		trac ("appendValues: r="<>show cellRow) $
		dbg "appendValues" $
		appendRow (Tree cell treesParent : parents) rows
		where
		cell = Value (posCell cellParent) (posEndCell cellRow) $ p <> pad <> r
		pad =
			if linePos (posEndCell cellParent) == linePos (posCell cellRow)
			then padding (colPos $ posEndCell cellParent) (columnCell cellRow)
			else "\n" <> padding (columnCell cellParent) (columnCell cellRow)
		padding x y = Text.replicate (y - x) " "
	lt = appendRow [] rs <> ps
	eq = appendRow (Tree cellRow mempty: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 pars@(x@(Tree c _):xs) | columnCell c == col =
		case x of
		 Tree (Key _ _ (KeySection lvl)) _ -> Just (lvl,pars)
		 _ -> (\(lvl,cs) -> (lvl,insertChild x cs)) <$> collapseSection col xs
	collapseSection _ _ = Nothing

insertChild :: Tree (Cell Text) -> Rows -> Rows
insertChild cellChild ps@[] =
	trac ("insertChild: cellChild="<>show cellChild) $
	trac ("insertChild: ps="<>show ps) $
	dbg "insertChild" $
	[cellChild]
insertChild child@(Tree cellChild _) ps@(Tree cellParent treesParent:parents) =
	trac ("insertChild: child="<>show child) $
	trac ("insertChild: ps="<>show ps) $
	dbg "insertChild" $
	case dbg "colParent" (columnCell cellParent)`compare`dbg "colChild" (columnCell cellChild) of
	 LT -> Tree cellParent (treesParent |> child) : parents
	 EQ -> Tree cellParent (treesParent |> child) : parents
	 GT -> undefined

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