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

import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..), forM_, mapM)
import Data.Bool
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), (.), flip)
import Data.Int (Int)
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (ViewL(..))
import Data.String (String, IsString(..))
import Data.Text (Text)
import Prelude (Num(..), undefined)
import Text.Blaze ((!))
import Text.Blaze.Html (Html)
import Text.Show (Show(..))
import qualified Control.Monad.Trans.State as S
import qualified Data.List as L
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 Language.TCT.Tree
import Language.TCT.Token
import Language.TCT.Elem hiding (trac,dbg)
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 Token) -> DTC
dtc tct = do
	D.xmlModel        "./schema/dtc.rnc"
	D.xmlStylesheet   "./xsl/document.html5.xsl"
	D.html5Stylesheet "./xsl/document.html5.xsl"
	D.atomStylesheet  "./xsl/document.atom.xsl"
	D.document $
		forM_ tct $ d_TreeCell []

d_TreeCell :: [Key] -> Tree (Cell Key) (Cell Token) -> DTC
d_TreeCell path (TreeN (unCell -> key@KeySection{}) ts) =
	case Seq.viewl ts of
	 Tree0 (Cell _posTitle _ (TokenPlain title)) :< _ ->
		D.section ! DA.name (attrValue title) $
			d_content
	 Tree0 (Cell _posTitle _ title) :< _ ->
		D.section $ do
			D.name $ d_Token (key:path) title
			d_content
	 _ -> D.section d_content
	where
	d_content = forM_ (case Seq.viewl ts of {Tree0{} :< ts' -> ts'; _ -> ts}) $ d_TreeCell (key:path)
d_TreeCell path (Tree0 cell) = d_CellToken path cell
d_TreeCell path (TreeN cell cs) = d_CellKey path cell cs

d_CellKey :: [Key] -> Cell Key -> Trees (Cell Key) (Cell Token) -> 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 = do
		B.CustomParent (B.Text name) $
			forM_ cells $ d_TreeCell (key:path)

d_CellToken :: [Key] -> Cell Token -> DTC
d_CellToken path (Cell _pos _posEnd tok) =
	-- case L.find (\case KeySection{} -> True; _ -> False) $ dbg "d_CellToken: path:" path of
	case dbg "d_CellToken: path" path of
	 KeySection{}:_ ->
		case tok of
		 TokenGroup GroupElem{} _t -> d_Token path tok
		 _ -> D.para $ d_Token path tok
	 _ -> d_Token path tok

d_Token :: [Key] -> Token -> DTC
d_Token path tok = go 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 (TokenGroup GroupSlash t) = D.i $ go t
	go (TokenGroup GroupBackquote t) = D.code $ go t
	go (TokenGroup GroupFrenchquote t) = D.q $ go t
	go (TokenGroup GroupHash (TokenPlain t)) =
		D.ref mempty ! DA.to (attrValue t)
	go (TokenGroup (GroupElem name attrs) t) =
		d_Attrs attrs $
		case t of
		 Tokens ts | Seq.null ts ->
			B.CustomLeaf (B.Text name) True mempty
		 _ -> B.CustomParent (B.Text name) $ go t
	go (TokenGroup grp t) = do
		let (o,c) = groupBorders grp t
		B.toMarkup o
		go t
		B.toMarkup c
	go (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