{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Render a DTC source file in HTML5.
module Language.DTC.Write.HTML5 where

-- import Control.Monad.Trans.Class (MonadTrans(..))
-- import Data.Functor.Identity (Identity(..))
-- import qualified Data.Map.Strict as Map
-- import qualified Data.TreeSeq.Strict as Tree
-- import qualified Data.Sequence as Seq
import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..), forM_, mapM_, when)
import Data.Char (Char)
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), (.))
import Data.Functor ((<$>))
import Data.Functor.Compose (Compose(..))
import Data.Int (Int)
import Data.Map.Strict (Map)
import Data.Maybe (Maybe(..), mapMaybe)
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (Seq)
import Data.String (String)
import Data.Text (Text)
import Data.TreeSeq.Strict (Tree(..))
import Data.Tuple (snd)
import Prelude (Num(..))
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.Text as Text
import qualified Data.Text.Lazy as TL
import qualified Data.TreeSeq.Strict.Zipper as Tree
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes  as HA
import qualified Text.Blaze.Internal as H
import System.FilePath (FilePath)

import Text.Blaze.Utils
import Data.Locale hiding (localize)
import qualified Data.Locale as Locale

import Language.DTC.Document (Document)
import Language.DTC.Write.XML ()
import Language.XML (XmlName(..), XmlPos(..))
import qualified Language.DTC.Document as DTC
-- import Debug.Trace (trace)

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

-- ** Type 'StateHtml5'
data StateHtml5
 =   StateHtml5
 { styles   :: Map FilePath CSS
 , scripts  :: Map FilePath Script
 , localize :: MsgHtml5 -> Html5
 }
stateHtml5 :: StateHtml5
stateHtml5 = StateHtml5
 { styles   = mempty
 , scripts  = mempty
 , localize = html5ify . show
 }
type CSS = Text
type Script = Text

-- ** Class 'Html5ify'
class Html5ify a where
	html5ify :: a -> Html5
instance Html5ify Char where
	html5ify = html5ify . H.toMarkup
instance Html5ify Text where
	html5ify = html5ify . H.toMarkup
instance Html5ify String where
	html5ify = html5ify . H.toMarkup
instance Html5ify H.Markup where
	html5ify = Compose . return
instance Html5ify DTC.Title where
	html5ify (DTC.Title t) = html5ify t
instance Html5ify DTC.Ident where
	html5ify (DTC.Ident i) = html5ify i

html5Document ::
 Localize ls Html5 MsgHtml5 =>
 Locales ls =>
 LocaleIn ls -> Document -> Html
html5Document locale DTC.Document{..} = do
	let (html5Body, StateHtml5{..}) =
		runStateMarkup stateHtml5 $ do
			liftStateMarkup $ S.modify $ \s -> s{localize = Locale.localize locale}
			html5ify body
	H.docType
	H.html ! HA.lang (attrValue $ countryCode locale) $ do
		H.head $ do
			H.meta ! HA.httpEquiv "Content-Type"
			       ! HA.content "text/html; charset=UTF-8"
			whenSome (DTC.titles $ DTC.about (head :: DTC.Head)) $ \ts ->
				H.title $
					H.toMarkup $ plainify $ List.head ts
			forM_ (DTC.links $ DTC.about (head :: DTC.Head)) $ \DTC.Link{rel, href} ->
				H.link ! HA.rel (attrValue rel)
				       ! HA.href (attrValue href)
			H.meta ! HA.name "generator"
			       ! HA.content "tct"
			let chapters =
				(`mapMaybe` toList body) $ \case
				 TreeN k _ -> Just k
				 _ -> Nothing
			forM_ chapters $ \DTC.Section{..} ->
				H.link ! HA.rel "Chapter"
				       ! HA.title (attrValue $ plainify title)
				       ! HA.href ("#"<>attrValue pos)
			H.link ! HA.rel "stylesheet"
			       ! HA.type_ "text/css"
			       ! HA.href "style/dtc-html5.css"
			forM_ styles $ \style ->
				H.style ! HA.type_ "text/css" $
					H.toMarkup style
			forM_ scripts $ \script ->
				H.script ! HA.type_ "application/javascript" $
					H.toMarkup script
		H.body
			html5Body

-- * Type 'BodyCursor'
-- | Cursor to navigate within a 'DTC.Body' according to many axis (like in XSLT).
type BodyCursor = Tree.Zipper DTC.BodyKey (Seq DTC.BodyValue)
instance Html5ify DTC.Body where
	html5ify body =
		forM_ (Tree.zippers body >>= Tree.axis_following_sibling) $
			html5ify

instance Html5ify BodyCursor where
	html5ify z =
		case Tree.current z of
		 TreeN k _ts -> html5BodyKey z k
		 Tree0 vs -> forM_ vs $ html5BodyValue z

