{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
-- | Render a TCT source file in HTML5.
module Language.TCT.Write.HTML5.Source where

import Control.Monad (Monad(..), forM_, mapM, when)
import Data.Bool
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Function (($))
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 (IsString(..))
import Data.Text (Text)
import Data.TreeSeq.Strict (Tree(..),Trees)
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 Data.Text.Lazy as TL
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes  as HA

import Text.Blaze.Utils
import Language.TCT
import Language.TCT.Write.Text

{-
class HTML5able a where
	html5Of :: a -> Html

class Textable a where
	textOf :: a -> Html
instance HTML5able TCT where
-}

html5 :: TCTs -> Html
html5 tct = do
	H.docType
	H.html $ do
		H.head $ do
			H.meta ! HA.httpEquiv "Content-Type"
			       ! HA.content "text/html; charset=UTF-8"
			whenJust (titleTCT tct) $ \ts ->
				H.title $ H.toMarkup $ L.head $
					Text.lines (TL.toStrict $ t_Tokens ts) <> [""]
			-- link ! rel "Chapter" ! title "SomeTitle">
			H.link ! HA.rel "stylesheet"
			       ! HA.type_ "text/css"
			       ! HA.href "style/tct-html5-source.css"
		H.body $ do
			H.a ! HA.id ("line-1") $ return ()
			h_TreesCell (treePosLastCell tct)

h_TreesCell :: Trees (Pos,Cell Key) (Pos,Tokens) -> Html
h_TreesCell = foldMap h_TreeCell

titleTCT :: Trees (Cell Key) Tokens -> Maybe Tokens
titleTCT tct =
	L.find (\case
	 TreeN (unCell -> KeySection{}) _ts -> True
	 _ -> False) tct >>=
	\case
	 TreeN (unCell -> KeySection _lvl) (Seq.viewl -> Tree0 title:<_) -> Just title
	 _ -> Nothing

h_Text :: Text -> Html
h_Text = H.toMarkup

h_Spaces :: Int -> Html
h_Spaces 0  = return ()
h_Spaces sp = H.span $ h_Text $ Text.replicate sp " "

h_TreeCell :: Tree (Pos,Cell Key) (Pos,Tokens) -> Html
h_TreeCell (TreeN (posEnd, Cell pos _ (KeySection lvl)) ts) = do
	h_IndentCell (posEnd,pos)
	H.section $ do
		H.span ! HA.class_ "section-title" $ do
			H.span $ h_Text $ Text.replicate lvl "#" <> " "
			case Seq.viewl ts of
			 Tree0 (_,title) :< _ -> h lvl $ h_IndentToken title
			 _ -> return ()
		h_TreesCell $
			case Seq.viewl ts of {Tree0{} :< ts' -> ts'; _ -> ts}
	where
	h 1 = H.h1
	h 2 = H.h2
	h 3 = H.h3
	h 4 = H.h4
	h 5 = H.h5
	h 6 = H.h6
	h n | n > 0 = H.span ! HA.class_ ("h h"<>attrValue n)
	h _ = undefined
h_TreeCell (Tree0 (posEnd,toks)) =
	case Seq.viewl toks of
	 EmptyL -> h_IndentToken toks
	 t0:<_  -> h_IndentCell (posEnd,posCell t0) <> h_IndentToken toks
h_TreeCell (TreeN (posEnd,cell@(Cell pos _ _)) cs) =
	h_IndentCell (posEnd,pos) <>
	h_CellKey cell cs

h_IndentCell :: (Pos,Pos) -> Html
h_IndentCell (Pos lineLast colLast,Pos line col)
 | lineLast < line = do
	forM_ [lineLast+1..line] $ \lnum -> do
		H.toMarkup '\n'
		H.a ! HA.id ("line-"<>attrValue lnum) $ return ()
	H.toMarkup $ Text.replicate (col - 1) " "
 | lineLast == line
 && colLast <= col = H.toMarkup $ Text.replicate (col - colLast) " "
 | otherwise = undefined

h_CellKey :: Cell Key -> Trees (Pos,Cell Key) (Pos,Tokens) -> Html
h_CellKey (Cell _pos _posEnd key) ts = do
	case key of
	 KeyColon n wh -> h_Key "" "" n wh ":" "" "colon"
	 KeyGreat n wh -> h_Key "" "" n wh ">" "" "great"
	 KeyEqual n wh -> h_Key "" "" n wh "=" "" "equal"
	 KeyBar   n wh -> h_Key "" "" n wh "|" "" "bar"
	 KeyDot   n    -> h_Key "" "" n "" "." "" "dot"
	 KeyDash       -> h_Key "" "" "" "" "-" " " "dash"
	 KeyDashDash   -> h_Key "" "" "" "" "--" " " "dashdash"
	 KeyBrackets n -> h_Key "[" "" n "" "]" "" "dashdash"
	 KeyLower name attrs -> do
		H.span ! HA.class_ (mconcat ["key key-lower"," key-name-",attrValue name]) $ do
			H.span ! HA.class_ "key-mark" $ H.toMarkup '<'
			H.span ! HA.class_ "key-name" $ H.toMarkup name
			h_Attrs attrs
			h_TreesCell ts
	where
	h_Key :: Text -> White -> Text -> White -> Text -> White -> H.AttributeValue -> Html
	h_Key markBegin whmb name whn markEnd whme cl = do
		-- h_Spaces $ colPos posEnd - (colPos pos + Text.length name + 1)
		H.span ! HA.class_ (mconcat ["key key-",cl," key-name-",attrValue name]) $ do
			when (markBegin/="") $
				H.span ! HA.class_ "key-mark" $ H.toMarkup markBegin
			H.toMarkup whmb
			when (name/="") $
				H.span ! HA.class_ "key-name" $ H.toMarkup name
			H.toMarkup whn
			when (markEnd/="") $
				H.span ! HA.class_ "key-mark" $ H.toMarkup markEnd
			H.toMarkup whme
			H.span ! HA.class_ "key-value" $
				h_TreesCell ts

h_IndentToken :: Tokens -> Html
h_IndentToken (Seq.viewl -> EmptyL) = ""
h_IndentToken toks@(Seq.viewl -> Cell pos _ _ :< _) =
	goTokens toks `S.evalState` linePos pos
	where
	indent = Text.replicate (columnPos pos - 1) " "
	go :: Cell Token -> S.State Int Html
	go tok =
		case unCell tok of
		 TokenPlain txt -> do
			lin <- S.get
			let lines = Text.splitOn "\n" txt
			let lnums = H.toMarkup :
				 [ \line -> do
					H.toMarkup '\n'
					H.a ! HA.id ("line-"<>attrValue lnum) $ return ()
					H.toMarkup indent
					H.toMarkup line
				 | lnum <- [lin+1..]
				 ]
			S.put (lin - 1 + L.length lines)
			return $ mconcat $ L.zipWith ($) lnums lines
		 TokenTag v ->
			return $
				H.span ! HA.class_ "tag" $ do
					H.span ! HA.class_ "tag-open" $ H.toMarkup '#'
					H.toMarkup v
		 TokenEscape c -> return $ H.toMarkup ['\\',c]
		 TokenLink lnk ->
			return $
				H.a ! HA.href (attrValue lnk) $
					H.toMarkup lnk
		 TokenPair (PairElem name attrs) ts -> do
			h <- goTokens ts
			return $ do
				let cl = mconcat ["pair-PairElem", " pair-elem-", attrValue name]
				H.span ! HA.class_ cl $ do
					whenMarkup o $ H.span ! HA.class_ "pair-open" $ o
					whenMarkup h $ H.span ! HA.class_ "pair-content" $ h
					whenMarkup c $ H.span ! HA.class_ "pair-close" $ c
			where
			h_name = H.span ! HA.class_ "elem-name" $ H.toMarkup name
			o,c :: Html
			(o,c) =
				if Seq.null ts
				then
					( "<"<>h_name<>h_Attrs attrs<>"/>"
					, mempty )
				else
					( "<"<>h_name<>h_Attrs attrs<>">"
					, "</"<>h_name<>">" )
		 TokenPair grp ts -> do
			h <- goTokens ts
			return $ do
				let (o,c) = pairBorders grp ts
				H.span ! HA.class_ (mconcat ["pair-", fromString $ show grp]) $ do
					H.span ! HA.class_ "pair-open"    $ H.toMarkup o
					H.span ! HA.class_ "pair-content" $ h
					H.span ! HA.class_ "pair-close"   $ H.toMarkup c
	goTokens :: Tokens -> S.State Int Html
	goTokens ts = do
		ts' <- go`mapM`ts
		return $ foldr (<>) mempty ts'

h_Attrs :: Attrs -> Html
h_Attrs = foldMap h_Attr

h_Attr :: (Text,Attr) -> Html
h_Attr (attr_white,Attr{..}) = do
	H.toMarkup attr_white
	H.span ! HA.class_ "attr-name" $
		H.toMarkup attr_name
	H.toMarkup attr_open
	H.span ! HA.class_ "attr-value" $
		H.toMarkup attr_value
	H.toMarkup attr_close