{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Render a TCT file in plain Text.
module Language.TCT.Write.Text where

import Control.Monad (Monad(..), mapM)
import Data.Bool
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), (.))
import Data.Functor ((<$>))
import Data.Int (Int)
import Data.Int (Int64)
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (ViewL(..), ViewR(..))
import Data.String (String)
import Data.Text (Text)
import Data.TreeSeq.Strict (Tree(..),Trees)
import Prelude (Num(..), undefined, Integral(..))
import Text.Show (Show(..))
import qualified Control.Monad.Trans.State as S
import qualified Data.List as L
import qualified Data.Sequence as Seq
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL

import Language.TCT.Tree
import Language.TCT.Cell
import Language.TCT.Token
import Language.TCT.Elem hiding (trac,dbg)

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

tl :: Text -> TL.Text
tl = TL.fromStrict

-- * Type 'Config_Text'
data Config_Text
 =   Config_Text
 {   config_text_escape :: Bool
 } deriving (Eq, Show)

config_text :: Config_Text
config_text =
	Config_Text
	 { config_text_escape = True
	 }

text :: Config_Text -> Trees (Cell Key) Tokens -> TL.Text
text cfg = t_TreesCell cfg . treePosLastCell

treeRackUpLeft :: Tree (Cell k) (Cell a) -> Tree (Cell k) (Cell a)
treeRackUpLeft t = go t
	where
	Pos l0 c0 = posTree t
	rackUpLeft pos =
		Pos
		 (linePos pos - l0 + 1)
		 (columnPos pos - c0 + 1)
	go :: Tree (Cell k) (Cell a) -> Tree (Cell k) (Cell a)
	go (Tree0 (Cell pos posEnd c)) =
		Tree0 $ Cell (rackUpLeft pos) (rackUpLeft posEnd) c
	go (TreeN (Cell pos posEnd c) ts) =
		TreeN
		 (Cell (rackUpLeft pos) (rackUpLeft posEnd) c)
		 (go <$> ts)

treePosLastCell ::
 Trees (Cell k) Tokens ->
 Trees (Pos,Cell k) (Pos,Tokens)
treePosLastCell t = S.evalState (go`mapM`t) (Pos 1 1)
	where
	go :: Tree (Cell k) Tokens ->
	      S.State Pos (Tree (Pos,Cell k) (Pos,Tokens))
	go (Tree0 ts) = do
		lastPos <- S.get
		case Seq.viewr ts of
		 EmptyR ->
			return $ Tree0 (lastPos,ts)
		 _ :> cell -> do
			S.put $ posEndCell cell
			return $ Tree0 (lastPos,ts)
	go (TreeN cell ts) = do
		lastPos <- S.get
		S.put $ posEndCell cell
		ts' <- go`mapM`ts
		return $ TreeN (lastPos,cell) ts'

int64 :: Integral i => i -> Int64
int64 = fromInteger . toInteger

t_TreeCell ::
 Config_Text ->
 Tree (Pos,Cell Key) (Pos,Tokens) ->
 TL.Text
t_TreeCell cfg (TreeN (posEnd, Cell pos _ (KeySection lvl)) ts) =
	t_IndentCell (posEnd,pos) <>
	TL.replicate (int64 lvl) "#" <> " " <>
	(case Seq.viewl ts of
	 Tree0 (_,title) :< _ ->
		t_IndentToken cfg title
	 _ -> "") <>
	t_TreesCell cfg
	 (case Seq.viewl ts of
		 Tree0{} :< ts' -> ts'
		 _ -> ts)
t_TreeCell cfg (Tree0 (posEnd,toks)) =
	case Seq.viewl toks of
	 EmptyL -> t_IndentToken cfg toks
	 t0:<_  -> t_IndentCell (posEnd,posCell t0) <> t_IndentToken cfg toks
t_TreeCell cfg (TreeN (posEnd,cell@(Cell pos _ _)) cs) =
	t_IndentCell (posEnd,pos) <>
	t_CellKey cfg cell cs

