{-# 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.Arrow (first)
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, id)
import Data.Functor (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 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

-- * Type 'Inh_DTC'
data Inh_DTC
 =   Inh_DTC
 {   inh_dtc_para   :: DTC -> DTC
 ,   inh_dtc_figure :: Bool
 }
inh_dtc :: Inh_DTC
inh_dtc = Inh_DTC
 { inh_dtc_para   = id
 , inh_dtc_figure = False
 }

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

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 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 ::
	 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 .
			tokens1 . TokenPlain

d_Trees :: Inh_DTC -> Trees Key Tokens -> DTC
d_Trees inh ts =
	case Seq.viewl ts of
	 TreeN (KeyBar n _) _ :< _
	  | (content,ts') <- gatherBar n ts -> do
		D.artwork !?? (mimetype n, DA.type_ . attrValue) $
			d_Trees inh{inh_dtc_para=id} content
		d_Trees inh ts'
	
	 TreeN key@(KeyColon n _) cs :< ts'
	  | (cs',ts'') <- gatherColon n ts'
	  , not (null cs') ->
		d_Trees inh $ TreeN key (cs<>cs') <| ts''
	
	 _ | (ul,ts') <- gatherLI (==KeyDash) ts, not (null ul) -> do
		D.ul ! DA.style "format —" $ forM_ ul $ d_Tree inh
		d_Trees inh ts'
	
	 _ | (ol,ts') <- gatherLI (\case KeyDot{} -> True; _ -> False) ts, not (null ol) -> do
		D.ol $ forM_ ol $ d_Tree inh
		d_Trees inh ts'
	
	{-
	 _ | inh_dtc_figure inh
	   , Just (name,head,content,ts') <- gatherColon ts -> do
		D.figure ! DA.type_ (attrValue name) $ do
			D.name $ d_Tokens head
			d_Trees inh content
		d_Trees inh ts'
	-}
	
	 t:<ts' -> do
		d_Tree inh t
		d_Trees inh ts'
	
	 _ ->
		return ()

gatherBar :: Name -> Trees Key Tokens -> (Trees Key Tokens, Trees Key Tokens)
gatherBar 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

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

{-
gatherColon :: Trees Key Tokens -> Maybe (Name, Tokens, Trees Key Tokens, Trees Key Tokens)
gatherColon ts =
	case Seq.viewl ts of
	 TreeN (KeyColon name _) (toList -> [Tree0 head]) :< (spanBar name -> (body,ts')) ->
		Just (name,head,body,ts')
	 _ -> Nothing
	where
	spanBar name =
		Seq.spanl $ \case
		 TreeN (KeyBar n _) _ | n == name -> True
		 _ -> False
-}

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

gatherName ::
 Trees Key Tokens ->
 (Name, Tokens, Attributes, Trees Key Tokens)
gatherName ts = dbg "gatherName" $
	case Seq.viewl children of
	 Tree0 (toList -> [TokenPlain name]) :< body ->
		case Text.splitOn "\n" name of
		 n:[] -> (n,mempty,attrs,body)
		 n:ns -> (n,tokens [TokenPlain $ Text.intercalate "\n" ns],attrs,body)
		 []   -> (name,mempty,attrs,body)
	 Tree0 name :< body -> ("",name,attrs,body)
	 _ -> ("",mempty,attrs,children)
	where
	(attrs,children) = partitionAttributesChildren ts

d_Tree :: Inh_DTC -> Tree Key Tokens -> DTC
d_Tree inh (TreeN KeySection{} ts) =
	let inh' = inh
		 { inh_dtc_para = D.para
		 } in
	case gatherName ts of
	 ("",Tokens (null->True),attrs,body) ->
		d_Attributes attrs $
		D.section $ d_Trees inh' body
	 ("",names,attrs,body) ->
		d_Attributes (setAttrId (TL.toStrict $ Write.t_Tokens names) attrs) $
		D.section $ do
			D.name $ d_Tokens names
			d_Trees inh' body
	 (name,names,attrs,body) ->
		d_Attributes (setAttrId name attrs) $
		D.section ! DA.name (attrValue name) $ do
			when (not $ null $ unTokens names) $
				D.name $ d_Tokens names
			d_Trees inh' body
d_Tree inh (TreeN key@(KeyColon typ _) ts) =
	if inh_dtc_figure inh
	then
		case gatherName ts of
		 ("",names,attrs,body) ->
			d_Attributes attrs $
			D.figure ! DA.type_ (attrValue typ) $ do
				when (not $ null $ unTokens names) $
					D.name $ d_Tokens names
				d_Trees inh body
		 (name,names,attrs,body) ->
			d_Attributes attrs $
			D.figure ! DA.type_ (attrValue typ)
			         ! DA.name (attrValue name) $ do
				when (not $ null $ unTokens names) $
					D.name $ d_Tokens names
				d_Trees inh body
	else
		let (attrs,body) = partitionAttributesChildren ts in
		d_Attributes attrs $
		d_Key inh key body
d_Tree path (TreeN key ts) = d_Key path key ts
d_Tree inh (Tree0 ts) =
	case ts of
	 (toList -> [TokenPair PairElem{} _ts]) -> d_Tokens ts
	 _ -> inh_dtc_para inh $ d_Tokens ts

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

d_Key :: Inh_DTC -> Key -> Trees Key Tokens -> DTC
d_Key inh 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 inh ts
	 KeyDash   -> D.li $ d_Trees inh 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 inh{inh_dtc_para = id} 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 inh ts

d_Tokens :: Tokens -> DTC
d_Tokens 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 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 | 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_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