{-# 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.Monad (forM_, when)
import Data.Bool
import Data.Foldable (Foldable(..))
import Data.Function (($), (.), flip)
import Data.Functor ((<$>))
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (Seq, ViewL(..))
import Data.String (String)
import Data.Text (Text)
import Text.Blaze ((!))
import Text.Show (Show(..))
import qualified Data.Sequence as Seq
import qualified Data.Text as Text
import qualified Text.Blaze as B
import qualified Text.Blaze.Internal as B
import qualified Data.Text.Lazy as TL

import Language.TCT.Tree
import Language.TCT.Token
import Language.TCT.Elem hiding (trac,dbg)
import qualified Language.TCT.Write.Text as Write
import Text.Blaze.Utils
import Text.Blaze.DTC (DTC)
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

dtc :: Trees (Cell Key) (Cell Tokens) -> DTC
dtc tct = 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 $
		forM_ tct $ d_TreeCell []

d_TreeCell :: [Key] -> Tree (Cell Key) (Cell Tokens) -> DTC
d_TreeCell path (TreeN (unCell -> key@KeySection{}) ts) =
	let (attrs,children) = partitionAttributesChildren ts in
	let d_content =
		forM_ (case Seq.viewl children of {Tree0{} :< ts' -> ts'; _ -> children}) $
			d_TreeCell (key:path) in
	(\acc -> foldr (\(n,v) -> B.AddCustomAttribute (B.Text n) (B.Text v)) acc attrs) $
	case Seq.viewl children of
	 Tree0 (Cell _posTitle _ (toList . unTokens -> [TokenPlain title])) :< _ ->
		case Text.splitOn "\n" title of
		 t0:t1 ->
			D.section ! DA.name (attrValue t0) $ do
				let st = Text.intercalate "\n" t1
				when (not (Text.null st)) $
					D.name $ B.toMarkup st
				d_content
		 [] ->
			D.section ! DA.name (attrValue title) $
				d_content
	 Tree0 (Cell _posTitle _ title) :< _ ->
		D.section $ do
			D.name $ d_Tokens (key:path) title
			d_content
	 _ -> D.section d_content
d_TreeCell path (Tree0 cell) = d_CellTokens path cell
d_TreeCell path (TreeN cell@(unCell -> KeyColon{}) ts) =
	let (attrs,children) = partitionAttributesChildren ts in
	foldr (\(n,v) -> B.AddCustomAttribute (B.Text n) (B.Text v))
	 (d_CellKey path cell children)
	 attrs
d_TreeCell path (TreeN cell ts) = d_CellKey path cell ts

partitionAttributesChildren :: Seq (Tree (Cell Key) (Cell Tokens)) -> ([(Name,Text)],Seq (Tree (Cell Key) (Cell Tokens)))
partitionAttributesChildren ts = (attrs,children)
	where
	attrs :: [(Name,Text)]
	attrs =
		foldr (\t acc ->
			case t of
			 Tree0{} -> acc
			 TreeN (unCell -> KeyEqual n _wh) a -> (n,v):acc
				where
				v = TL.toStrict $
					Write.text Write.config_text{Write.config_text_escape = False} $
					Write.treeRackUpLeft <$> a
			 TreeN{} -> acc
		 ) [] ts
	children = Seq.filter (\t ->
		case t of
		 Tree0{} -> True
		 TreeN (unCell -> KeyEqual{}) _cs -> False
		 TreeN{} -> True
		 ) ts

d_CellKey :: [Key] -> Cell Key -> Trees (Cell Key) (Cell Tokens) -> DTC
d_CellKey path (Cell _pos _posEnd key) cells = do
	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
	 KeyDash -> do
		B.toMarkup ("- "::Text)
		forM_ cells $ d_TreeCell (key:path)
	 {-
	 KeyLower name attrs -> do
		B.Content $ "<"<>B.toMarkup name
		d_Attrs attrs
		forM_ cells $ d_TreeCell path
	 -}
	where
	d_Key :: Text -> DTC
	d_Key name | null cells =
		B.CustomLeaf (B.Text name) True mempty
	d_Key name =
		B.CustomParent (B.Text name) $
			forM_ cells $ d_TreeCell (key:path)

d_CellTokens :: [Key] -> Cell Tokens -> DTC
d_CellTokens path (Cell _pos _posEnd ts) =
	-- case L.find (\case KeySection{} -> True; _ -> False) $ dbg "d_CellTokens: path:" path of
	case dbg "d_CellTokens: path" path of
	 KeySection{}:_ ->
		case ts of
		 _ | [TokenPair PairElem{} _ts] <- toList (unTokens ts) -> d_Tokens path ts
		 _ -> D.para $ d_Tokens path ts
	 _ -> d_Tokens path ts

d_Tokens :: [Key] -> Tokens -> DTC
d_Tokens _path tok = goTokens tok
	where
	-- indent = Text.replicate (columnPos pos - 1) " "
	go :: Token -> DTC
	go (TokenPlain txt) = B.toMarkup txt
	go (TokenTag v) = D.ref mempty ! DA.to (attrValue v)
	go (TokenEscape c) = B.toMarkup c
	go (TokenLink lnk) = D.eref (B.toMarkup lnk) ! DA.to (attrValue lnk)
	go (TokenPair PairSlash ts) = D.i $ goTokens ts
	go (TokenPair PairBackquote ts) = D.code $ goTokens ts
	go (TokenPair PairFrenchquote ts) = D.q $ goTokens ts
	go (TokenPair PairHash (toList . unTokens -> [TokenPlain ts])) =
		D.ref mempty ! DA.to (attrValue ts)
	go (TokenPair (PairElem name attrs) ts) =
		d_Attrs attrs $
		case ts of
		 Tokens s | Seq.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 ts) = foldMap go ts

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