{-# 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(..), 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 Language.Symantic.XML as XML

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      :: FilePos
     -- ^ current position,
     -- always in sync annotated 'FilePos' 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 'filePos_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 'FilePos' of given 'State'
-- by using the first 'cell_begin'.
setStart :: Roots -> State -> State
setStart ts st = st
	 { state_pos      = pos
	 , state_unindent = filePos_column pos
	 }
	where pos =
		case Seq.viewl ts of
		 EmptyL -> pos1
		 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=FilePos line _col, state_indent, state_unindent} ->
			s{state_pos=FilePos (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=FilePos line col} ->
			s{state_pos=FilePos 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=FilePos line col} ->
				s{state_pos=FilePos line $ col + int (TL.length h)}
			return $ TLB.fromLazyText h
		 Just (_n,ts') ->
			return (TLB.fromLazyText h) <>
			 -- NOTE: useless to increment the filePos_column for h,
			 --       since the following '\n' will reset the filePos_column.
			plainify '\n' <>
			plainify ts'
instance Plainify FilePos where
	plainify new@(FilePos lineNew colNew) = do
		State
		 { state_pos=old@(FilePos 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 FilePos:"
				 <> "\n old: " <> show old
				 <> "\n new: " <> show 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 (filePos_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 (filePos_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 (filePos_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
	 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 FilePos) a
instance RackUpLeft FilePos where
	rackUpLeft pos@FilePos{..} = do
		S.get >>= \case
		 Nothing -> return pos
		 Just (FilePos l0 c0) ->
			return FilePos
			 { filePos_line   = filePos_line   - l0 + 1
			 , filePos_column = filePos_column - 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
-}