html5BodyKey :: BodyCursor -> DTC.BodyKey -> Html5
html5BodyKey z = \case
	 DTC.Section{..} ->
		H.section ! HA.class_ "section"
		          ! HA.id (attrValue pos) $$ do
			html5CommonAttrs attrs $
				H.table ! HA.class_ "section-header" $$
					H.tbody $$
						H.tr $$ do
							H.td ! HA.class_ "section-number" $$ do
								html5SectionNumber $
									xmlPosAncestors pos
							H.td ! HA.class_ "section-title" $$ do
								html5ify title
			forM_ (Tree.axis_child z) $
				html5ify
html5BodyValue :: BodyCursor -> DTC.BodyValue -> Html5
html5BodyValue z = \case
	 DTC.Vertical v -> do
		html5ify v
	 DTC.ToC{..} -> do
		H.nav ! HA.class_ "toc"
		      ! HA.id (attrValue pos) $$ do
			H.span ! HA.class_ "toc-name" $$
				H.a ! HA.href (attrValue pos) $$
					html5ify MsgHTML5_Table_of_Contents
			H.ul $$
				forM_ (Tree.axis_following_sibling z) $
					html5ToC d
		where d = case depth of { Just (DTC.Nat n) -> n; _ -> 0 }
	 DTC.ToF{..} -> do
		H.nav ! HA.class_ "tof"
		      ! HA.id (attrValue pos) $$
			H.table ! HA.class_ "tof" $$
				H.tbody $$
					forM_ (Tree.axis_preceding z) $
						html5ToF d
		where d = case depth of { Just (DTC.Nat n) -> n; _ -> 0 }
	 DTC.Figure{..} ->
		html5CommonAttrs attrs $
		H.div ! HA.class_ (attrValue $ "figure-"<>type_)
		      ! HA.id (attrValue pos) $$ do
			H.table ! HA.class_ "figure-caption" $$
				H.tbody $$
					H.tr $$ do
						H.td ! HA.class_ "figure-number" $$ do
							H.a ! HA.href ("#"<>attrValue pos) $$
								html5ify type_
							": "
						H.td ! HA.class_ "figure-name" $$
							html5ify title
			H.div ! HA.class_ "figure-content" $$ do
				html5ify verts
html5ToC :: Int -> BodyCursor -> Html5
html5ToC depth z =
	case Tree.current z of
	 TreeN DTC.Section{..} _ts -> do
		H.li $$ do
			H.table ! HA.class_ "toc-entry" $$
				H.tbody $$
					H.tr $$ do
						H.td $$
							html5SectionRef $ xmlPosAncestors pos
						H.td $$
							html5ify title
			when (depth > 0) $
				H.ul $$
					forM_ (Tree.axis_child z) $
						html5ToC (depth - 1)
	 _ -> pure ()
html5ToF :: Int -> BodyCursor -> Html5
html5ToF depth z =
	case Tree.current z of
	 Tree0 bs ->
		forM_ bs $ \case
		 DTC.Figure{..} ->
			H.tr $$ do
				H.td ! HA.class_ "figure-number" $$
					H.a ! HA.href ("#"<>attrValue pos) $$
						html5ify type_
				H.td ! HA.class_ "figure-name" $$
					html5ify title
		 _ -> pure ()
	 _ -> pure ()

instance Html5ify [DTC.Vertical] where
	html5ify = mapM_ html5ify
instance Html5ify DTC.Vertical where
	html5ify = \case
	 DTC.Para{..} ->
		html5CommonAttrs attrs $
		H.div ! HA.class_ "para"
		      ! HA.id (attrValue pos) $$ do
			html5ify horis
	 DTC.OL{..} ->
		html5CommonAttrs attrs $
		H.ol ! HA.class_ "ol"
		     ! HA.id (attrValue pos) $$ do
			forM_ items $ \item ->
				H.li $$ html5ify item
	 DTC.UL{..} ->
		html5CommonAttrs attrs $
		H.ul ! HA.class_ "ul"
		     ! HA.id (attrValue pos) $$ do
			forM_ items $ \item ->
				H.li $$ html5ify item
	 DTC.RL{..} ->
		html5CommonAttrs attrs $
		H.div ! HA.class_ "rl"
		      ! HA.id (attrValue pos) $$ do
			H.table $$
				forM_ refs html5ify
	 DTC.Comment t ->
		html5ify $ H.Comment (H.Text t) ()
	{-
	 Index{..} -> 
	 Artwork{..} -> 
	-}
