{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
-- | Render TCT as HTML5.
module Language.TCT.Write.HTML5 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

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

html5TreesCell :: Trees (Pos,Cell Key) (Pos,Tokens) -> Html
html5TreesCell = foldMap html5TreeCell

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

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

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

html5TreeCell :: Tree (Pos,Cell Key) (Pos,Tokens) -> Html
html5TreeCell (TreeN (posEnd, Cell pos _ (KeySection lvl)) ts) = do
	html5IndentCell (posEnd,pos)
	H.section $ do
		H.span ! HA.class_ "section-title" $ do
			H.span $ html5Text $ Text.replicate lvl "#" <> " "
			case Seq.viewl ts of
			 Tree0 (_,title) :< _ -> h lvl $ html5IndentToken title
			 _ -> return ()
		html5TreesCell $
			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
html5TreeCell (Tree0 (posEnd,toks)) =
	case Seq.viewl toks of
	 EmptyL -> html5IndentToken toks
	 t0:<_  -> html5IndentCell (posEnd,posCell t0) <> html5IndentToken toks
html5TreeCell (TreeN (posEnd,cell@(Cell pos _ _)) cs) =
	html5IndentCell (posEnd,pos) <>
	html5CellKey cell cs

html5IndentCell :: (Pos,Pos) -> Html
html5IndentCell (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

html5CellKey :: Cell Key -> Trees (Pos,Cell Key) (Pos,Tokens) -> Html
html5CellKey (Cell _pos _posEnd key) ts = do
	case key of
	 KeyColon n wh -> html5Key "" "" n wh ":" "" "colon"
	 KeyGreat n wh -> html5Key "" "" n wh ">" "" "great"
	 KeyEqual n wh -> html5Key "" "" n wh "=" "" "equal"
	 KeyBar   n wh -> html5Key "" "" n wh "|" "" "bar"
	 KeyDot   n    -> html5Key "" "" n "" "." "" "dot"
	 KeyDash       -> html5Key "" "" "" "" "-" " " "dash"
	 KeyDashDash   -> html5Key "" "" "" "" "--" " " "dashdash"
	 KeyBrackets n -> html5Key "[" "" 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
			html5Attrs attrs
			html5TreesCell ts
	where
	html5Key :: Text -> White -> Text -> White -> Text -> White -> H.AttributeValue -> Html
	html5Key markBegin whmb name whn markEnd whme cl = do
		-- html5Spaces $ 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" $
				html5TreesCell ts

html5IndentToken :: Tokens -> Html
html5IndentToken toks =
	case Seq.viewl toks of
	 EmptyL -> ""
	 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
				html5name = H.span ! HA.class_ "elem-name" $ H.toMarkup name
				o,c :: Html
				(o,c) =
					if Seq.null ts
					then
						( "<"<>html5name<>html5Attrs attrs<>"/>"
						, mempty )
					else
						( "<"<>html5name<>html5Attrs attrs<>">"
						, "</"<>html5name<>">" )
			 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'

html5Attrs :: Attrs -> Html
html5Attrs = foldMap html5Attr

html5Attr :: (Text,Attr) -> Html
html5Attr (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