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

import Control.Applicative (liftA2)
import Control.Monad (Monad(..), mapM)
import Data.Bool
import Data.Default.Class (Default(..))
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), (.), id)
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.String (String)
import Data.Text (Text)
import Data.TreeSeq.Strict (Tree(..),Trees)
import GHC.Exts (IsString(..))
import Prelude (Num(..), undefined, Integral(..))
import Text.Show (Show(..))
import qualified Control.Monad.Trans.Reader as R
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

-- * Type 'Plain'
type Plain = R.Reader State TL.Text
instance IsString Plain where
	fromString = return . fromString
instance Semigroup Plain where
	(<>) = liftA2 (<>)
instance Monoid Plain where
	mempty  = return ""
	mappend = (<>)

runPlain :: Plain -> State -> TL.Text
runPlain p s = {-TLB.toLazyText .-} R.runReader p s

text :: Plainify a => State -> a -> TL.Text
text st a = runPlain (plainify a) st

-- * Type 'State'
data State
 =   State
 {   state_escape :: Bool
 } deriving (Eq, Show)
instance Default State where
	def = State
	 { state_escape = True
	 }

-- * Class 'Plainify'
class Plainify a where
	plainify :: a -> Plain
instance Plainify String where
	plainify = return . fromString
instance Plainify Text where
	plainify = return . TL.fromStrict
instance Plainify TL.Text where
	plainify = return
instance Plainify (Trees (Cell Key) Tokens) where
	plainify = plainify . treePosLastCell
instance Plainify (Trees (Pos,Cell Key) (Pos,Tokens)) where
	plainify = foldMap plainify
instance Plainify (Tree (Pos,Cell Key) (Pos,Tokens)) where
	plainify (TreeN (posEnd, Cell pos _ (KeySection lvl)) ts) =
		plainifyIndentCell (posEnd,pos) <>
		plainify (TL.replicate (int64 lvl) "#") <> " " <>
		(case Seq.viewl ts of
		 Tree0 (_,title) :< _ ->
			plainify title
		 _ -> "") <>
		plainify
		 (case Seq.viewl ts of
			 Tree0{} :< ts' -> ts'
			 _ -> ts)
	plainify (Tree0 (posEnd,toks)) =
		case Seq.viewl toks of
		 EmptyL -> plainify toks
		 t0:<_  -> plainifyIndentCell (posEnd,posTree t0) <> plainify toks
	plainify (TreeN (posEnd,cell@(Cell pos _ _)) cs) =
		plainifyIndentCell (posEnd,pos) <>
		plainify (cell, cs)
instance Plainify (Cell Key, Trees (Pos,Cell Key) (Pos,Tokens)) where
	plainify (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 ->
			"<" <>
			plainify name <>
			plainify attrs <>
			plainify cells
		 KeySection{} -> undefined
		 KeyDotSlash p ->
			plainify ("./"::TL.Text) <>
			plainify p <>
			plainify cells
		where
		textKey :: Text -> White -> TL.Text -> Plain
		textKey name wh mark =
			plainify (textify name <> textify wh <> mark) <>
			plainify cells
instance Plainify Tokens where
	plainify toks =
		case Seq.viewl toks of
		 EmptyL -> ""
		 t0 :< _ -> do
			st <- R.ask
			return $ goTokens st toks `S.evalState` linePos pos
			where
			pos = posTree t0
			indent = TL.replicate (int64 $ columnPos pos - 1) " "
			go :: State -> Token -> S.State Int TL.Text
			go st@State{..} = \case
			 TreeN (unCell -> p) ts -> do
				ts' <- goTokens st ts
				return $ textify o<>ts'<>textify c
				where (o,c) = pairBorders p ts
			 Tree0 (unCell -> tok) ->
				case 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) -> textify l0 <> mconcat ((\l -> "\n"<>indent<>textify l)<$>ls)
				 TokenTag v -> return $ "#"<>textify v
				 TokenEscape c -> do
					return $
						if state_escape
						then textify $ Text.pack ['\\',c]
						else TL.singleton c
				 TokenLink lnk -> return $ textify lnk
			goTokens :: State -> Tokens -> S.State Int TL.Text
			goTokens st ts = do
				ts' <- go st`mapM`ts
				return $ foldr (<>) mempty ts'
instance Plainify Attrs where
	plainify = plainify . textify

-- * Class 'Textify'
class Textify a where
	textify :: a -> TL.Text
instance Textify Text where
	textify = TL.fromStrict
instance Textify TL.Text where
	textify = id
instance Textify Attrs where
	textify = foldMap textify
instance Textify (Text,Attr) where
	textify (attr_white,Attr{..}) =
		mconcat $ textify <$>
		 [ attr_white
		 , attr_name
		 , attr_open
		 , attr_value
		 , attr_close
		 ]
instance Textify Token where
	textify = \case
	 TreeN (unCell -> p) ts -> textify o<>textify ts<>textify c
		where (o,c) = pairBorders p ts
	 Tree0 (unCell -> t) ->
		case t of
		 TokenPlain txt -> textify txt
		 TokenTag v     -> "#"<>textify v
		 TokenEscape c  -> TL.singleton c -- textify $ Text.pack ['\\',c]
		 TokenLink lnk  -> textify lnk
instance Textify Tokens where
	textify = foldMap textify

-- * Utilities

plainifyIndentCell :: (Pos,Pos) -> Plain
plainifyIndentCell (Pos lineLast colLast,Pos line col)
 | lineLast < line =
	return $
	TL.replicate (int64 $ line - (lineLast+1)) "\n" <>
	TL.replicate (int64 $ col - 1) " "
 | lineLast == line && colLast <= col =
	return $
	TL.replicate (int64 $ col - colLast) " "
 | otherwise = undefined

-- ** 'Tree'
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)
		 _ :> r -> do
			S.put $ posEndTree r
			return $ Tree0 (lastPos,ts)
	go (TreeN p ts) = do
		lastPos <- S.get
		S.put $ posEndCell p
		ts' <- go`mapM`ts
		return $ TreeN (lastPos,p) ts'

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