{-# 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 (Monad(..), forM_, when)
import Data.Bool
import Data.Foldable (foldr, null, foldMap, foldl', any)
import Data.Function (($), (.), flip)
import Data.Functor ((<$>))
import Data.Map.Strict (Map)
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (ViewL(..), (<|), (|>))
import Data.String (String)
import Data.Text (Text)
import GHC.Exts (toList)
import Text.Blaze ((!))
import Text.Show (Show(..))
import qualified Data.Char as Char
import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq
import qualified Data.Text.Lazy as TL
import qualified Text.Blaze as B
import qualified Text.Blaze.Internal as B

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 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 $
		case Seq.viewl ts of
		 TreeN (unCell -> KeySection{})
		       (Seq.viewl -> Tree0 (unCell -> Write.t_Tokens -> title) :< head)
		       :< body -> do
			d_Trees [] (mangleHead title head)
			d_Trees [] body
		 _ ->
			d_Trees [] ts
	where
	mangleHead ::
	 TL.Text ->
	 Trees (Cell Key) (Cell Tokens) ->
	 Trees (Cell Key) (Cell Tokens)
	mangleHead title head =
		let mi =
			(`Seq.findIndexL` head) $ \case
			 TreeN (unCell -> KeyColon "about" _) _ -> True
			 _ -> False in
		case mi of
		 Nothing ->
			TreeN (cell0 (KeyColon "about" ""))
			      (Seq.fromList names)
			<| head
		 Just i -> Seq.adjust f i head
			where
			f (TreeN c about) = TreeN c $ Seq.fromList names <> about
			f t = t
		where
		names = name <$> TL.splitOn "\n" title
		name =
			TreeN (cell0 (KeyColon "name" "")) .
			Seq.singleton .
			Tree0 . cell0 .
			Tokens . Seq.singleton . TokenPlain

d_Trees :: [Key] -> Trees (Cell Key) (Cell Tokens) -> DTC
d_Trees path ts =
	case () of
	 _ | (ul,ts') <- gatherUL ts, not (null ul) -> do
		D.ul $ forM_ ul $ d_Tree path
		d_Trees path ts'
	 _ | (ol,ts') <- gatherOL ts, not (null ol) -> do
		D.ol $ forM_ ol $ d_Tree path
		d_Trees path ts'
	 _ | t:<ts' <- Seq.viewl ts -> do
		d_Tree path t
		d_Trees path ts'
	 _ ->
		return ()

gatherUL ::
 Trees (Cell Key) (Cell Tokens) ->
 ( Trees (Cell Key) (Cell Tokens)
 , Trees (Cell Key) (Cell Tokens) )
gatherUL ts =
	let (lis, ts') = spanLIs ts in
	foldl' accumLIs (mempty,ts') lis
	where
	spanLIs = Seq.spanl $ \case
		 TreeN (unCell -> KeyDash) _ -> True
		 Tree0 (unCell -> Tokens toks) ->
			(`any` toks) $ \case
			 TokenPair (PairElem "li" _) _ -> True
			 _ -> False
		 _ -> False
	accumLIs acc@(oks,kos) t =
		case t of
		 TreeN (unCell -> KeyDash) _ -> (oks|>t,kos)
		 Tree0 (Cell pos posEnd (Tokens toks)) ->
			let mk = Tree0 . Cell pos posEnd . Tokens in
			let (ok,ko) =
				(`Seq.spanl` toks) $ \case
				 TokenPair (PairElem "li" _) _ -> True
				 TokenPlain txt -> Char.isSpace`TL.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

gatherOL ::
 Trees (Cell Key) (Cell Tokens) ->
 ( Trees (Cell Key) (Cell Tokens)
 , Trees (Cell Key) (Cell Tokens) )
gatherOL ts =
	let (lis, ts') = spanLIs ts in
	foldl' accumLIs (mempty,ts') lis
	where
	spanLIs = Seq.spanl $ \case
		 TreeN (unCell -> KeyDot{}) _ -> True
		 Tree0 (unCell -> Tokens toks) ->
			(`any` toks) $ \case
			 TokenPair (PairElem "li" _) _ -> True
			 _ -> False
		 _ -> False
	accumLIs acc@(oks,kos) t =
		case t of
		 TreeN (unCell -> KeyDot{}) _ -> (oks|>t,kos)
		 Tree0 (Cell pos posEnd (Tokens toks)) ->
			let mk = Tree0 . Cell pos posEnd . Tokens in
			let (ok,ko) =
				(`Seq.spanl` toks) $ \case
				 TokenPair (PairElem "li" _) _ -> True
				 TokenPlain txt -> Char.isSpace`TL.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

d_Tree :: [Key] -> Tree (Cell Key) (Cell Tokens) -> DTC
d_Tree path (TreeN (unCell -> key@KeySection{}) ts) =
	case Seq.viewl children of
	 Tree0 (Cell _posTitle _ (toList -> [TokenPlain title])) :< body ->
		d_attrs (mangleAttrs title attrs) $
		case TL.splitOn "\n" title of
		 t0:t1 ->
			D.section ! DA.name (attrValue t0) $ do
				let st = TL.intercalate "\n" t1
				when (not (TL.null st)) $
					D.name $ B.toMarkup st
				d_content body
		 [] ->
			D.section ! DA.name (attrValue title) $
				d_content body
	 Tree0 (Cell _posTitle _ title) :< body ->
		d_attrs (mangleAttrs (Write.t_Tokens title) attrs) $
		D.section $ do
			D.name $ d_Tokens (key:path) title
			d_content body
	 _ ->
		d_attrs attrs $
		D.section $ d_content children
	where
	(attrs,children) = partitionAttributesChildren ts
	d_content cs     = d_Trees (key:path) cs
	mangleAttrs :: TL.Text -> Attributes -> Attributes
	mangleAttrs title = Map.insertWith (\_new old -> old) "id" title
d_Tree path (Tree0 cell) = d_CellTokens path cell
d_Tree path (TreeN cell@(unCell -> KeyColon{}) ts) =
	let (attrs,children) = partitionAttributesChildren ts in
	d_attrs attrs $ d_CellKey path cell children
d_Tree path (TreeN cell ts) = d_CellKey path cell 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
	 KeyDot _n -> D.li $ d_Trees (key:path) cells
	 KeyDash   -> D.li $ d_Trees (key:path) cells
	 {-
	 KeyLower name attrs -> do
		B.Content $ "<"<>B.toMarkup name
		d_Attrs attrs
		forM_ cells $ d_Tree 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) $
			d_Trees (key:path) cells

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
	 [] ->
		case ts of
		 (toList -> [TokenPair PairElem{} _ts]) -> d_Tokens path ts
		 _ -> D.para $ d_Tokens path ts
	 KeySection{}:_ ->
		case ts of
		 (toList -> [TokenPair PairElem{} _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 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 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 -> [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

-- attr_id :: Text -> [(Text,Text)] -> [(Text,Text)]
-- attr_id title = ("id",title)

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

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

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