instance Html5ify DTC.Horizontal where
	html5ify = \case
		 DTC.BR       -> html5ify H.br
		 DTC.B    hs  -> H.strong $$ html5ify hs
		 DTC.Code hs  -> H.code   $$ html5ify hs
		 DTC.Del  hs  -> H.del    $$ html5ify hs
		 DTC.I    hs  -> H.i      $$ html5ify hs
		 DTC.Note _   -> ""
		 DTC.Q    hs  -> do
			"« "::Html5
			H.i $$ html5ify hs
			" »"
		 DTC.SC   hs  -> html5ify hs
		 DTC.Sub  hs  -> H.sub $$ html5ify hs
		 DTC.Sup  hs  -> H.sup $$ html5ify hs
		 DTC.U    hs  -> H.span ! HA.class_ "underline" $$ html5ify hs
		 DTC.Eref{..} ->
			H.a ! HA.class_ "eref"
			    ! HA.href (attrValue href) $$
				html5ify text
		 DTC.Iref{..} ->
			H.a ! HA.class_ "iref"
			    ! HA.href (attrValue to) $$
				html5ify text
		 DTC.Ref{..}  ->
			H.a ! HA.class_ "ref"
			    ! HA.href ("#"<>attrValue to) $$
			if null text
			then html5ify to
			else html5ify text
		 DTC.Rref{..} ->
			H.a ! HA.class_ "rref"
			    ! HA.href (attrValue to) $$
				html5ify text
		 DTC.Plain t  -> Compose $ return $ H.toMarkup t
instance Html5ify [DTC.Horizontal] where
	html5ify = mapM_ html5ify
instance Html5ify DTC.About where
	html5ify DTC.About{..} =
		forM_ titles $ \(DTC.Title title) ->
			html5ify $ DTC.Q title
instance Html5ify DTC.Reference where
	html5ify DTC.Reference{..} =
		H.tr $$ do
			H.td ! HA.class_ "reference-key" $$
				html5ify id
			H.td ! HA.class_ "reference-content" $$
				html5ify about

html5CommonAttrs :: DTC.CommonAttrs -> Html5 -> Html5
html5CommonAttrs DTC.CommonAttrs{..} =
	Compose . (addClass . addId <$>) . getCompose
	where
	addClass =
		case classes of
		 [] -> \x -> x
		 _  -> H.AddCustomAttribute "class" (H.Text $ Text.unwords classes)
	addId =
		case id of
		 Nothing -> \x -> x
		 Just (DTC.Ident i) ->
			H.AddCustomAttribute "id" (H.Text i)

html5SectionNumber :: [(XmlName,Int)] -> Html5
html5SectionNumber = go [] . List.reverse
	where
	go :: [(XmlName,Int)] -> [(XmlName,Int)] -> Html5
	go _rs [] = pure ()
	go rs (a@(_n,cnt):as) = do
		H.a ! HA.href (attrValue $ "#"<>textXmlPosAncestors (a:rs)) $$
			html5ify $ show cnt
		html5ify '.'
		go (a:rs) as

html5SectionRef :: [(XmlName,Int)] -> Html5
html5SectionRef as =
	H.a ! HA.href (attrValue $ "#"<>textXmlPosAncestors as) $$
		case as of
		 [(_n,c)] -> do
			html5ify $ show c
			html5ify '.'
		 _ ->
			html5ify $
				Text.intercalate "." $
				Text.pack . show . snd <$> as

textXmlPosAncestors :: [(XmlName,Int)] -> Text
textXmlPosAncestors =
	snd . foldr (\(n,c) (nParent,acc) ->
		(n,
			(if Text.null acc
				then acc
				else acc <> ".") <>
			Text.pack
			 (if n == nParent
				then show c
				else show n<>show c)
		)
	 )
	 ("","")

-- * Class 'Plainify'
class Plainify a where
	plainify :: a -> TL.Text
instance Plainify DTC.Horizontal where
	plainify = \case
	 DTC.BR       -> "\n"
	 DTC.B    hs  -> "*"<>plainify hs<>"*"
	 DTC.Code hs  -> "`"<>plainify hs<>"`"
	 DTC.Del  hs  -> "-"<>plainify hs<>"-"
	 DTC.I    hs  -> "/"<>plainify hs<>"/"
	 DTC.Note _   -> ""
	 DTC.Q    hs  -> "« "<>plainify hs<>" »"
	 DTC.SC   hs  -> plainify hs
	 DTC.Sub  hs  -> plainify hs
	 DTC.Sup  hs  -> plainify hs
	 DTC.U    hs  -> "_"<>plainify hs<>"_"
	 DTC.Eref{..} -> plainify text
	 DTC.Iref{..} -> plainify text
	 DTC.Ref{..}  -> plainify text
	 DTC.Rref{..} -> plainify text
	 DTC.Plain t  -> TL.fromStrict t
instance Plainify [DTC.Horizontal] where
	plainify = foldMap plainify
instance Plainify DTC.Title where
	plainify (DTC.Title t) = plainify t

instance AttrValue XmlPos where
	attrValue = attrValue . textXmlPosAncestors . xmlPosAncestors

-- * Type 'MsgHtml5'
data MsgHtml5
 =   MsgHTML5_Table_of_Contents
 deriving (Show)
instance Html5ify MsgHtml5 where
	html5ify msg = do
		loc <- liftStateMarkup $ S.gets localize
		loc msg
instance LocalizeIn FR Html5 MsgHtml5 where
	localizeIn _ = \case
	 MsgHTML5_Table_of_Contents -> "Sommaire"
instance LocalizeIn EN Html5 MsgHtml5 where
	localizeIn _ = \case
	 MsgHTML5_Table_of_Contents -> "Summary"