{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# 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.Bool
-- import Data.Eq (Eq(..))
-- import Data.String (IsString(..))
-- import Prelude (Num(..), undefined)
import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..), forM_, mapM_)
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), (.), const)
import Data.Functor (Functor(..), (<$>), ($>))
import Data.Functor.Compose (Compose(..))
import Data.Functor.Identity (Identity(..))
import Data.Int (Int)
import Data.Map.Strict (Map)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.Text (Text)
import Data.Tuple (snd)
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.Map.Strict as Map
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 qualified Text.Blaze.Internal as H

import Text.Blaze.Utils

import Language.DTC.Document (Document)
import Language.DTC.Write.XML ()
import Language.TCT.Write.XML (XmlName(..), XmlPos(..))
import qualified Language.DTC.Document as DTC

-- import Debug.Trace (trace)

instance H.ToMarkup DTC.Ident where
	toMarkup (DTC.Ident i) = H.toMarkup i
instance AttrValue XmlPos where
	attrValue = attrValue . textXmlPosAncestors . xmlPosAncestors

-- * Type 'InhHtml5'
data InhHtml5
 =   InhHtml5
inhHtml5 :: InhHtml5
inhHtml5 = InhHtml5

{- NOTE: composing state and markups
type HtmlM st = Compose (S.State st) H.MarkupM
instance Monad (HtmlM st) where
	return = pure
	Compose sma >>= a2csmb =
		Compose $ sma >>= \ma ->
			case ma >>= H.Empty . a2csmb of
			 H.Append _ma (H.Empty csmb) ->
				H.Append ma <$> getCompose csmb
			 _ -> undefined

($$) :: (Html -> Html) -> HTML -> HTML
($$) f m = Compose $ f <$> getCompose m
infixr 0 $$
-}

unMarkupValue :: H.MarkupM a -> b -> H.MarkupM b
unMarkupValue = \case
 H.Parent x0 x1 x2 m          -> H.Parent x0 x1 x2 . unMarkupValue m
 H.CustomParent x0 m          -> H.CustomParent x0 . unMarkupValue m
 H.Leaf x0 x1 x2 _            -> H.Leaf x0 x1 x2
 H.CustomLeaf x0 x1 _         -> H.CustomLeaf x0 x1
 H.Content x0 _               -> H.Content x0
 H.Comment x0 _               -> H.Comment x0
 H.Append x0 m                -> H.Append x0 . unMarkupValue m
 H.AddAttribute x0 x1 x2 m    -> H.AddAttribute x0 x1 x2 . unMarkupValue m
 H.AddCustomAttribute x0 x1 m -> H.AddCustomAttribute x0 x1 . unMarkupValue m
 H.Empty _                    -> H.Empty

markupValue :: H.MarkupM a -> a
markupValue m0 = case m0 of
 H.Parent _ _ _ m1           -> markupValue m1
 H.CustomParent _ m1         -> markupValue m1
 H.Leaf _ _ _ x              -> x
 H.CustomLeaf _ _ x          -> x
 H.Content _ x               -> x
 H.Comment _ x               -> x
 H.Append _ m1               -> markupValue m1
 H.AddAttribute _ _ _ m1     -> markupValue m1
 H.AddCustomAttribute _ _ m1 -> markupValue m1
 H.Empty x                   -> x

html5Document :: Document -> Html
html5Document DTC.Document{..} = do
	H.docType
	H.html $ 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 ->
				let t = textHorizontals $ List.head $ (DTC.unTitle <$> ts) <> [[DTC.Plain ""]] in
				H.title $ H.toMarkup t
			-- link ! rel "Chapter" ! title "SomeTitle">
			H.link ! HA.rel "stylesheet"
			       ! HA.type_ "text/css"
			       ! HA.href "style/dtc-html5.css"
		H.body $
			forM_ body html5Body
html5Body :: DTC.Body -> Html
html5Body = \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
								html5Horizontals $ DTC.unTitle title
			forM_ body html5Body
		{- aliases :: [Alias]
		-}
	 DTC.Verticals vs -> html5Verticals vs

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)
		)
	 ) ("","")

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

html5Verticals :: [DTC.Vertical] -> Html
html5Verticals = foldMap html5Vertical

