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

-- import Data.Char (Char)
-- import Data.Eq (Eq(..))
-- import Data.Int
-- import Data.Text.Lazy.Builder (Buildable(..))
-- import qualified Data.ByteString.Lazy as BSL
-- import qualified Data.Char as Char
-- import qualified Data.Text.Lazy as TL
-- import qualified Data.Text.Lazy.Builder as TL
import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..), forM_, mapM)
import Data.Bool
import Data.Eq (Eq(..))
import Data.Foldable (sum)
import Data.Function (($), (.), const, id)
import Data.Functor ((<$>))
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 T
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes  as HA

import Language.TCT.Tree
import Language.TCT.Markup
import Language.TCT.Read.Tree
import Language.TCT.Read.Markup

{-
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 Markup) -> 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_Markup t
			-- link ! rel "Chapter" ! title "SomeTitle">
			H.link ! HA.rel "stylesheet"
			       ! HA.type_ "text/css"
			       ! HA.href "tct-text.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 $ T.replicate sp " "

h_TreeCell :: Tree (Pos,Cell Key) (Pos,Cell Markup) -> 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 $ T.replicate lvl "#" <> " "
			case Seq.viewl ts of
			 Tree0 (_,Cell posTitle _ title) :< _ -> h lvl $ h_Markup 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"`mappend`fromString (show n))
	h _ = undefined
h_TreeCell (Tree0 c@(_,cell)) = do
	h_IndentCell c
	h_CellMarkup cell
h_TreeCell (TreeN c@(_,cell) cs) = do
	h_IndentCell c
	h_CellKey cell
	forM_ cs $ h_TreeCell

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-"`mappend`fromString (show lnum)) $ return ()
	H.toMarkup $ T.replicate (col - 1) " "
 | lineLast == line
 && colLast <= col = H.toMarkup $ T.replicate (col - colLast) " "
 | otherwise = undefined

h_CellKey :: Cell Key -> Html
h_CellKey (Cell pos posEnd key) = do
	case key of
	 KeyColon n -> h_Key n ':' "colon"
	 KeyGreat n -> h_Key n '>' "great"
	 KeyEqual n -> h_Key n '=' "equal"
	 KeyBar   n -> h_Key n '|' "bar"
	 KeyDash    -> H.toMarkup ("- "::Text)
	where
	h_Key nam mark cl = do
		-- h_Spaces $ colPos posEnd - (colPos pos + T.length nam + 1)
		H.span ! HA.class_ (mconcat ["key key-",cl," key-name-",fromString $ T.unpack nam]) $ do
			H.toMarkup nam
			H.span ! HA.class_ "key-mark" $ H.toMarkup mark
{-
h_CellKey (TreeN (Cell pos posEnd k) _) = do
	-- h_Spaces pos
	H.pre $ H.toMarkup $ show k
-}

h_CellText :: Cell Text -> Html
h_CellText (Cell pos posEnd a) = h_IndentText pos a

h_CellMarkup :: Cell Markup -> Html
h_CellMarkup (Cell pos posEnd (MarkupPlain t)) =
	h_IndentText pos t

h_IndentText :: Pos -> Text -> Html
h_IndentText pos v =
	let lines = T.splitOn "\n" v in
	let lnums = H.toMarkup :
		 [ \line -> do
			H.toMarkup '\n'
			H.a ! HA.id ("line-"`mappend`fromString (show lnum)) $ return ()
			H.toMarkup pad
			H.toMarkup line
		 | lnum <- [linePos pos+1..]
		 ] in
	mconcat $ L.zipWith ($) lnums lines
	where pad = T.replicate (columnPos pos - 1) " "

h_Markup :: Pos -> Markup -> Html
h_Markup pos (MarkupPlain v) = h_IndentText pos v
{-
h_Markup pos (Tag v) =
	H.span ! HA.class_ "tag" $
		toMarkup $ T.concat ["#",v,if T.all isTagNameShortChar v then "" else "#"]
h_Markup pos (Values vs) = do
	forM_ vs (h_Markup pos)
h_Markup pos v = H.pre $ toMarkup $ show v
-}

t_Markup :: Markup -> Text
t_Markup (MarkupPlain t) = t
t_Value :: Text -> Text
t_Value v = v
{-
t_Value (Tag v) = T.concat ["#",v,if T.all isTagNameShortChar v then "" else "#"]
t_Value v = T.pack $ show 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 (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'

{-
colValue :: Value -> Column
colValue = \case
	 Plain t    -> T.length t
	 Tag t      -> T.length t + (if T.all isTagNameCharShort t then 0 else 1)
	 Values vs  -> sum $ colValue <$> vs
	 Group _g v -> 2 + colValue v
-}