{-# 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 (Int)
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..), Ordering(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (Seq)
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 Language.TCT
import Language.TCT.Utils

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

plainDocument :: Roots -> TL.Text
plainDocument = text def

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

-- * 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) state_indent}
		indent <- S.gets state_indent
		return $ TLB.singleton '\n' <> fromString (List.replicate (indent - 1) ' ')
	 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
		old@(Pos lineOld colOld) <- S.gets state_pos
		S.modify $ \s -> s{state_pos=new}
		case lineOld`compare`lineNew of
		 LT ->
			return $
				fromString (List.replicate (lineNew - lineOld) '\n') <>
				fromString (List.replicate (colNew - 1) ' ')
		 EQ | colOld <= colNew ->
			return $
				fromString (List.replicate (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
		 NodePara -> do
			ind <- S.gets state_indent
			S.modify $ \s -> s{state_indent = pos_column bp}
			r <- plainify ts
			S.modify $ \s -> s{state_indent=ind}
			return r
		 NodeGroup -> plainify ts
		 NodeHeader h -> plainify h <> plainify ts
		 NodeToken t -> plainify t
		 NodeText t -> do
			ind <- S.gets state_indent
			S.modify $ \s -> s{state_indent = pos_column bp}
			r <- plainify t
			S.modify $ \s -> s{state_indent=ind}
			return r
		 NodePair p ->
			plainify o <> plainify ts <> plainify c
			where (o,c) | null ts   = pairBordersWithoutContent p
			            | otherwise = pairBorders p
		 NodeLower n as ->
			"<" <> plainify n <> plainify as <> plainify 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