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

import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..), forM_, mapM_, when)
import Data.Bool
import Data.Char (Char)
import Data.Default.Class (Default(..))
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), (.), id)
import Data.Functor ((<$>))
import Data.Functor.Compose (Compose(..))
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (ViewL(..))
import Data.String (String, IsString(..))
import Data.Text (Text)
import Data.TreeSeq.Strict (Tree(..),Trees)
import Prelude (Num(..), undefined, error)
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 List
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 Debug.Trace (trace)

import Text.Blaze.Utils
import Language.TCT
import qualified Language.TCT.Write.Plain as Plain

html5Document :: TCTs -> Html
html5Document body = do
	H.docType
	H.html $ do
		H.head $ do
			H.meta ! HA.httpEquiv "Content-Type"
			       ! HA.content "text/html; charset=UTF-8"
			whenJust (tokensTitle body) $ \ts ->
				H.title $
					H.toMarkup $ Plain.text def $ List.head $ toList ts
			-- link ! rel "Chapter" ! title "SomeTitle">
			H.link ! HA.rel "stylesheet"
			       ! HA.type_ "text/css"
			       ! HA.href "style/tct-html5.css"
		let (html5Body, State{}) =
			runStateMarkup def $
			html5ify body
		H.body $ do
			H.a ! HA.id ("line-1") $ return ()
			html5Body

-- * Type 'Html5'
type Html5 = StateMarkup State ()

-- ** Type 'State'
data State
 =   State
 {   state_pos :: Pos
 }
instance Default State where
	def = State
	 { state_pos = pos1
	 }

-- * Class 'Html5ify'
class Html5ify a where
	html5ify :: a -> Html5
instance Html5ify H.Markup where
	html5ify = Compose . return
instance Html5ify Html5 where
	html5ify = id
instance Html5ify () where
	html5ify = mempty
instance Html5ify Char where
	html5ify = html5ify . H.toMarkup
instance Html5ify Text where
	html5ify = html5ify . H.toMarkup
instance Html5ify TL.Text where
	html5ify = html5ify . H.toMarkup
instance Html5ify String where
	html5ify = html5ify . H.toMarkup
instance Html5ify (Trees (Cell Key) Tokens) where
	html5ify = mapM_ html5ify
instance Html5ify (Tree (Cell Key) Tokens) where
	html5ify = \case
	 TreeN (Cell bp ep k) ts -> html5ify (Cell bp ep (k,ts))
	 Tree0 ts -> html5ify ts
instance Html5ify a => Html5ify (Cell a) where
	html5ify (Cell next@(Pos line col) ep a) = do
		prev@(Pos lineLast colLast) <- liftStateMarkup $ S.gets state_pos
		case () of
		 _ | lineLast < line -> do
			forM_ [lineLast+1..line] $ \lnum -> do
				html5ify '\n'
				H.a ! HA.id ("line-"<>attrify lnum) $$ return ()
			html5ify $ Text.replicate (col - 1) " "
		 _ | lineLast == line && colLast <= col -> do
			html5ify $ Text.replicate (col - colLast) " "
		 _ -> error $ "html5ify: non-ascending positions: "
			 <> "\n prev: " <> show prev
			 <> "\n next: " <> show next
		-- liftStateMarkup $ S.modify $ \s -> s{state_pos=bp}
		liftStateMarkup $ S.modify $ \s -> s{state_pos=ep}
		html5ify a
instance Html5ify (Key, Trees (Cell Key) Tokens) where
	html5ify (key, ts) =
		case key of
		 KeyPara       -> html5ify ts
		 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" $$ html5ify '<'
				H.span ! HA.class_ "key-name" $$ html5ify name
				html5ify attrs
				html5ify ts
		 KeySection lvl -> do
			H.section $$ do
				H.span ! HA.class_ "section-title" $$ do
					H.span ! HA.class_ "section-mark" $$ do
						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 > 6 = H.span ! HA.class_ ("h h"<>attrify n)
			h _ = undefined
		where
		html5Key :: Text -> White -> Text -> White -> Text -> White -> H.AttributeValue -> Html5
		html5Key markBegin whmb name whn markEnd whme cl = do
			H.span ! HA.class_ (mconcat ["key key-",cl," key-name-",attrify name]) $$ do
				when (markBegin/="") $
					H.span ! HA.class_ "key-mark" $$ html5ify markBegin
				html5ify whmb
				when (name/="") $
					H.span ! HA.class_ "key-name" $$ html5ify name
				html5ify whn
				when (markEnd/="") $
					H.span ! HA.class_ "key-mark" $$ html5ify markEnd
				html5ify whme
				H.span ! HA.class_ "key-value" $$
					html5ify ts
