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

import Control.Monad (Monad(..), forM_, mapM_, when, unless)
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(..))
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.State as S
import qualified Data.List as List
import qualified Data.Sequence as Seq
import qualified Data.Text.Lazy as TL
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as HA

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

document :: Trees (Cell Node) -> Html
document 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{}) =
			runStateMarkup def $
			html5ify body
		H.body $ do
			H.a ! HA.id "line-1" $ return ()
			html5Body

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

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

instance IsString Html5 where
	fromString = mapM_ html5ify

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

-- ** Type 'State'
data State
 =   State
 {   state_pos      :: Pos
 ,   state_indent   :: Html5
 ,   state_italic   :: Bool
 ,   state_ext_html :: String
 } -- deriving (Eq, Show)
instance Default State where
	def = State
	 { state_pos      = pos1
	 , state_indent   = ""
	 , state_italic   = False
	 , state_ext_html = ".html"
	 }
-- instance Pretty State

-- * Class 'Html5ify'
class Html5ify a where
	html5ify :: a -> Html5
instance Html5ify () where
	html5ify = mempty
instance Html5ify Char where
	html5ify = \case
	 '\n' -> do
		s@State{state_pos=Pos line _col, ..} <- liftStateMarkup S.get
		liftStateMarkup $ S.put s{state_pos=Pos (line + 1) 1}
		html5 '\n'
		H.a ! HA.id ("line-"<>attrify (line + 1)) $$ return ()
		state_indent
	 c -> do
		liftStateMarkup $ S.modify' $ \s@State{state_pos=Pos line col} ->
			s{state_pos=Pos line (col + 1)}
		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
			liftStateMarkup $ S.modify' $ \s@State{state_pos=Pos line col} ->
				s{state_pos=Pos line $ col + int (TL.length h)}
			html5 h
		 Just (_n,ts') -> do
			html5 h
			 -- NOTE: useless to increment the pos_column for h,
			 --       since the following '\n' will reset the pos_column.
			html5ify '\n'
			html5ify ts'
instance Html5ify Pos where
	html5ify new@(Pos lineNew colNew) = do
		s@State
		 { state_pos=old@(Pos lineOld colOld)
		 , state_indent
		 } <- liftStateMarkup S.get
		case lineOld`compare`lineNew of
		 LT -> do
			forM_ [lineOld+1..lineNew] $ \lnum -> do
				html5 '\n'
				H.a ! HA.id ("line-"<>attrify lnum) $$ return ()
			liftStateMarkup $ S.put s{state_pos=Pos lineNew 1}
			state_indent
			Pos _lineMid colMid <- liftStateMarkup $ S.gets state_pos
			html5 $ List.replicate (colNew - colMid) ' '
			liftStateMarkup $ S.put s{state_pos=new}
		 EQ | colOld <= colNew -> do
			liftStateMarkup $ S.put s{state_pos=new}
			html5 $ List.replicate (colNew - colOld) ' '
		 _ -> error $ "html5ify: non-ascending Pos:"
			 <> "\n old: " <> show old
			 <> "\n new: " <> show new
instance Html5ify Roots where
	html5ify = mapM_ html5ify
instance Html5ify Root where
	html5ify (Tree (Cell (Span{span_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 "" "" n wh ">" "" "great"
			 HeaderBar   n wh -> html5HeaderRepeated "" "" n wh "|" "" "bar"
			 HeaderColon n wh -> html5Header "" "" n wh ":" "" "colon"
			 HeaderEqual n wh -> html5Header "" "" 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 <- liftStateMarkup $ S.gets state_ext_html
				if null ext
				 then html5ify file
				 else
					H.a ! HA.class_ "header-dotslash"
					    ! HA.href (attrify $ file<>ext) $$
						html5ify file
			where
			html5Head :: Name -> White -> Name -> 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 :: Name -> White -> Name -> White -> TL.Text -> White -> H.AttributeValue -> Html5
			html5HeaderRepeated markBegin whmb name whn markEnd whme cl = do
				State{state_indent} <- liftStateMarkup S.get
				liftStateMarkup $ S.modify' $ \s ->
					s{ state_indent = do
						state_indent
						Pos _lineMid colMid <- liftStateMarkup $ S.gets state_pos
						html5ify $ List.replicate (pos_column bp - colMid) ' '
						html5Head markBegin whmb name whn markEnd whme cl
					 }
				r <- html5Header markBegin whmb name whn markEnd whme cl
				liftStateMarkup $ S.modify' $ \s -> s{state_indent}
				return r
		----------------------
		 NodeText t -> do
			State{state_indent} <- liftStateMarkup S.get
			liftStateMarkup $ S.modify' $ \s ->
				s{ state_indent = do
					state_indent
					Pos _lineMid colMid <- liftStateMarkup $ S.gets state_pos
					html5ify $ List.replicate (pos_column bp - colMid) ' '
				 }
			r <- html5ify t
			liftStateMarkup $ S.modify' $ \s -> s{state_indent}
			return r
		----------------------
		 NodePara -> do
			State{state_indent} <- liftStateMarkup S.get
			liftStateMarkup $ S.modify' $ \s ->
				s{ state_indent = do
					state_indent
					Pos _lineMid colMid <- liftStateMarkup $ S.gets state_pos
					html5ify $ List.replicate (pos_column bp - colMid) ' '
				 }
			r <- html5ify ts
			liftStateMarkup $ S.modify' $ \s -> s{state_indent}
			return r
		----------------------
		 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
					State{..} <- liftStateMarkup $ S.get
					liftStateMarkup $ S.modify' $ \s -> s{state_italic = not state_italic}
					r <- H.em ! HA.class_ (if state_italic then "even" else "odd") $$ h
					liftStateMarkup $ S.modify' $ \s -> s{state_italic}
					return r
				 _ -> h
instance Html5ify Token where
	html5ify tok =
		case tok of
		 TokenText t -> html5ify t
		 TokenTag v ->
			H.span ! HA.class_ "tag" $$ do
				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 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