{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Render a TCT file in DTC.
module Language.TCT.Write.DTC where

import Control.Applicative (Applicative(..))
import Control.Arrow (first)
import Control.Monad (Monad(..), (=<<), mapM, sequence_)
import Data.Bool
import Data.Eq (Eq(..))
import Data.Foldable (foldr, null, foldl', any)
import Data.Function (($), (.), flip, id)
import Data.Functor ((<$>))
import Data.Map.Strict (Map)
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (ViewL(..), ViewR(..), (<|), (|>))
import Data.String (String)
import Data.Text (Text)
import GHC.Exts (toList)
import Text.Blaze ((!))
import Text.Show (Show(..))
import qualified Control.Monad.Trans.State as S
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
import qualified System.FilePath as FP
import qualified Text.Blaze as B
import qualified Text.Blaze.Internal as B

import Language.TCT.Elem hiding (trac,dbg)
import Language.TCT.Token
import Language.TCT.Tree
import Text.Blaze.DTC (DTC)
import Text.Blaze.Utils
import qualified Language.TCT.Write.Text as Write
import qualified Text.Blaze.DTC as D
import qualified Text.Blaze.DTC.Attributes as DA

-- import Debug.Trace (trace)
trac :: String -> a -> a
trac _m x = x
-- trac m x = trace m x
dbg :: Show a => String -> a -> a
dbg m x = trac (m <> ": " <> show x) x

-- * Type 'Inh_DTC'
data Inh_DTC
 =   Inh_DTC
 {   inh_dtc_figure :: Bool
 ,   inh_dtc_tree0  :: [(DTC -> DTC)]
 }
inh_dtc :: Inh_DTC
inh_dtc = Inh_DTC
 { inh_dtc_figure = False
 , inh_dtc_tree0  = []
 }

-- * Type 'Chan_DTC'
data Chan_DTC
 =   Chan_DTC
 {   chan_dtc_tree0 :: [(DTC -> DTC)]
 }
chan_dtc :: Chan_DTC
chan_dtc =
	Chan_DTC
	 { chan_dtc_tree0 = []
	 }

mimetype :: Text -> Maybe Text
mimetype "sh"          = Just "text/x-shellscript"
mimetype "shell"       = Just "text/x-shellscript"
mimetype "shellscript" = Just "text/x-shellscript"
mimetype _             = Nothing

(<>=) :: (Monad m, Semigroup a) => m a -> m a -> m a
(<>=) m n = (<>) <$> m <*> n
infixl 1 <>=

dtc :: Trees Key Tokens -> DTC
dtc ts = do
	let lang = "fr"
	D.xmlModel "./schema/dtc.rnc"
	D.xmlStylesheet   $ "./xsl/document.html5."<>lang<>".xsl"
	D.html5Stylesheet $ "./xsl/document.html5."<>lang<>".xsl"
	D.atomStylesheet  $ "./xsl/document.atom."<>lang<>".xsl"
	D.document $
		(`S.evalState` chan_dtc) $
		case Seq.viewl ts of
		 TreeN KeySection{} (spanlTree0 -> (title, head)) :< body ->
			d_Trees inh_dtc (mangleHead title head) <>=
			d_Trees inh_dtc{inh_dtc_figure = True} body
		 _ -> d_Trees inh_dtc{inh_dtc_figure = True} ts
	where
	mangleHead ::
	 Trees Key Tokens ->
	 Trees Key Tokens ->
	 Trees Key Tokens
	mangleHead title head =
		let mi =
			(`Seq.findIndexL` head) $ \case
			 TreeN (KeyColon "about" _) _ -> True
			 _ -> False in
		case mi of
		 Nothing -> TreeN (KeyColon "about" "") title <| head
		 Just i -> Seq.adjust f i head
			where
			f (TreeN c about) = TreeN c $ title <> about
			f t = t

d_Trees :: Inh_DTC -> Trees Key Tokens -> S.State Chan_DTC DTC
d_Trees inh_orig = go inh_orig
	where
	go inh trs =
		case Seq.viewl trs of
		 TreeN (KeyBar n _) _ :< _
		  | (body,ts) <- spanlBar n trs
		  , not (null body) ->
			((D.artwork !?? (mimetype n, DA.type_ . attrValue)) . sequence_ <$>
				d_Tree inh{inh_dtc_tree0=[]} `mapM` body) <>=
			go inh ts
		
		 TreeN KeyBrackets{} _ :< _
		  | (refs,ts) <- spanlBrackets trs
		  , not (null refs) ->
			(D.references . sequence_ <$> d_Tree inh_orig `mapM` refs) <>=
			go inh ts
		
		 TreeN key@(KeyColon n _) cs :< ts
		  | (cs',ts') <- spanlKeyName n ts
		  , not (null cs') ->
			go inh $ TreeN key (cs<>cs') <| ts'
		
		 _ | (ul,ts) <- spanlItems (==KeyDash) trs
		   , not (null ul) ->
			((D.ul ! DA.style "format —") . sequence_ <$> d_Tree inh_orig `mapM` ul) <>=
			go inh ts
		
		 _ | (ol,ts) <- spanlItems (\case KeyDot{} -> True; _ -> False) trs
		   , not (null ol) ->
			(D.ol . sequence_ <$> d_Tree inh_orig `mapM` ol) <>=
			go inh ts
		
		 t@(Tree0 toks) :< ts | isTokenElem toks ->
			d_Tree inh_orig t <>=
			go inh ts
		 t@Tree0{} :< ts ->
			case inh_dtc_tree0 inh of
			 [] ->
				d_Tree inh_orig t <>=
				go inh{inh_dtc_tree0=[]} ts
			 d:ds ->
				(d <$> d_Tree inh_orig t) <>=
				go inh{inh_dtc_tree0=ds} ts
		
		 t:<ts ->
			d_Tree inh_orig t <>=
			go inh ts
		
		 _ -> return $ return ()

d_Tree :: Inh_DTC -> Tree Key Tokens -> S.State Chan_DTC DTC
d_Tree inh tr =
	case tr of
	 TreeN KeySection{} ts -> do
		let (attrs,body) = partitionAttributesChildren ts
		let inh' = inh{inh_dtc_tree0 = D.name : List.repeat D.para}
		d_Attributes (setAttrId (getAttrId body) attrs) . D.section <$>
			d_Trees inh' body
	 TreeN key@(KeyColon kn _) ts -> do
		let (attrs,body) = partitionAttributesChildren ts
		let inh' = inh{inh_dtc_tree0 =
			case kn of
			 "about"     -> D.name : D.name : List.repeat D.para
			 "reference" -> D.name : D.name : List.repeat D.para
			 "author"    -> List.repeat D.name
			 _           -> []
		 }
		if inh_dtc_figure inh && not (kn`List.elem`D.elems)
		then
			d_Attributes attrs . (D.figure ! DA.type_ (attrValue kn)) <$>
			case toList body of
			 [Tree0{}] -> d_Trees inh'{inh_dtc_tree0 = List.repeat D.para} body
			 _         -> d_Trees inh'{inh_dtc_tree0 = D.name : List.repeat D.para} body
		else d_Attributes attrs <$> d_Key inh' key body
	 TreeN key ts -> d_Key inh key ts
	 Tree0 ts -> return $ d_Tokens ts

d_Key :: Inh_DTC -> Key -> Trees Key Tokens -> S.State Chan_DTC DTC
d_Key inh key ts =
	case key of
	 KeyColon n _wh -> d_key n
	 KeyGreat n _wh -> d_key n
	 KeyEqual n _wh -> d_key n
	 KeyBar   n _wh -> d_key n
	 KeyDot _n -> D.li <$> d_Trees inh ts
	 KeyDash   -> D.li <$> d_Trees inh ts
	 KeyDashDash -> return $ B.Comment (B.Text $ TL.toStrict com) ()
		where com =
			Write.text Write.config_text $
			mapTreeKey cell1 (\_path -> cell1) <$> ts
	 KeyLower n as -> do
		S.modify $ \chan -> chan{chan_dtc_tree0=[]}
		D.artwork <$> d_Trees inh ts
	 KeyBrackets ident -> do
		let (attrs,body) = partitionAttributesChildren ts
		let inh' = inh{inh_dtc_figure = False}
		S.modify $ \chan -> chan{chan_dtc_tree0 =
			D.name : D.name : List.repeat D.para
		 }
		d_Attributes (setAttrId ident attrs) .
		 D.reference <$> d_Trees inh' body
	 KeyDotSlash p ->
		return (D.include True $ attrValue $ FP.replaceExtension p "dtc") <>=
		d_Trees inh ts
	where
	d_key :: Text -> S.State Chan_DTC DTC
	d_key n | null ts = return $ B.CustomLeaf (B.Text n) True mempty
	d_key n           = B.CustomParent (B.Text n) <$> d_Trees inh ts

d_Tokens :: Tokens -> DTC
d_Tokens tok = goTokens tok
	where
	go :: Token -> DTC
	go (TokenPlain t)  = B.toMarkup t
	go (TokenTag t)    = D.ref mempty ! DA.to (attrValue t)
	go (TokenEscape c) = B.toMarkup c
	go (TokenLink lnk) = D.eref (B.toMarkup lnk) ! DA.to (attrValue lnk)
	go (TokenPair PairBracket ts)
	 | to <- Write.t_Tokens ts
	 , TL.all (\c -> Char.isAlphaNum c || Char.isSymbol c) to =
		D.rref ! DA.to (attrValue $ TL.toStrict to) $ mempty
	go (TokenPair PairStar ts)        = D.b $ goTokens ts
	go (TokenPair PairSlash ts)       = D.i $ goTokens ts
	go (TokenPair PairBackquote ts)   = D.code $ goTokens ts
	go (TokenPair PairFrenchquote toks@(Tokens ts)) =
		D.q $
		case ts of
		 (Seq.viewl -> TokenPlain l :< ls) ->
			case Seq.viewr ls of
			 m :> TokenPlain r ->
				goTokens $ Tokens $
					TokenPlain (Text.dropWhile Char.isSpace l)
					 <|(m|>TokenPlain (Text.dropWhileEnd Char.isSpace r))
			 _ ->
				goTokens $ Tokens $
					TokenPlain (Text.dropAround Char.isSpace l) <| ls
		 (Seq.viewr -> rs :> TokenPlain r) ->
			goTokens $ Tokens $
				rs |> TokenPlain (Text.dropAround Char.isSpace r)
		 _ -> goTokens toks
	go (TokenPair PairHash (toList -> [TokenPlain ts])) =
		D.ref mempty ! DA.to (attrValue ts)
	go (TokenPair (PairElem name attrs) ts) =
		d_Attrs attrs $
		case ts of
		 Tokens s | null s ->
			B.CustomLeaf (B.Text name) True mempty
		 _ -> B.CustomParent (B.Text name) $ goTokens ts
	go (TokenPair p ts) = do
		let (o,c) = pairBorders p ts
		B.toMarkup o
		goTokens ts
		B.toMarkup c
	
	goTokens :: Tokens -> DTC
	goTokens (Tokens toks) =
		case Seq.viewl toks of
		 TokenPair PairParen b :< (Seq.viewl -> TokenPair PairBracket p :< ts) -> do
			case p of
			 Tokens (toList -> [TokenLink lnk]) ->
				D.eref ! DA.to (attrValue lnk) $ goTokens b
			 _ -> D.rref ! DA.to (attrValue $ TL.toStrict $ Write.t_Tokens p) $ goTokens b
			goTokens (Tokens ts)
		 t :< ts -> go t <> goTokens (Tokens ts)
		 Seq.EmptyL -> mempty

spanlTree0 :: Trees Key Tokens -> (Trees Key Tokens, Trees Key Tokens)
spanlTree0 =
	Seq.spanl $ \case
	 Tree0{} -> True
	 _ -> False

spanlBar :: Name -> Trees Key Tokens -> (Trees Key Tokens, Trees Key Tokens)
spanlBar name = first unKeyBar . spanBar
	where
	unKeyBar :: Trees Key Tokens -> Trees Key Tokens
	unKeyBar = (=<<) $ \case
		 TreeN KeyBar{} ts -> ts
		 _ -> mempty
	spanBar =
		Seq.spanl $ \case
		 TreeN (KeyBar n _) _ | n == name -> True
		 _ -> False

spanlKeyName :: Name -> Trees Key Tokens -> (Trees Key Tokens, Trees Key Tokens)
spanlKeyName name =
	Seq.spanl $ \case
	 TreeN (KeyBar   n _) _ -> n == name
	 TreeN (KeyGreat n _) _ -> n == name
	 _ -> False

spanlBrackets :: Trees Key Tokens -> (Trees Key Tokens, Trees Key Tokens)
spanlBrackets =
	Seq.spanl $ \case
	 TreeN KeyBrackets{} _ -> True
	 _ -> False

spanlItems ::
 (Key -> Bool) ->
 Trees Key Tokens ->
 (Trees Key Tokens, Trees Key Tokens)
spanlItems liKey ts =
	let (lis, ts') = spanLIs ts in
	foldl' accumLIs (mempty,ts') lis
	where
	spanLIs = Seq.spanl $ \case
		 TreeN (liKey -> True) _ -> True
		 Tree0 (Tokens toks) ->
			(`any` toks) $ \case
			 TokenPair (PairElem "li" _) _ -> True
			 _ -> False
		 _ -> False
	accumLIs acc@(oks,kos) t =
		case t of
		 TreeN (liKey -> True) _ -> (oks|>t,kos)
		 Tree0 (Tokens toks) ->
			let mk = Tree0 . Tokens in
			let (ok,ko) =
				(`Seq.spanl` toks) $ \case
				 TokenPair (PairElem "li" _) _ -> True
				 TokenPlain txt -> Char.isSpace`Text.all`txt
				 _ -> False in
			( if null ok then oks else oks|>mk (rmTokenPlain ok)
			, if null ko then kos else mk ko<|kos )
		 _ -> acc
	rmTokenPlain =
		Seq.filter $ \case
		 TokenPlain{} -> False
		 _ -> True

getAttrId :: Trees Key Tokens -> (Text)
getAttrId ts =
	case Seq.index ts <$> Seq.findIndexL isTree0 ts of
	 Just (Tree0 toks) -> TL.toStrict $ Write.t_Tokens toks
	 _ -> ""
	where

setAttrId :: Text -> Attributes -> Attributes
setAttrId ident | Text.null ident = id
setAttrId ident = Map.insertWith (\_new old -> old) "id" ident

d_Attrs :: Attrs -> DTC -> DTC
d_Attrs = flip $ foldl' d_Attr

d_Attr :: DTC -> (Text,Attr) -> DTC
d_Attr acc (_,Attr{..}) =
	B.AddCustomAttribute
	 (B.Text attr_name)
	 (B.Text attr_value)
	 acc

-- * Type 'Attributes'
type Attributes = Map Name Text

d_Attributes :: Attributes -> DTC -> DTC
d_Attributes = flip $ Map.foldrWithKey $ \n v ->
	B.AddCustomAttribute (B.Text n) (B.Text v)

partitionAttributesChildren ::
 Trees Key Tokens ->
 (Attributes, Trees Key Tokens)
partitionAttributesChildren ts = (attrs,children)
	where
	attrs :: Attributes
	attrs =
		foldr (\t acc ->
			case t of
			 Tree0{} -> acc
			 TreeN (KeyEqual n _wh) a -> Map.insert n v acc
				where
				v = TL.toStrict $
					Write.text Write.config_text{Write.config_text_escape = False} $
					mapTreeKey cell1 (\_path -> cell1) <$> a
					-- Write.treeRackUpLeft <$> a
			 TreeN{} -> acc
		 ) mempty ts
	children = Seq.filter (\t ->
		case t of
		 Tree0{} -> True
		 TreeN KeyEqual{} _cs -> False
		 TreeN{} -> True
		 ) ts