{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Render a TCT file in plain Text.
module Language.TCT.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

text :: Trees (Cell Key) (Cell Token) -> TL.Text
text tct = foldMap t_TreeCell (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 :: Tree (Pos,Cell Key) (Pos,Cell Token) -> TL.Text
t_TreeCell (TreeN c@(_, unCell -> KeySection lvl) ts) =
	t_IndentCell c <>
	TL.replicate (int64 lvl) "#" <> " " <>
	(case Seq.viewl ts of
	 Tree0 (_,Cell posTitle _ title) :< _ -> t_IndentToken posTitle title
	 _ -> "") <>
	foldMap t_TreeCell (case Seq.viewl ts of {Tree0{} :< ts' -> ts'; _ -> ts})
t_TreeCell (Tree0 c@(_,cell)) =
	t_IndentCell c <>
	t_CellToken cell
t_TreeCell (TreeN c@(_,cell) cs) =
	t_IndentCell c <>
	t_CellKey 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 :: Cell Key -> Trees (Pos,Cell Key) (Pos,Cell Token) -> TL.Text
t_CellKey (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 cells
	 KeyLower name attrs ->
		"<" <> tl name <> t_Attrs attrs <>
		foldMap t_TreeCell cells
	where
	t_Key :: Text -> White -> TL.Text -> TL.Text
	t_Key name wh mark = tl name <> tl wh <> mark <> foldMap t_TreeCell cells

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

t_IndentToken :: Pos -> Token -> TL.Text
t_IndentToken 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 $ tl $ Text.pack ['\\',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