{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hdoc.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.List.NonEmpty (NonEmpty(..))
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 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 Hdoc.TCT
import Hdoc.TCT.Utils
-- import Hdoc.TCT.Debug

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

-- * 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 $ S.evalState p s

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

-- ** Type 'State'
data State
 =   State
 {   state_escape   :: Bool
 ,   state_pos      :: Pos
     -- ^ current position,
     -- always in sync annotated 'Pos' of the input,
     -- not with the output (whose colmuns may be shifted left by 'state_unindent')
 ,   state_indent   :: TL.Text
     -- ^ indentation, which contain horizontal spaces,
     -- but also any repeated prefix introduced by 'HeaderBar' or 'HeaderGreat'
 ,   state_unindent :: Int
     -- ^ initial 'pos_column' set by 'setStart',
     -- 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 = 1
	 }

-- | Set the starting 'Pos' of given 'State'
-- by using the first 'cell_begin'.
setStart :: Roots -> State -> State
setStart ts st = st
	 { state_pos      = pos
	 , state_unindent = pos_column pos
	 }
	where pos =
		case Seq.viewl ts of
		 EmptyL -> pos1
		 Tree (Cell (Span{span_begin}:|_) _) _ :< _ -> span_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, state_unindent} ->
			s{state_pos=Pos (line + 1) $ state_unindent + int (TL.length state_indent)}
		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
		 , state_unindent
		 } <- 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 - state_unindent) - 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 (Span{span_begin=bp}:|_) nod) ts) =
		plainify bp <>
		case nod of
		----------------------
		 NodeLower n as -> "<" <> plainify n <> plainify as <> plainify ts
		----------------------
		 NodeHeader hdr ->
			case hdr of
			 HeaderGreat{}    -> plainHeaderRepeated
			 HeaderBar{}      -> plainHeaderRepeated
			 HeaderDotSlash{} -> plainify hdr
			 _ -> plainify hdr <> plainify ts
			where
			plainHeaderRepeated = do
				State{..} <- S.get
				h <- plainify hdr
				S.modify' $ \s -> s{state_indent =
					state_indent <>
					TL.replicate (int64 (pos_column bp - state_unindent) - 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 - state_unindent) - TL.length state_indent) " "
			 }
			r <- plainify t
			S.modify' $ \s -> s{state_indent}
			return r
		----------------------
		 NodePara -> do
			State{..} <- S.get
			S.modify' $ \s -> s{state_indent =
				state_indent <>
				TL.replicate (int64 (pos_column bp - state_unindent) - 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
-}