{-# 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 Token) -> TL.Text
text cfg tct = foldMap (t_TreeCell cfg) (treePosLastCell tct)

treeRackUpLeft :: Tree (Cell k) (Cell a) -> Tree (Cell k) (Cell a)
treeRackUpLeft t = go t
	where
	(l0,c0) = posTree t
	rackUpLeft 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) (1,1)
	where
	go :: Tree (Cell k) (Cell a) ->
	      S.State (Int, Int) (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'

t_Value :: Text -> TL.Text
t_Value v = tl v

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

t_TreeCell :: Config_Text -> Tree (Pos,Cell Key) (Pos,Cell Token) -> 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
	 _ -> "") <>
	foldMap (t_TreeCell 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 ((lineLast,colLast),posCell -> (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 Token) -> 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 -> "- " <> foldMap (t_TreeCell cfg) cells
	 KeyLower name attrs ->
		"<" <> tl name <> t_Attrs attrs <>
		foldMap (t_TreeCell cfg) cells
	 KeySection{} -> undefined
	where
	t_Key :: Text -> White -> TL.Text -> TL.Text
	t_Key name wh mark = tl name <> tl wh <> mark <> foldMap (t_TreeCell cfg) cells

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

t_IndentToken :: Config_Text -> Pos -> Token -> TL.Text
t_IndentToken cfg pos tok = go tok `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 t) = do
		t' <- go t
		return $ tl o<>t'<>tl c
		where (o,c) = pairBorders grp t
	go (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_Token t<>tl c
	where (o,c) = pairBorders grp t
t_Token (Tokens ts) = foldMap t_Token ts