{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Textphile.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(..), 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.Sequence as Seq
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
import qualified Symantic.XML as XML
import qualified Text.Megaparsec as P

import Textphile.TCT
import Textphile.TCT.Utils
-- import Textphile.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      :: LineColumn
     -- ^ current position,
     -- always in sync with annotated 'LineColumn' 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 'colNum' set by 'setStart',
     -- useful to shift everything to the left
 } deriving (Eq, Show)
instance Default State where
	def = State
	 { state_escape   = True
	 , state_pos      = def
	 , state_indent   = ""
	 , state_unindent = 1
	 }

-- | Set the starting 'LineColumn' of given 'State'
-- by using the first 'cell_begin'.
setStart :: Roots -> State -> State
setStart ts st = st
	 { state_pos      = pos
	 , state_unindent = colInt pos
	 }
	where pos =
		case Seq.viewl ts of
		 EmptyL -> def
		 Tree (Sourced (FileRange{fileRange_begin}:|_) _) _ :< _ -> fileRange_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=LineColumn line _col, state_indent, state_unindent} ->
			s{state_pos=LineColumn (line <> P.pos1) $ P.mkPos $ 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=LineColumn line col} ->
			s{state_pos=LineColumn line (col <> P.pos1)}
		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=LineColumn line col} ->
				s{state_pos=LineColumn line $ col <> P.mkPos (int (TL.length h))}
			return $ TLB.fromLazyText h
		 Just (_n,ts') ->
			return (TLB.fromLazyText h) <>
			 -- NOTE: useless to increment the 'colNum' for h,
			 --       since the following '\n' will reset the 'colNum'.
			plainify '\n' <>
			plainify ts'
instance Plainify LineColumn where
	plainify new = do
		State
		 { state_pos=old
		 , state_indent
		 , state_unindent
		 } <- S.get
		let lineOld = lineInt old
		let colOld  = colInt  old
		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 LineColumn:"
				 <> "\n old: " <> show old
				 <> "\n new: " <> show new
		where
		lineNew = lineInt new
		colNew  = colInt  new
instance Plainify Roots where
	plainify = foldMap plainify
instance Plainify Root where
	plainify (Tree (Sourced (FileRange{fileRange_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 (colInt 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 (colInt 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 (colInt 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
	 TokenAt  b r -> (if b then plainify '~' else mempty) <> plainify '@' <> plainify r
	 TokenTag b r -> (if b then plainify '~' else mempty) <> plainify '#' <> plainify r
	 TokenLink l -> plainify l
	 TokenEscape c -> do
		esc <- S.gets state_escape
		if esc
		 then plainify ['\\', c]
		 else plainify c
instance Plainify ElemName where
	plainify (XML.NCName n) = plainify n
instance Plainify (Maybe ElemName) where
	plainify = maybe mempty plainify
instance Plainify ElemAttrs where
	plainify = foldMap plainify
instance Plainify (White,ElemAttr) where
	plainify (elemAttr_white,ElemAttr{..}) =
		mconcat $ plainify <$>
		 [ elemAttr_white
		 , XML.unNCName elemAttr_name
		 , elemAttr_open
		 , elemAttr_value
		 , elemAttr_close
		 ]

{-
-- * Class 'RackUpLeft'
class RackUpLeft a where
	rackUpLeft :: a -> S.State (Maybe LineColumn) a
instance RackUpLeft LineColumn where
	rackUpLeft pos@LineColumn{..} = do
		S.get >>= \case
		 Nothing -> return pos
		 Just (LineColumn l0 c0) ->
			return LineColumn
			 { lineNum = lineNum - l0 + 1
			 , colNum  = colNum  - c0 + 1
			 }
instance RackUpLeft (Sourced a) where
	rackUpLeft (Sourced bp ep a) = do
		S.modify' $ \case
		 Nothing -> Just bp
		 p -> p
		Sourced
		 <$> 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
-}