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

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 (($), (.))
import Data.Functor.Compose (Compose(..))
import Data.Int (Int)
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.Write.Plain (int)
import Text.Blaze.Utils
import qualified Language.TCT.Write.Plain as Plain

html5Document :: Trees (Cell Node) -> 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 (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 :: Int
 ,   state_italic :: Bool
 } deriving (Eq, Show)
instance Default State where
	def = State
	 { state_pos    = pos1
	 , state_indent = 1
	 , state_italic = False
	 }
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
		(indent, lnum) <-
			liftStateMarkup $ do
				s@State{state_pos=Pos line _col, state_indent} <- S.get
				S.put $ s{state_pos=Pos (line + 1) state_indent}
				return (state_indent, line + 1)
		html5 '\n'
		H.a ! HA.id ("line-"<>attrify lnum) $$ return ()
		html5 $ List.replicate (indent - 1) ' '
	 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
		old@(Pos lineOld colOld) <-
			liftStateMarkup $ do
				s <- S.get
				S.put s{state_pos=new}
				return $ state_pos s
		case lineOld`compare`lineNew of
		 LT -> do
			forM_ [lineOld+1..lineNew] $ \lnum -> do
				html5 '\n'
				H.a ! HA.id ("line-"<>attrify lnum) $$ return ()
			html5 $ List.replicate (colNew - 1) ' '
		 EQ | colOld <= colNew -> do
			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 bp _ep nod) ts) = do
		html5ify bp
		case nod of
		 NodeGroup -> html5ify ts
		 NodeToken t -> html5ify t
		 NodePara -> do
			ind <-
				liftStateMarkup $ do
					s <- S.get
					S.put $ s{state_indent = pos_column bp}
					return $ state_indent s
			r <- html5ify ts
			liftStateMarkup $ S.modify $ \s -> s{state_indent=ind}
			return r
		 NodeText t -> do
			ind <-
				liftStateMarkup $ do
					s <- S.get
					S.put $ s{state_indent = pos_column bp}
					return $ state_indent s
			r <- html5ify t
			liftStateMarkup $ S.modify $ \s -> s{state_indent=ind}
			return r
		 NodeHeader hdr ->
			case hdr of
			 HeaderColon n wh -> html5Header "" "" n wh ":" "" "colon"
			 HeaderGreat n wh -> html5Header "" "" n wh ">" "" "great"
			 HeaderEqual n wh -> html5Header "" "" n wh "=" "" "equal"
			 HeaderBar   n wh -> html5Header "" "" n wh "|" "" "bar"
			 HeaderDot   n    -> html5Header "" "" n "" "." "" "dot"
			 HeaderDotSlash n -> html5Header "./" "" (fromString n) "" "" "" "dotslash"
			 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
			where
			html5Header :: Name -> White -> Name -> White -> TL.Text -> White -> H.AttributeValue -> Html5
			html5Header 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
					H.span ! HA.class_ "header-value" $$
						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
					when (not $ 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
					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
				(o,c) | null ts   = pairBordersWithoutContent pair
				      | otherwise = pairBorders pair
			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
		 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
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