t_IndentCell :: (Pos,Pos) -> TL.Text
t_IndentCell (Pos lineLast colLast,Pos line col)
 | lineLast < line =
	TL.replicate (int64 $ line - (lineLast+1)) "\n" <>
	TL.replicate (int64 $ col - 1) " "
 | lineLast == line && colLast <= col =
	TL.replicate (int64 $ col - colLast) " "
 | otherwise = undefined

t_CellKey ::
 Config_Text ->
 Cell Key ->
 Trees (Pos,Cell Key) (Pos,Tokens) ->
 TL.Text
t_CellKey cfg (Cell _pos _posEnd key) cells = do
	case key of
	 KeyColon n wh -> t_Key n wh ":"
	 KeyGreat n wh -> t_Key n wh ">"
	 KeyEqual n wh -> t_Key n wh "="
	 KeyBar   n wh -> t_Key n wh "|"
	 KeyDash       -> t_Key "" "" "- "
	 KeyDashDash   -> t_Key "" "" "-- "
	 KeyLower name attrs ->
		"<" <> tl name <> t_Attrs attrs <>
		t_TreesCell cfg cells
	 KeySection{} -> undefined
	 KeyDotSlash p ->
		"./" <> TL.pack p <>
		t_TreesCell cfg cells
	where
	t_Key :: Text -> White -> TL.Text -> TL.Text
	t_Key name wh mark =
		tl name <> tl wh <> mark <>
		t_TreesCell cfg cells

t_TreesCell ::
 Config_Text ->
 Trees (Pos,Cell Key) (Pos,Tokens) ->
 TL.Text
t_TreesCell cfg = foldMap (t_TreeCell cfg)

t_IndentToken :: Config_Text -> Tokens -> TL.Text
t_IndentToken _cfg (Seq.viewl -> EmptyL) = ""
t_IndentToken cfg toks@(Seq.viewl -> Cell pos _ _ :< _) =
	goTokens toks `S.evalState` linePos pos
	where
	indent = TL.replicate (int64 $ columnPos pos - 1) " "
	go :: Cell Token -> S.State Int TL.Text
	go tok =
		case unCell tok of
		 TokenPlain txt -> do
			lnum <- S.get
			let lines = Text.splitOn "\n" txt
			S.put (lnum - 1 + L.length lines)
			return $
				case lines of
				 [] -> undefined
				 (l0:ls) -> tl l0 <> mconcat ((\l -> "\n"<>indent<>tl l)<$>ls)
		 TokenTag v -> return $ "#"<>tl v
		 TokenEscape c ->
			return $
				if config_text_escape cfg
				then tl $ Text.pack ['\\',c]
				else TL.singleton c
		 TokenLink lnk -> return $ tl lnk
		 TokenPair grp ts -> do
			ts' <- goTokens ts
			return $ tl o<>ts'<>tl c
			where (o,c) = pairBorders grp ts
	goTokens :: Tokens -> S.State Int TL.Text
	goTokens ts = do
		ts' <- go`mapM`ts
		return $ foldr (<>) mempty ts'

t_Attrs :: Attrs -> TL.Text
t_Attrs = foldMap t_Attr

t_Attr :: (Text,Attr) -> TL.Text
t_Attr (attr_white,Attr{..}) =
	mconcat $ tl <$>
	 [ attr_white
	 , attr_name
	 , attr_open
	 , attr_value
	 , attr_close
	 ]

t_Token :: Token -> TL.Text
t_Token (TokenPlain txt)  = tl txt
t_Token (TokenTag v)      = "#"<>tl v
t_Token (TokenEscape c)   = TL.singleton c -- tl $ Text.pack ['\\',c]
t_Token (TokenLink lnk)   = tl lnk
t_Token (TokenPair grp t) = tl o<>t_Tokens t<>tl c
	where (o,c) = pairBorders grp t

t_Tokens :: Tokens -> TL.Text
t_Tokens ts = foldMap (t_Token . unCell) ts