{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Render a TCT file in plain Text.
module Language.TCT.Write.Plain where

import Control.Monad (Monad(..), mapM)
import Data.Bool
import Data.Default.Class (Default(..))
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 'Inh'
data Inh
 =   Inh
 {   inh_escape :: Bool
 } deriving (Eq, Show)
instance Default Inh where
	def = Inh
	 { inh_escape = True
	 }

plainify :: Inh -> Trees (Cell Key) Tokens -> TL.Text
plainify inh = plainifyTreesCell inh . 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

plainifyTreeCell ::
 Inh ->
 Tree (Pos,Cell Key) (Pos,Tokens) ->
 TL.Text
plainifyTreeCell inh (TreeN (posEnd, Cell pos _ (KeySection lvl)) ts) =
	plainifyIndentCell (posEnd,pos) <>
	TL.replicate (int64 lvl) "#" <> " " <>
	(case Seq.viewl ts of
	 Tree0 (_,title) :< _ ->
		plainifyIndentToken inh title
	 _ -> "") <>
	plainifyTreesCell inh
	 (case Seq.viewl ts of
		 Tree0{} :< ts' -> ts'
		 _ -> ts)
plainifyTreeCell inh (Tree0 (posEnd,toks)) =
	case Seq.viewl toks of
	 EmptyL -> plainifyIndentToken inh toks
	 t0:<_  -> plainifyIndentCell (posEnd,posCell t0) <> plainifyIndentToken inh toks
plainifyTreeCell inh (TreeN (posEnd,cell@(Cell pos _ _)) cs) =
	plainifyIndentCell (posEnd,pos) <>
	plainifyCellKey inh cell cs

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

plainifyCellKey ::
 Inh ->
 Cell Key ->
 Trees (Pos,Cell Key) (Pos,Tokens) ->
 TL.Text
plainifyCellKey inh (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 <> plainifyAttrs attrs <>
		plainifyTreesCell inh cells
	 KeySection{} -> undefined
	 KeyDotSlash p ->
		"./" <> TL.pack p <>
		plainifyTreesCell inh cells
	where
	textKey :: Text -> White -> TL.Text -> TL.Text
	textKey name wh mark =
		tl name <> tl wh <> mark <>
		plainifyTreesCell inh cells

plainifyTreesCell ::
 Inh ->
 Trees (Pos,Cell Key) (Pos,Tokens) ->
 TL.Text
plainifyTreesCell inh = foldMap (plainifyTreeCell inh)

plainifyIndentToken :: Inh -> Tokens -> TL.Text
plainifyIndentToken _cfg (Seq.viewl -> EmptyL) = ""
plainifyIndentToken inh 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 inh_escape inh
				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'

plainifyAttrs :: Attrs -> TL.Text
plainifyAttrs = foldMap plainifyAttr

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

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

plainifyTokens :: Tokens -> TL.Text
plainifyTokens ts = foldMap (plainifyToken . unCell) ts