{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.TCT.Write.Plain where

import Control.Applicative (Applicative(..), liftA2)
import Control.Monad (Monad(..), mapM)
import Data.Bool
import Data.Char (Char)
import Data.Default.Class (Default(..))
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), (.))
import Data.Functor ((<$>))
import Data.Int (Int64)
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (Seq, ViewL(..))
import Data.String (String, IsString(..))
import Data.Text (Text)
import Data.TreeSeq.Strict (Tree(..),Trees)
import Data.Tuple (fst)
import Prelude (Num(..), undefined, Integral(..))
import Text.Show (Show(..))
import qualified Control.Monad.Trans.State as S
import qualified Data.Sequence as Seq
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB

-- import Language.TCT.Tree
import Language.TCT.Token
import Language.TCT.Cell
import Language.TCT.Elem
import Language.TCT.Read.Token

-- * Type 'Plain'
type Plain = S.State State TLB.Builder
 -- NOTE: To get maximum performance when building lazy Text values using a builder,
 --       associate mappend calls to the right.
 -- NOTE: (Semigroup.<>) associates to the right.
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 $ fst $ S.runState p s

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

-- ** Type 'State'
data State
 =   State
 {   state_escape :: Bool -- FIXME: useful?
 ,   state_pos    :: Pos
 } deriving (Eq, Show)
instance Default State where
	def = State
	 { state_escape = True
	 , state_pos    = pos1
	 }

-- * Class 'Plainify'
class Plainify a where
	plainify :: a -> Plain
instance Plainify () where
	plainify = mempty
instance Plainify Char where
	plainify = return . TLB.singleton
instance Plainify String where
	plainify = return . fromString
instance Plainify Text where
	plainify = plainify . TL.fromStrict
instance Plainify TL.Text where
	plainify = return . TLB.fromLazyText
instance Plainify a => Plainify (Cell a) where
	plainify (Cell _bp@(Pos line col) ep a) = do
		Pos lineLast colLast <- S.gets state_pos
		case () of
		 _ | lineLast < line -> do
			S.modify $ \s -> s{state_pos=ep}
			plainify (Text.replicate (line - lineLast - 1) "\n")
			 <> plainify (Text.replicate (col - 1) " ")
			 <> plainify a
		 _ | lineLast == line && colLast <= col -> do
			S.modify $ \s -> s{state_pos=ep}
			plainify (Text.replicate (col - colLast) " ")
			 <> plainify a
		 _ -> undefined
instance Plainify (Trees (Cell Key) Tokens) where
	plainify = foldMap plainify
instance Plainify (Tree (Cell Key) Tokens) where
	plainify = \case
	 TreeN (Cell bp ep k) ts -> plainify (Cell bp ep (k,ts))
	 Tree0 ts -> plainify ts
instance Plainify (Key, Trees (Cell Key) Tokens) where
	plainify (key, ts) =
		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 ts
		 KeySection lvl ->
			plainify (TL.replicate (int64 lvl) "#") <>
			case Seq.viewl ts of
			 Tree0 title :< ts' ->
				plainify title <>
				plainify ts'
			 _ -> plainify ts
		 KeyDotSlash p ->
			plainify ("./"::TL.Text) <>
			plainify p <>
			plainify ts
		where
		textKey :: Text -> White -> TL.Text -> Plain
		textKey name wh mark =
			plainify name <>
			plainify wh <>
			plainify mark <>
			plainify ts
instance Plainify Tokens where
	plainify = foldMap plainify
instance Plainify Token where
	plainify = \case
	 TreeN (Cell bp ep k) ts ->
		plainify (Cell bp ep ()) <>
		plainify o <> plainify ts <> plainify c
		where (o,c) = pairBorders k ts
	 Tree0 tok ->
		-- plainify (Cell bp ep ()) <>
		case tok of
		 TokenPhrases p -> plainify p
		 TokenRaw t -> plainify t
			{- TODO: remove
			lnum <- S.get
			let lines = Text.splitOn "\n" txt
			S.put (lnum - 1 + List.length lines)
			return $
				case lines of
				 [] -> undefined
				 (l0:ls) -> plainify l0 <> mconcat ((\l -> "\n"<>indent<>plainify l)<$>ls)
			-}
		 TokenTag v -> plainify $ ("#"<>) <$> v
		 TokenEscape c -> do
			esc <- S.gets state_escape
			if esc
			 then plainify $ (('\\' :) . pure) <$> c
			 else plainify c
		 TokenLink lnk -> plainify lnk
instance Plainify Phrases where
	plainify = foldMap plainify
instance Plainify Phrase where
	plainify p =
		case p of
		 PhraseWord  t -> plainify t
		 PhraseWhite t -> plainify t
		 PhraseOther t -> plainify t
instance Plainify ElemAttrs where
	plainify = foldMap plainify
instance Plainify (Text,ElemAttr) where
	plainify (elemAttr_white,ElemAttr{..}) =
		mconcat $ plainify <$>
		 [ elemAttr_white
		 , elemAttr_name
		 , elemAttr_open
		 , elemAttr_value
		 , elemAttr_close
		 ]

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

-- * Class 'RackUpLeft'
class RackUpLeft a where
	rackUpLeft :: a -> S.State (Maybe Pos) a
instance RackUpLeft Pos where
	rackUpLeft pos@Pos{..} = do
		S.get >>= \case
		 Nothing -> return pos
		 Just (Pos l0 c0) ->
			return Pos
			 { linePos   = linePos   - l0 + 1
			 , columnPos = columnPos - c0 + 1
			 }
instance RackUpLeft (Cell a) where
	rackUpLeft (Cell bp ep a) = do
		S.modify $ \case
		 Nothing -> Just bp
		 p -> p
		Cell
		 <$> rackUpLeft bp
		 <*> rackUpLeft ep
		 <*> pure a
instance RackUpLeft a => RackUpLeft (Seq a) where
	rackUpLeft = mapM rackUpLeft
instance (RackUpLeft k, RackUpLeft a) => RackUpLeft (Tree k a) where
	rackUpLeft = \case
	 Tree0 a    -> Tree0 <$> rackUpLeft a
	 TreeN k ts -> TreeN <$> rackUpLeft k <*> rackUpLeft ts

{-
-- * 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'

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