{-# 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)

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_Token :: Token -> TL.Text
t_Token (TokenPlain txt) = tl txt
t_Token (TokenTag v) = "#"<>tl v
t_Token (TokenEscape c) = tl $ Text.pack ['\\',c]
t_Token (TokenLink lnk) = tl lnk
t_Token (TokenGroup grp t) = tl o<>t_Token t<>tl c
	where (o,c) = groupBorders grp t
t_Token (Tokens ts) = foldMap t_Token ts

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
		lin <- S.get
		let lines = Text.splitOn "\n" txt
		let lnums = tl : -- TODO: fmap
			 [ \line -> "\n"<>indent<>tl line
			 | _lnum <- [lin+1..]
			 ]
		S.put (lin - 1 + L.length lines)
		return $ mconcat $ L.zipWith ($) lnums lines
	go (TokenTag v) = return $ "#"<>tl v
	go (TokenEscape c) = return $ tl $ Text.pack ['\\',c]
	go (TokenLink lnk) = return $ tl lnk
	go (TokenGroup grp t) = do
		t' <- go t
		return $ tl o<>t'<>tl c
		where (o,c) = groupBorders 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
	 ]

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_TreeCell :: [Key] -> Tree (Cell Key) (Cell Token) -> TL.Text
t_TreeCell path (TreeN (unCell -> key@KeySection{}) ts) =
	case Seq.viewl ts of
	 Tree0 (Cell _posTitle _ (TokenPlain title)) :< _ ->
		D.section ! DA.name (attrValue title) $
			d_content
	 Tree0 (Cell _posTitle _ title) :< _ ->
		D.section $ do
			D.name $ d_Token (key:path) title
			d_content
	 _ -> D.section d_content
	where
	d_content = forM_ (case Seq.viewl ts of {Tree0{} :< ts' -> ts'; _ -> ts}) $ d_TreeCell (key:path)
t_TreeCell path (Tree0 cell) = d_CellToken path cell
t_TreeCell path (TreeN cell ts) = d_CellKey path cell ts

t_CellKey :: [Key] -> Cell Key -> Trees (Cell Key) (Cell Token) -> TL.Text
t_CellKey path (Cell _pos _posEnd key) cells = do
	case key of
	 KeyColon n _wh -> d_Key n
	 KeyGreat n _wh -> d_Key n
	 KeyEqual n _wh -> d_Key n
	 KeyBar   n _wh -> d_Key n
	 KeyDash -> "- " <> foldMap (d_TreeCell (key:path)) cells
	 {-
	 KeyLower name attrs -> do
		B.Content $ "<"<>B.toMarkup name
		d_Attrs attrs
		forM_ cells $ d_TreeCell path
	 -}
	where
	d_Key :: Text -> TL.Text
	d_Key name = do
		B.CustomParent (B.Text name) $
			forM_ cells $ d_TreeCell (key:path)

t_CellToken :: [Key] -> Cell Token -> TL.Text
t_CellToken path (Cell _pos _posEnd tok) =
	-- case L.find (\case KeySection{} -> True; _ -> False) $ dbg "d_CellToken: path:" path of
	case dbg "d_CellToken: path" path of
	 KeySection{}:_ ->
		case tok of
		 TokenGroup GroupElem{} _t -> d_Token path tok
		 _ -> D.para $ d_Token path tok
	 _ -> d_Token path tok
-}