{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
-- | Render a TCT source file in HTML5.
module Language.TCT.Write.HTML5.Source 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 (($))
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 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.Html5 as H
import qualified Text.Blaze.Html5.Attributes  as HA
import qualified Data.Text.Lazy as TL

import Text.Blaze.Utils
import Language.TCT.Tree
import Language.TCT.Token
import Language.TCT.Elem
import Language.TCT.Write.Text

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

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

whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()
whenJust Nothing _f = pure ()
whenJust (Just a) f = f a

html5 :: Trees (Cell Key) (Cell Tokens) -> 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) $ \(unCell -> 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 ()
			forM_ (treePosLastCell tct) $ h_TreeCell

titleTCT :: Trees (Cell Key) (Cell a) -> Maybe (Cell a)
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,Cell Tokens) -> Html
h_TreeCell (TreeN c@(_, unCell -> KeySection lvl) ts) = do
	h_IndentCell c
	H.section $ do
		H.span ! HA.class_ "section-title" $ do
			H.span $ h_Text $ Text.replicate lvl "#" <> " "
			case Seq.viewl ts of
			 Tree0 (_,Cell posTitle _ title) :< _ -> h lvl $ h_IndentToken posTitle title
			 _ -> return ()
		forM_ (case Seq.viewl ts of {Tree0{} :< ts' -> ts'; _ -> ts}) $ h_TreeCell
	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 c@(_,cell)) = do
	h_IndentCell c
	h_CellToken cell
h_TreeCell (TreeN c@(_,cell) cs) = do
	h_IndentCell c
	h_CellKey cell cs

h_IndentCell :: (Pos,Cell a) -> Html
h_IndentCell (Pos lineLast colLast,posCell -> 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,Cell Tokens) -> Html
h_CellKey (Cell _pos _posEnd key) cells = 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"
	 KeyDash -> do
		H.toMarkup ("- "::Text)
		forM_ cells h_TreeCell
	 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
			forM_ cells h_TreeCell
	where
	h_Key :: Text -> White -> Text -> H.AttributeValue -> Html
	h_Key name wh mark 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
			H.span ! HA.class_ "key-name" $ H.toMarkup name
			H.toMarkup wh
			H.span ! HA.class_ "key-mark" $ H.toMarkup mark
			H.span ! HA.class_ "key-value" $
				forM_ cells h_TreeCell

h_CellToken :: Cell Tokens -> Html
h_CellToken (Cell pos _posEnd tok) =
	h_IndentToken pos tok

h_IndentToken :: Pos -> Tokens -> Html
h_IndentToken pos toks = goTokens toks `S.evalState` linePos pos
	where
	indent = Text.replicate (columnPos pos - 1) " "
	go :: Token -> S.State Int Html
	go (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
	go (TokenTag v) = do
		return $
			H.span ! HA.class_ "tag" $ do
				H.span ! HA.class_ "tag-open" $ H.toMarkup '#'
				H.toMarkup v
	go (TokenEscape c) = return $ H.toMarkup ['\\',c]
	go (TokenLink lnk) = do
		return $
			H.a ! HA.href (attrValue lnk) $
				H.toMarkup lnk
	go (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) =
			case ts of
			 Tokens s | Seq.null s ->
				( "<"<>h_name<>h_Attrs attrs<>"/>"
				, mempty )
			 _ ->
				( "<"<>h_name<>h_Attrs attrs<>">"
				, "</"<>h_name<>">" )
	go (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 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