{-# LANGUAGE OverloadedStrings #-}
{-# 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,Int64)
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (ViewL(..), ViewR(..))
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

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 = textTreesCell 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

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

textIndentCell :: (Pos,Pos) -> TL.Text
textIndentCell (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

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

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

textIndentToken :: Config_Text -> Tokens -> TL.Text
textIndentToken _cfg (Seq.viewl -> EmptyL) = ""
textIndentToken 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'

textAttrs :: Attrs -> TL.Text
textAttrs = foldMap textAttr

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

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

textTokens :: Tokens -> TL.Text
textTokens ts = foldMap (textToken . unCell) ts