{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Language.TCT.HTML5 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.Monad (Monad(..), forM_, mapM)
import Data.Bool
import Data.Foldable (sum)
import Data.Function (($), (.), const, id)
import Data.Eq (Eq(..))
import Data.Functor ((<$>))
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Int (Int)
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..))
import Data.Text (Text)
import Prelude (Num(..), undefined)
import Text.Show (Show(..))
import Data.Sequence (ViewL(..))
import qualified Data.List as L
import qualified Data.Text as T
import qualified Data.Sequence as Seq

import qualified Control.Monad.Trans.State as S
-- import qualified Text.Blaze.Html  as H
-- import qualified Data.ByteString as BS
-- import qualified Data.ByteString.Lazy as BSL
import Text.Blaze as B
import Text.Blaze.Html (Html)
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes  as HA

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

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

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

html5 :: TCT Text -> 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"
			case L.find (\case Tree (Key _ _ KeySection{}) _ns -> True; _ -> False) tct of
			 Just (Tree (Key _ _ (KeySection _lvl)) (Seq.viewl -> Tree (Value _ _ title) _:<_)) ->
				H.title $ toMarkup $ t_Value title
			 _ -> return ()
			-- link ! rel "Chapter" ! title "SomeTitle">
			H.link ! HA.rel "stylesheet"
			       ! HA.type_ "text/css"
			       ! HA.href "tct-text.css"
		H.body $ do
			forM_ (treePosLastCell tct) $ h_TreeCell
			{-
			div ! id "header" $ "Syntax"
			p "This is an example of BlazeMarkup syntax."
			ul $ mapM_ (li . toMarkup . show) [1::Int, 2, 3]
			-}

h_Text :: Text -> Html
h_Text = toMarkup

h_Spaces :: Int -> Html
h_Spaces 0  = return ()
h_Spaces sp = H.span $ h_Text $ T.replicate sp " "

h_fill :: Pos -> Pos -> Html
h_fill (l0,c0) (l1,c1) | l0 < l1 = do
	toMarkup $
		T.replicate (l1 - l0) "\n" <>
		T.replicate c1 " "
h_fill (l0,c0) (l1,c1) | l0 == l1 && c0 <= c1 = do
	toMarkup $ T.replicate (c1 - c1) " "
h_fill _ _ = undefined

h_TreeCell :: Tree (Pos,Cell Text) -> Html
h_TreeCell (Tree c@(posLast, Key pos posEnd (KeySection lvl))
                 (Seq.viewl -> Tree (_, Value posTitle _ title) _:<cs)) = do
	toMarkup $ indentCell c
	H.section $ do
		H.span ! HA.class_ "section-title" $ do
			H.span $ h_Text $ T.replicate lvl "#" <> " "
			h lvl $ h_Value posTitle title
		forM_ cs $ 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 (Tree c@(_,cell) cs) = do
	toMarkup $ indentCell c
	h_Cell cell
	forM_ cs $ h_TreeCell

indentCell :: (Pos,Cell Text) -> Text
indentCell ((lineLast,colLast),posCell -> (line,col))
 | lineLast < line = T.replicate (line - lineLast) "\n" <> T.replicate (col - 1) " "
 | lineLast == line
 && colLast <= col = T.replicate (col - colLast) " "
 | otherwise = undefined

h_Cell :: Cell Text -> Html
h_Cell (Key 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    -> 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
			toMarkup nam
			H.span ! HA.class_ "key-mark" $ toMarkup mark
h_Cell (Key pos posEnd k) = do
	-- h_Spaces pos
	H.pre $ toMarkup $ show k
h_Cell (Value pos posEnd v) = h_Value pos v

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

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

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 :: Forest (Cell Text) -> Forest (Pos,Cell Text)
treePosLastCell t = S.evalState (go`mapM`t) (1,1)
	where
	go (Tree cell cells) = do
		lastPos <- S.get
		S.put $ posEndCell cell
		cells' <- go`mapM`cells
		return $ Tree (lastPos,cell) cells'

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