{-# 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(..))
import Data.String (String)
import Data.Text (Text)
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.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) (Cell 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) (Cell a) -> Trees (Pos,Cell k) (Pos,Cell a)
treePosLastCell t = S.evalState (go`mapM`t) (Pos 1 1)
	where
	go :: Tree (Cell k) (Cell a) ->
	      S.State Pos (Tree (Pos, Cell k) (Pos, Cell a))
	go (Tree0 cell) = do
		lastPos <- S.get
		S.put $ posEndCell cell
		return $ Tree0 (lastPos,cell)
	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,Cell Tokens) ->
 TL.Text
t_TreeCell cfg (TreeN c@(_, unCell -> KeySection lvl) ts) =
	t_IndentCell c <>
	TL.replicate (int64 lvl) "#" <> " " <>
	(case Seq.viewl ts of
	 Tree0 (_,Cell posTitle _ title) :< _ -> t_IndentToken cfg posTitle title
	 _ -> "") <>
	t_TreesCell cfg
	 (case Seq.viewl ts of
		 Tree0{} :< ts' -> ts'
		 _ -> ts)
t_TreeCell cfg (Tree0 c@(_,cell)) =
	t_IndentCell c <>
	t_CellToken cfg cell
t_TreeCell cfg (TreeN c@(_,cell) cs) =
	t_IndentCell c <>
	t_CellKey cfg cell cs

t_IndentCell :: (Pos,Cell a) -> TL.Text
t_IndentCell (Pos lineLast colLast,posCell -> 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,Cell 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,Cell Tokens) ->
 TL.Text
t_TreesCell cfg = foldMap (t_TreeCell cfg)

t_CellToken :: Config_Text -> Cell Tokens -> TL.Text
t_CellToken cfg (Cell pos _posEnd tok) =
	t_IndentToken cfg pos tok

t_IndentToken :: Config_Text -> Pos -> Tokens -> TL.Text
t_IndentToken cfg pos toks = goTokens toks `S.evalState` linePos pos
	where
	indent = TL.replicate (int64 $ columnPos pos - 1) " "
	go :: Token -> S.State Int TL.Text
	go (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)
	go (TokenTag v) = return $ "#"<>tl v
	go (TokenEscape c) =
		return $
			if config_text_escape cfg
			then tl $ Text.pack ['\\',c]
			else TL.singleton c
	go (TokenLink lnk) = return $ tl lnk
	go (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 (Tokens 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 (Tokens ts) = foldMap t_Token ts