{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Render a TCT source file in HTML5.
module Language.TCT.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 Language.TCT.Tree
import Language.TCT.Token
import Language.TCT.Elem

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

class Textable a where
	textOf :: a -> Html
instance HTML5able TCT where
-}
instance Semigroup H.AttributeValue where
	(<>) = mappend

-- * Class 'Attributable'
class AttrValue a where
	attrValue :: a -> H.AttributeValue
instance AttrValue Text where
	attrValue = fromString . Text.unpack
instance AttrValue Int where
	attrValue = fromString . show
instance AttrValue Group where
	attrValue = fromString . show

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

html5 :: Trees (Cell Key) (Cell Token) -> 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 -> t) ->
				H.title $ H.toMarkup $ t_Token t
			-- 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 Token) -> 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 ((lineLast,colLast),posCell -> (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 Token) -> 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
			forM_ cells h_TreeCell

h_CellToken :: Cell Token -> Html
h_CellToken (Cell pos _posEnd mrk) =
	h_IndentToken pos mrk

h_IndentToken :: Pos -> Token -> Html
h_IndentToken pos mrk = go mrk `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" $
				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 (TokenGroup (GroupElem name attrs) t) = do
		h <- go t
		return $ do
			let cl = mconcat ["group-GroupElem", " group-elem-", attrValue name]
			H.span ! HA.class_ cl $ do
				H.span ! HA.class_ "group-open"    $ H.toMarkup o
				H.span ! HA.class_ "group-content" $ h
				H.span ! HA.class_ "group-close"   $ H.toMarkup c
		where
		h_name = H.span ! HA.class_ "elem-name" $ H.toMarkup name
		o,c :: Html
		(o,c) =
			case t of
			 Tokens ts | Seq.null ts ->
				( "<"<>h_name<>h_Attrs attrs<>"/>"
				, "" )
			 _ ->
				( "<"<>h_name<>h_Attrs attrs<>">"
				, "</"<>h_name<>">" )
	go (TokenGroup grp t) = do
		h <- go t
		return $ do
			let (o,c) = groupBorders grp t
			H.span ! HA.class_ (mconcat ["group-", attrValue grp]) $ do
				H.span ! HA.class_ "group-open"    $ H.toMarkup o
				H.span ! HA.class_ "group-content" $ h
				H.span ! HA.class_ "group-close"   $ H.toMarkup c
	go (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

t_Token :: Token -> Text
t_Token (TokenPlain t) = t
t_Token (TokenTag v) = "#"<>v
t_Token (TokenEscape c) = Text.pack ['\\',c]
t_Token (TokenLink lnk) = lnk
t_Token (TokenGroup grp t) = o<>t_Token t<>c
	where (o,c) = groupBorders grp t
t_Token (Tokens ts) = foldMap t_Token ts

t_Value :: Text -> Text
t_Value v = v

treePosLastCell :: Trees (Cell k) (Cell a) -> Trees (Pos,Cell k) (Pos,Cell a)
treePosLastCell t = S.evalState (go`mapM`t) (1,1)
	where
	go :: Tree (Cell k) (Cell a) ->
	      S.State (Int, Int) (Tree (Pos, Cell k) (Pos, Cell a))
	go (Tree0 cell) = do
		lastPos <- S.get
		S.put $ posEndCell cell
		return $ Tree0 (lastPos,cell)
	go (TreeN cell ts) = do
		lastPos <- S.get
		S.put $ posEndCell cell
		ts' <- go`mapM`ts
		return $ TreeN (lastPos,cell) ts'