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

import Control.Monad (Monad(..), forM_, mapM_, join)
import Data.Bool
import Data.Char (Char)
import Data.Default.Class (Default(..))
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), (.))
import Data.Functor.Compose (Compose(..))
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..), Ordering(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (ViewL(..))
import Data.String (String, IsString(..))
import Prelude (Num(..), undefined, error)
import Text.Blaze ((!))
import Text.Blaze.Html (Html)
import Text.Show (Show(..))
import qualified Control.Monad.Trans.RWS.Strict as RWS
import qualified Data.List as List
import qualified Data.Sequence as Seq
import qualified Data.Text.Lazy as TL
import qualified Symantic.XML as XML
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as HA
import qualified Text.Blaze.Internal as Blaze

-- import Hdoc.TCT.Debug
import Hdoc.TCT
import Hdoc.TCT.Utils
import Control.Monad.Utils
import Text.Blaze.Utils
import Text.Blaze.XML ()
import qualified Hdoc.TCT.Write.Plain as Plain

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

titleFrom :: Roots -> Maybe Root
titleFrom tct =
	List.find (\case
	 Tree (unSourced -> NodeHeader HeaderSection{}) _ts -> True
	 _ -> False) tct >>=
	\case
	 Tree (unSourced -> NodeHeader (HeaderSection _lvl))
	      (Seq.viewl -> title:<_) -> Just title
	 _ -> Nothing

-- * Type 'Html5'
type Html5 = ComposeRWS Reader Writer State Blaze.MarkupM ()

instance IsString Html5 where
	fromString = mapM_ html5ify

html5 :: H.ToMarkup a => a -> Html5
html5 = Compose . return . H.toMarkup

-- ** Type 'Reader'
data Reader = Reader
 { reader_indent   :: Html5
 , reader_italic   :: Bool
 , reader_ext_html :: String
 } -- deriving (Eq, Show)
instance Default Reader where
	def = Reader
	 { reader_indent   = ""
	 , reader_italic   = False
	 , reader_ext_html = ".html"
	 }

-- ** Type 'Writer'
type Writer = ()

-- ** Type 'State'
newtype State = State
 { state_pos :: LineColumn
 } -- deriving (Eq, Show)
instance Default State where
	def = State
	 { state_pos = def
	 }

-- * Class 'Html5ify'
class Html5ify a where
	html5ify :: a -> Html5
instance Html5ify () where
	html5ify = mempty
instance Html5ify Char where
	html5ify = \case
	 '\n' -> do
		st@State{state_pos=LineColumn line _col, ..} <- composeLift RWS.get
		composeLift $ RWS.put st{state_pos=LineColumn (line <> pos1) pos1}
		html5 '\n'
		H.a ! HA.id ("line-"<>attrify (line <> pos1)) $$ return ()
		join $ composeLift $ RWS.asks reader_indent
	 c -> do
		composeLift $ RWS.modify $ \s@State{state_pos=LineColumn line col} ->
			s{state_pos=LineColumn line (col <> pos1)}
		html5 c
instance Html5ify String where
	html5ify = mapM_ html5ify
instance Html5ify TL.Text where
	html5ify t
	 | TL.null t = mempty
	 | otherwise =
		let (h,ts) = TL.span (/='\n') t in
		case TL.uncons ts of
		 Nothing -> do
			composeLift $ RWS.modify $ \s@State{state_pos} ->
				s{state_pos=state_pos{colNum = colNum state_pos <> num (TL.length h)}}
			html5 h
		 Just (_n,ts') -> do
			html5 h
			 -- NOTE: useless to increment the 'colNum' for h,
			 --       since the following '\n' will reset the 'colNum'.
			html5ify '\n'
			html5ify ts'
instance Html5ify LineColumn where
	html5ify new = do
		Reader{reader_indent} <- composeLift RWS.ask
		st@State{state_pos=old} <- composeLift RWS.get
		let lineOld = lineInt old
		let colOld  = colInt  old
		case lineOld`compare`lineNew of
		 LT -> do
			forM_ [lineOld+1..lineNew] $ \lnum -> do
				html5 '\n'
				H.a ! HA.id ("line-"<>attrify lnum) $$ return ()
			composeLift $ RWS.put st{state_pos=LineColumn (lineNum new) pos1}
			reader_indent
			mid <- composeLift $ RWS.gets state_pos
			html5 $ List.replicate (colNew - colInt mid) ' '
			composeLift $ RWS.put st{state_pos=new}
		 EQ | colOld <= colNew -> do
			composeLift $ RWS.put st{state_pos=new}
			html5 $ List.replicate (colNew - colOld) ' '
		 _ -> error $ "html5ify: non-ascending LineColumn:"
			 <> "\n old: " <> show old
			 <> "\n new: " <> show new
		where
		lineNew = lineInt new
		colNew  = colInt  new
instance Html5ify Roots where
	html5ify = mapM_ html5ify
instance Html5ify Root where
	html5ify (Tree (Sourced (FileRange{fileRange_begin=bp}:|_) nod) ts) = do
		html5ify bp
		case nod of
		----------------------
		 NodeLower name attrs -> do
			H.span ! HA.class_ (mconcat ["header header-lower"," header-name-",attrify name]) $$ do
				H.span ! HA.class_ "header-mark" $$ html5ify '<'
				H.span ! HA.class_ "header-name" $$ html5ify name
				html5ify attrs
				html5ify ts
		----------------------
		 NodeHeader hdr ->
			case hdr of
			 HeaderGreat n wh -> html5HeaderRepeated "" "" (maybe "" XML.unNCName n) wh ">" "" "great"
			 HeaderBar   n wh -> html5HeaderRepeated "" "" (maybe "" XML.unNCName n) wh "|" "" "bar"
			 HeaderColon n wh -> html5Header "" "" (maybe "" XML.unNCName n) wh ":" "" "colon"
			 HeaderEqual n wh -> html5Header "" "" (XML.unNCName n) wh "=" "" "equal"
			 HeaderDot   n    -> html5Header "" "" n "" "." "" "dot"
			 HeaderDash       -> html5Header "" "" "" "" "-" " " "dash"
			 HeaderDashDash   -> html5Header "" "" "" "" "--" " " "dashdash"
			 HeaderBrackets n -> html5Header "[" "" n "" "]" "" "dashdash"
			 HeaderSection lvl -> do
				H.section $$ do
					H.span ! HA.class_ "section-title" $$ do
						H.span ! HA.class_ "section-mark" $$ do
							html5ify $ List.replicate lvl '#'
						case Seq.viewl ts of
						 title :< _ -> h lvl $$ html5ify title
						 _ -> return ()
					html5ify $
						case Seq.viewl ts of
						 _ :< 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
			 HeaderDotSlash file -> do
				ext <- composeLift $ RWS.asks reader_ext_html
				if null ext
				 then html5ify file
				 else
					H.a ! HA.class_ "header-dotslash"
					    ! HA.href (attrify $ file<>ext) $$
						html5ify file
			where
			html5Head :: TL.Text -> White -> TL.Text -> White -> TL.Text -> White -> H.AttributeValue -> Html5
			html5Head markBegin whmb name whn markEnd whme cl = do
				H.span ! HA.class_ (mconcat $ ["header header-",cl] <>
				 if TL.null name then [] else [" header-name-",attrify name]) $$ do
					when (markBegin/="") $
						H.span ! HA.class_ "header-mark" $$ html5ify markBegin
					html5ify whmb
					when (name/="") $
						H.span ! HA.class_ "header-name" $$ html5ify name
					html5ify whn
					when (markEnd/="") $
						H.span ! HA.class_ "header-mark" $$ html5ify markEnd
					html5ify whme
			html5Header markBegin whmb name whn markEnd whme cl = do
				html5Head markBegin whmb name whn markEnd whme cl
				H.span ! HA.class_ "header-value" $$
					html5ify ts
			html5HeaderRepeated :: TL.Text -> White -> TL.Text -> White -> TL.Text -> White -> H.AttributeValue -> Html5
			html5HeaderRepeated markBegin whmb name whn markEnd whme cl = do
				localComposeRWS (\ro ->
					ro{ reader_indent = do
						reader_indent ro
						midLC <- composeLift $ RWS.gets state_pos
						html5ify $ List.replicate (colInt bp - colInt midLC) ' '
						html5Head markBegin whmb name whn markEnd whme cl
					 }) $
					html5Header markBegin whmb name whn markEnd whme cl
		----------------------
		 NodeText t -> do
			localComposeRWS (\ro ->
				ro{ reader_indent = do
					reader_indent ro
					midLC <- composeLift $ RWS.gets state_pos
					html5ify $ List.replicate (colInt bp - colInt midLC) ' '
				 }) $
				html5ify t
		----------------------
		 NodePara -> do
			localComposeRWS (\ro ->
				ro{ reader_indent = do
					reader_indent ro
					midLC <- composeLift $ RWS.gets state_pos
					html5ify $ List.replicate (colInt bp - colInt midLC) ' '
				 }) $
				html5ify ts
		----------------------
		 NodeToken t -> html5ify t <> html5ify ts
		----------------------
		 NodePair pair ->
			case pair of
			 PairElem name attrs -> do
				H.span ! HA.class_ ("pair-PairElem" <> " pair-elem-"<>attrify name) $$ do
					H.span ! HA.class_ "pair-open" $$ o
					unless (null ts) $ do
						H.span ! HA.class_ "pair-content" $$ html5ify ts
						H.span ! HA.class_ "pair-close" $$ c
				where
				html5Name =
					H.span ! HA.class_ "elem-name" $$
						html5ify name
				o,c :: Html5
				(o,c)
				 | null ts =
					( "<"<>html5Name<>html5ify attrs<>"/>"
					, mempty )
				 | otherwise =
					( "<"<>html5Name<>html5ify attrs<>">"
					, "</"<>html5Name<>">" )
			 _ -> do
				H.span ! HA.class_ ("pair-"<>fromString (show pair)) $$ do
					let (o,c) = pairBorders pair ts
					H.span ! HA.class_ "pair-open"    $$ html5ify o
					H.span ! HA.class_ "pair-content" $$ em $ html5ify ts
					H.span ! HA.class_ "pair-close"   $$ html5ify c
			where
			em :: Html5 -> Html5
			em h =
				case pair of
				 p | p == PairSlash
				  || p == PairFrenchquote
				  || p == PairDoublequote -> do
					Reader{reader_italic} <- composeLift RWS.ask
					localComposeRWS (\ro -> ro{reader_italic = not reader_italic}) $
						H.em ! HA.class_ (if reader_italic then "even" else "odd") $$ h
				 _ -> h
instance Html5ify Token where
	html5ify tok =
		case tok of
		 TokenText t -> html5ify t
		 TokenAt b v ->
			H.span ! HA.class_ "at" $$ do
				when b $
					H.span ! HA.class_ "at-back" $$
						html5ify '~'
				H.span ! HA.class_ "at-open" $$
					html5ify '@'
				html5ify v
		 TokenTag b v ->
			H.span ! HA.class_ "tag" $$ do
				when b $
					H.span ! HA.class_ "tag-back" $$
						html5ify '~'
				H.span ! HA.class_ "tag-open" $$
					html5ify '#'
				html5ify v
		 TokenEscape c -> html5ify ['\\', c]
		 TokenLink l -> do
			H.a ! HA.href (attrify l) $$
				html5ify l
instance Html5ify ElemName where
	html5ify = html5ify . show
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