html5Vertical :: DTC.Vertical -> Html
html5Vertical = \case
	 DTC.Para{..} ->
		html5CommonAttrs attrs $
		H.div ! HA.class_ "para"
		      ! HA.id (attrValue pos) $ do
			html5Horizontals horis
	 DTC.OL{..} ->
		html5CommonAttrs attrs $
		H.ol ! HA.class_ "ol"
		     ! HA.id (attrValue pos) $ do
			forM_ items $ \item ->
				H.li $ html5Verticals item
	 DTC.UL{..} ->
		html5CommonAttrs attrs $
		H.ul ! HA.class_ "ul"
		     ! HA.id (attrValue pos) $ do
			forM_ items $ \item ->
				H.li $ html5Verticals item
	 DTC.RL{..} ->
		html5CommonAttrs attrs $
		H.div ! HA.class_ "rl"
		      ! HA.id (attrValue pos) $ do
			H.table $
				forM_ refs html5Reference
	 DTC.Comment t ->
		H.Comment (H.Text t) ()
	 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 "" $ H.toMarkup type_
							": "
						H.td ! HA.class_ "figure-name" $
							html5Horizontals $ DTC.unTitle title
			H.div ! HA.class_ "figure-content" $ do
				html5Verticals verts
	 DTC.ToC{..} ->
		H.nav ! HA.class_ "toc"
		      ! HA.id (attrValue pos) $
		""
	 DTC.ToF{..} -> 
		H.nav ! HA.class_ "tof"
		      ! HA.id (attrValue pos) $
		""
	{-
	 Index{..} -> 
	 Artwork{..} -> 
	-}

html5Reference :: DTC.Reference -> Html
html5Reference DTC.Reference{..} =
	H.tr $ do
		H.td ! HA.class_ "reference-key" $
			H.toMarkup id
		H.td ! HA.class_ "reference-content" $
			html5About about

html5About :: DTC.About -> Html
html5About DTC.About{..} =
	forM_ titles $ \(DTC.Title title) -> do
		html5Horizontal $ DTC.Q title
	{-
	authors
	editor
	date
	version
	keywords
	links
	series
	includes
	-}

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

html5Horizontal :: DTC.Horizontal -> Html
html5Horizontal = \case
	 DTC.BR       -> H.br
	 DTC.B    hs  -> H.strong $ html5Horizontals hs
	 DTC.Code hs  -> H.code   $ html5Horizontals hs
	 DTC.Del  hs  -> H.del    $ html5Horizontals hs
	 DTC.I    hs  -> H.i      $ html5Horizontals hs
	 DTC.Note _   -> ""
	 DTC.Q    hs  -> "« "<>H.i (html5Horizontals hs)<>" »"
	 DTC.SC   hs  -> html5Horizontals hs
	 DTC.Sub  hs  -> H.sub $ html5Horizontals hs
	 DTC.Sup  hs  -> H.sup $ html5Horizontals hs
	 DTC.U    hs  -> H.span ! HA.class_ "underline" $ html5Horizontals hs
	 DTC.Eref{..} -> H.a ! HA.class_ "eref" ! HA.href (attrValue href) $ html5Horizontals text
	 DTC.Iref{..} -> H.a ! HA.class_ "iref" ! HA.href (attrValue to)   $ html5Horizontals text
	 DTC.Ref{..}  ->
		H.a ! HA.class_ "ref"
		    ! HA.href ("#"<>attrValue to) $
		if null text
		then H.toMarkup to
		else html5Horizontals text
	 DTC.Rref{..} -> H.a ! HA.class_ "rref" ! HA.href (attrValue to)   $ html5Horizontals text
	 DTC.Plain t  -> H.toMarkup t

html5Horizontals :: [DTC.Horizontal] -> Html
html5Horizontals = mapM_ html5Horizontal

textHorizontal :: DTC.Horizontal -> TL.Text
textHorizontal = \case
	 DTC.BR       -> "\n"
	 DTC.B    hs  -> "*"<>textHorizontals hs<>"*"
	 DTC.Code hs  -> "`"<>textHorizontals hs<>"`"
	 DTC.Del  hs  -> "-"<>textHorizontals hs<>"-"
	 DTC.I    hs  -> "/"<>textHorizontals hs<>"/"
	 DTC.Note _   -> ""
	 DTC.Q    hs  -> "« "<>textHorizontals hs<>" »"
	 DTC.SC   hs  -> textHorizontals hs
	 DTC.Sub  hs  -> textHorizontals hs
	 DTC.Sup  hs  -> textHorizontals hs
	 DTC.U    hs  -> "_"<>textHorizontals hs<>"_"
	 DTC.Eref{..} -> textHorizontals text
	 DTC.Iref{..} -> textHorizontals text
	 DTC.Ref{..}  -> textHorizontals text
	 DTC.Rref{..} -> textHorizontals text
	 DTC.Plain t  -> TL.fromStrict t

textHorizontals :: [DTC.Horizontal] -> TL.Text
textHorizontals = foldMap textHorizontal