{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
-- | Render TCT as HTML5.
module Language.TCT.Write.HTML5 where

import Control.Monad (Monad(..), forM_, mapM_, 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 qualified Language.TCT.Write.Plain as Plain

-- * Class 'Html5ify'
class Html5ify a where
	html5ify :: a -> Html
instance Html5ify Text where
	html5ify = H.toMarkup
instance Html5ify TCTs where
	html5ify 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 (Plain.textify 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 ()
				html5ify (Plain.treePosLastCell tct)
instance Html5ify (Trees (Pos,Cell Key) (Pos,Tokens)) where
	html5ify = mapM_ html5ify
instance Html5ify (Tree (Pos,Cell Key) (Pos,Tokens)) where
	html5ify (TreeN (posEnd, Cell pos _ (KeySection lvl)) ts) = do
		html5ifyIndentCell (posEnd,pos)
		H.section $ do
			H.span ! HA.class_ "section-title" $ do
				H.span $ html5ify $ Text.replicate lvl "#" <> " "
				case Seq.viewl ts of
				 Tree0 (_,title) :< _ -> h lvl $ html5ify title
				 _ -> return ()
			html5ify $
				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"<>attrify n)
		h _ = undefined
	html5ify (Tree0 (posEnd,toks)) =
		case Seq.viewl toks of
		 EmptyL -> html5ify toks
		 t0:<_  -> html5ifyIndentCell (posEnd,posTree t0) <> html5ify toks
	html5ify (TreeN (posEnd,cell@(Cell pos _ _)) cs) =
		html5ifyIndentCell (posEnd,pos) <>
		html5ify (cell, cs)
instance Html5ify (Cell Key, Trees (Pos,Cell Key) (Pos,Tokens)) where
	html5ify (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-",attrify name]) $ do
				H.span ! HA.class_ "key-mark" $ H.toMarkup '<'
				H.span ! HA.class_ "key-name" $ H.toMarkup name
				html5ify attrs
				html5ify 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-",attrify 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" $
					html5ify ts
instance Html5ify Tokens where
	html5ify toks =
		case Seq.viewl toks of
		 EmptyL -> ""
		 t0 :< _ ->
			goTokens toks `S.evalState` linePos pos
			where
			pos = posTree t0
			indent = Text.replicate (columnPos pos - 1) " "
			go :: Token -> S.State Int Html
			go (TreeN (unCell -> p) ts) =
				case p of
				 PairElem name attrs -> do
					h <- goTokens ts
					return $ do
						let cl = mconcat ["pair-PairElem", " pair-elem-", attrify 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<>html5ify attrs<>"/>"
							, mempty )
						else
							( "<"<>html5name<>html5ify attrs<>">"
							, "</"<>html5name<>">" )
				 _ -> do
					h <- goTokens ts
					return $ do
						let (o,c) = pairBorders p ts
						H.span ! HA.class_ (mconcat ["pair-", fromString $ show p]) $ 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
			go (Tree0 (unCell -> tok)) =
				case 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-"<>attrify 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 (attrify lnk) $
							H.toMarkup lnk
			goTokens :: Tokens -> S.State Int Html
			goTokens ts = do
				ts' <- go`mapM`ts
				return $ foldr (<>) mempty ts'
instance Html5ify Attrs where
	html5ify = mapM_ html5ify
instance Html5ify (Text,Attr) where
	html5ify (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

-- * Utilities

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

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

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