{-# 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.Eq (Eq(..))
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 as Text
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 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 $
		case Seq.viewl ts of
		 TreeN KeySection{}
		       (Seq.viewl -> Tree0 (Write.t_Tokens -> TL.toStrict -> title) :< head)
		       :< body -> do
			d_Trees [] (mangleHead title head)
			d_Trees [] body
		 _ ->
			d_Trees [] ts
	where
	mangleHead ::
	 Text ->
	 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" "")
			      (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 <$> Text.splitOn "\n" title
		name =
			TreeN (KeyColon "name" "") .
			Seq.singleton . Tree0 . Tokens .
			Seq.singleton . TokenPlain

d_Trees :: [Key] -> Trees Key Tokens -> DTC
d_Trees path ts =
	case () of
	 _ | (ul,ts') <- gatherLI (==KeyDash) ts, not (null ul) -> do
		D.ul $ forM_ ul $ d_Tree path
		d_Trees path ts'
	 _ | (ol,ts') <- gatherLI (\case KeyDot{} -> True; _ -> False) 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 ()

gatherLI ::
 (Key -> Bool) ->
 Trees Key Tokens ->
 (Trees Key Tokens, Trees Key Tokens)
gatherLI 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

d_Tree :: [Key] -> Tree Key Tokens -> DTC
d_Tree path (TreeN key@KeySection{} ts) =
	case Seq.viewl children of
	 Tree0 (toList -> [TokenPlain title]) :< body ->
		d_attrs (mangleAttrs title attrs) $
		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 body
		 [] ->
			D.section ! DA.name (attrValue title) $
				d_content body
	 Tree0 title :< body ->
		d_attrs (mangleAttrs (TL.toStrict $ 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 :: Text -> Attributes -> Attributes
	mangleAttrs title = Map.insertWith (\_new old -> old) "id" title
d_Tree path (Tree0 ts) =
	case 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_Tree path (TreeN cell@KeyColon{} ts) =
	let (attrs,children) = partitionAttributesChildren ts in
	d_attrs attrs $ d_Key path cell children
d_Tree path (TreeN cell ts) = d_Key path cell ts

d_Key :: [Key] -> Key -> Trees Key Tokens -> DTC
d_Key path key ts = 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) ts
	 KeyDash   -> D.li $ d_Trees (key:path) ts
	 KeyDashDash -> B.Comment (B.Text $ TL.toStrict com) ()
		where com =
			Write.text Write.config_text $
			mapTreeKey cell1 (\_path -> cell1) <$> ts
	 KeyLower n as -> D.artwork $ d_Trees (key:path) ts
	where
	d_key :: Text -> DTC
	d_key name | null ts =
		B.CustomLeaf (B.Text name) True mempty
	d_key name =
		B.CustomParent (B.Text name) $
			d_Trees (key: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 Text

d_attrs :: Attributes -> DTC -> DTC
d_attrs = 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