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

import Control.Applicative (liftA2)
import Control.Monad (Monad(..))
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 (Int)
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..), Ordering(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (ViewL(..))
import Data.String (String, IsString(..))
import Data.Tuple (fst)
import Prelude (Num(..), error)
import Text.Show (Show(..))
import qualified Control.Monad.Trans.State as S
import qualified Data.List as List
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
import qualified Data.Sequence as Seq

import Language.TCT
import Language.TCT.Utils
-- import Language.TCT.Debug

-- * 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 = plainify
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 s a = runPlain (plainify a) s

plainDocument :: Roots -> TL.Text
plainDocument doc = text (setStart doc def) doc

-- ** Type 'State'
data State
 =   State
 {   state_escape   :: Bool -- FIXME: useful?
 ,   state_pos      :: Pos
 ,   state_indent   :: TL.Text
 ,   state_unindent :: Int
     -- ^ useful to shift everything to the left
 } deriving (Eq, Show)
instance Default State where
	def = State
	 { state_escape   = True
	 , state_pos      = pos1
	 , state_indent   = ""
	 , state_unindent = 0
	 }

-- | Set the starting 'Pos' of given 'State'
-- by using the first 'cell_begin'.
setStart :: Roots -> State -> State
setStart ts st = st
	 { state_unindent = pos_column - 1
	 , state_pos      = pos1{pos_line}
	 }
	where
	Pos{..} =
		case Seq.viewl ts of
		 EmptyL -> pos1
		 Tree Cell{cell_begin} _ :< _ -> cell_begin

-- * Class 'Plainify'
class Plainify a where
	plainify :: a -> Plain
instance Plainify () where
	plainify = mempty
instance Plainify Char where
	plainify = \case
	 '\n' -> do
		S.modify' $ \s@State{state_pos=Pos line _col, state_indent} ->
			s{state_pos=Pos (line + 1) $ int $ TL.length state_indent + 1}
		State{..} <- S.get
		return $ TLB.singleton '\n' <> TLB.fromLazyText state_indent
	 c -> do
		S.modify' $ \s@State{state_pos=Pos line col} ->
			s{state_pos=Pos line (col + 1)}
		return $ TLB.singleton c
instance Plainify String where
	plainify = foldMap plainify
instance Plainify TL.Text where
	plainify t
	 | TL.null t = mempty
	 | otherwise =
		let (h,ts) = TL.span (/='\n') t in
		case TL.uncons ts of
		 Nothing -> do
			S.modify' $ \s@State{state_pos=Pos line col} ->
				s{state_pos=Pos line (col + int (TL.length h))}
			return $ TLB.fromLazyText h
		 Just (_n,ts') ->
			return (TLB.fromLazyText h) <>
			 -- NOTE: useless to increment the pos_column for h,
			 --       since the following '\n' will reset the pos_column.
			plainify '\n' <>
			plainify ts'
instance Plainify Pos where
	plainify new@(Pos lineNew colNew) = do
		State
		 { state_pos=old@(Pos lineOld colOld)
		 , state_indent
		 } <- S.get
		S.modify' $ \s -> s{state_pos=new}
		return $ TLB.fromLazyText $
			case lineNew`compare`lineOld of
			 GT -> lines <> state_indent <> hspaces
				where
				lines   = TL.replicate (int64 $ lineNew - lineOld) "\n"
				hspaces = TL.replicate (int64 (colNew - 1) - TL.length state_indent) " "
			 EQ | colNew >= colOld ->
				TL.replicate (int64 $ colNew - colOld) " "
			 _ -> error $ "plainify: non-ascending Pos:"
				 <> "\n old: " <> show old
				 <> "\n new: " <> show new
instance Plainify Roots where
	plainify = foldMap plainify
instance Plainify Root where
	plainify (Tree (Cell bp _ep nod) ts) =
		plainify bp <>
		case nod of
		 NodeGroup -> plainify ts
		--
		 NodeLower n as -> "<" <> plainify n <> plainify as <> plainify ts
		--
		 NodeHeader hdr ->
			case hdr of
			 HeaderGreat{} -> repeatHeader
			 HeaderBar{}   -> repeatHeader
			 _ -> plainify hdr <> plainify ts
			where
			repeatHeader = do
				State{..} <- S.get
				h <- plainify hdr
				S.modify' $ \s -> s{state_indent =
					state_indent <>
					TL.replicate (int64 (pos_column bp - 1) - TL.length state_indent) " " <>
					TLB.toLazyText h
				 }
				r <- plainify ts
				S.modify' $ \s -> s{state_indent}
				return $ h <> r
		--
		 NodeText t -> do
			State{..} <- S.get
			S.modify' $ \s -> s{state_indent =
				state_indent <>
				TL.replicate (int64 (pos_column bp - 1) - TL.length state_indent) " "
			 }
			r <- plainify t
			S.modify' $ \s -> s{state_indent}
			return r
		 {-
		 NodeText t -> plainify t
		 -}
		--
		 NodePara -> do
			State{..} <- S.get
			S.modify' $ \s -> s{state_indent =
				state_indent <>
				TL.replicate (int64 (pos_column bp - 1) - TL.length state_indent) " "
			 }
			r <- plainify ts
			S.modify' $ \s -> s{state_indent}
			return r
		--
		 NodeToken t -> plainify t <> plainify ts
		--
		 NodePair p ->
			plainify o <> plainify ts <> plainify c
			where (o,c) = pairBorders p ts
instance Plainify Header where
	plainify hdr =
		case hdr of
		 HeaderColon n wh  -> plainify n <> plainify wh <> ":"
		 HeaderGreat n wh  -> plainify n <> plainify wh <> ">"
		 HeaderEqual n wh  -> plainify n <> plainify wh <> "="
		 HeaderBar   n wh  -> plainify n <> plainify wh <> "|"
		 HeaderDot   n     -> plainify n <> "."
		 HeaderBrackets n  -> "[" <> plainify n <> "]"
		 HeaderDash        -> "- "
		 HeaderDashDash    -> "-- "
		 HeaderSection lvl -> plainify (List.replicate lvl '#')
		 HeaderDotSlash n  -> "./" <> plainify n
instance Plainify Token where
	plainify = \case
	 TokenText t -> plainify t
	 TokenTag  t -> plainify '#' <> plainify t
	 TokenLink l -> plainify l
	 TokenEscape c -> do
		esc <- S.gets state_escape
		if esc
		 then plainify ['\\', c]
		 else plainify c
instance Plainify ElemAttrs where
	plainify = foldMap plainify
instance Plainify (White,ElemAttr) where
	plainify (elemAttr_white,ElemAttr{..}) =
		mconcat $ plainify <$>
		 [ elemAttr_white
		 , elemAttr_name
		 , elemAttr_open
		 , elemAttr_value
		 , elemAttr_close
		 ]

{-
-- * 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
			 { pos_line   = pos_line   - l0 + 1
			 , pos_column = pos_column - 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 a => RackUpLeft (Tree a) where
	rackUpLeft (Tree n ts) =
		Tree
		 <$> rackUpLeft n
		 <*> rackUpLeft ts
-}