instance Html5ify Tokens where
	html5ify = mapM_ html5ify
instance Html5ify Token where
	html5ify (TreeN (Cell bp ep p) ts) = do
		case p of
		 PairElem name attrs -> do
			H.span ! HA.class_ ("pair-PairElem" <> " pair-elem-"<>attrify name) $$ do
				html5ify $ Cell bp bp{columnPos = columnPos bp + lenO} ()
				when (lenO > 0) $
					H.span ! HA.class_ "pair-open"    $$ o
				when (not $ Seq.null ts) $
					H.span ! HA.class_ "pair-content" $$ html5ify ts
				html5ify $ Cell ep{columnPos = columnPos ep - lenC} ep ()
				when (lenC > 0) $
					H.span ! HA.class_ "pair-close"   $$ c
			where
			html5Name =
				H.span ! HA.class_ "elem-name" $$
					html5ify name
			lenName = Text.length name
			lenAttrs = sum $ (<$> attrs) $ \(elemAttr_white,ElemAttr{..}) ->
				Text.length elemAttr_white +
				Text.length elemAttr_name +
				Text.length elemAttr_open +
				Text.length elemAttr_value +
				Text.length elemAttr_close
			(lenO,lenC) | Seq.null ts = (1+lenName+lenAttrs+2,0)
			            | otherwise   = (1+lenName+lenAttrs+1,2+lenName+1)
			o,c :: Html5
			(o,c) | Seq.null ts =
				( "<"<>html5Name<>html5ify attrs<>"/>"
				, mempty )
			      | otherwise =
				( "<"<>html5Name<>html5ify attrs<>">"
				, "</"<>html5Name<>">" )
		 _ -> do
			let (o,c) = pairBorders p ts
			H.span ! HA.class_ ("pair-"<>fromString (show p)) $$ do
				html5ify $ Cell bp bp{columnPos = columnPos bp + Text.length o} ()
				H.span ! HA.class_ "pair-open"    $$ html5ify o
				H.span ! HA.class_ "pair-content" $$ html5ify ts
				html5ify $ Cell ep{columnPos = columnPos ep - Text.length c} ep ()
				H.span ! HA.class_ "pair-close"   $$ html5ify c
	html5ify (Tree0 tok) = do
		-- html5ify $ Cell bp ep ()
		case tok of
		 TokenPhrases ps -> html5ify ps
		 TokenRaw t -> html5ify t
			{-do
			lin <- S.get
			let lines = Text.splitOn "\n" txt
			let lnums = html5ify :
				 [ \line -> do
					html5ify '\n'
					H.a ! HA.id ("line-"<>attrify lnum) $$ return ()
					html5ify indent
					html5ify line
				 | lnum <- [lin+1..]
				 ]
			S.put (lin - 1 + List.length lines)
			return $ mconcat $ List.zipWith ($) lnums lines
			-}
		 TokenTag v ->
			H.span ! HA.class_ "tag" $$ do
				H.span ! HA.class_ "tag-open" $$
					html5ify '#'
				html5ify v
		 TokenEscape c -> html5ify $ ('\\' :) . pure <$> c
		 TokenLink (Cell bp ep lnk) -> do
			html5ify $ Cell bp ep ()
			H.a ! HA.href (attrify lnk) $$
				html5ify lnk
instance Html5ify Phrases where
	html5ify = mapM_ html5ify
instance Html5ify Phrase where
	html5ify p =
		case p of
		 PhraseWord  t -> html5ify t
		 PhraseWhite t -> html5ify t
		 PhraseOther t -> html5ify t
instance Html5ify ElemAttrs where
	html5ify = mapM_ html5ify
instance Html5ify (White,ElemAttr) where
	html5ify (elemAttr_white,ElemAttr{..}) = do
		html5ify elemAttr_white
		H.span ! HA.class_ "attr-name" $$
			html5ify elemAttr_name
		html5ify elemAttr_open
		H.span ! HA.class_ "attr-value" $$
			html5ify elemAttr_value
		html5ify elemAttr_close

-- * Utilities

tokensTitle :: Trees (Cell Key) Tokens -> Maybe Tokens
tokensTitle tct =
	List.find (\case
	 TreeN (unCell -> KeySection{}) _ts -> True
	 _ -> False) tct >>=
	\case
	 TreeN (unCell -> KeySection _lvl) (Seq.viewl -> Tree0 title:<_) -> Just title
	 _ -> Nothing

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