{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# 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.Bool
-- import Data.Functor.Compose (Compose(..))
-- import Data.Functor.Identity (Identity(..))
-- import Data.Map.Strict (Map)
-- import Data.String (IsString(..))
-- import Prelude (Num(..), undefined)
-- import qualified Control.Monad.Trans.State as S
-- import qualified Data.Map.Strict as Map
import Control.Monad (forM_, mapM_, when)
import Data.Eq (Eq(..))
import Data.Ord (Ord(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), (.))
import Data.Functor ((<$>))
import Data.Int (Int)
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.Text (Text)
import Data.Tuple (snd)
import Prelude (Num(..))
import Text.Blaze ((!))
import Text.Blaze.Html (Html)
import Text.Show (Show(..))
import qualified Data.List as List
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 Data.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)

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_localize :: MsgHtml5 -> Html
 }
inhHtml5 :: InhHtml5
inhHtml5 = InhHtml5
 { inhHtml5_localize = localizeIn @EN EN_US
 }

-- * Type 'MsgHtml5'
data MsgHtml5
 =   MsgHTML5_Table_of_Contents
instance LocalizeIn FR Html MsgHtml5 where
	localizeIn _ MsgHTML5_Table_of_Contents = "Sommaire"
instance LocalizeIn EN Html MsgHtml5 where
	localizeIn _ MsgHTML5_Table_of_Contents = "Table of Contents"

{- 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 ::
 Localize ls Html MsgHtml5 =>
 LocaleIn ls -> Document -> Html
html5Document loc DTC.Document{..} = do
	let inh = InhHtml5
		 { inhHtml5_localize = localize loc
		 }
	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 $
			html5Body inh body

html5Body :: InhHtml5 -> [DTC.Body] -> Html
html5Body _inh [] = mempty
html5Body inh@InhHtml5{..} (b:bs) =
	case b of
	 DTC.Section{..} -> do
		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
			html5Body inh body
		html5Body inh bs
		{- aliases :: [Alias]
		-}
	 DTC.Verticals vs -> do
		html5Verticals vs
		html5Body inh bs
	 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) $
					inhHtml5_localize MsgHTML5_Table_of_Contents
			H.ul $
				html5ToC d bs
		html5Body inh bs
		where d = case depth of { Just (DTC.Nat n) -> n; _ -> 0 }
	 DTC.ToF{..} -> do
		H.nav ! HA.class_ "tof"
		      ! HA.id (attrValue pos) $
			""
		html5Body inh bs

html5ToC :: Int -> [DTC.Body] -> Html
html5ToC _depth [] = mempty
html5ToC depth (b:bs) =
	case b of
	 DTC.Section{..} -> do
		H.li $ do
			H.table ! HA.class_ "toc-entry" $
				H.tbody $
					H.tr $ do
						H.td $
							html5SectionRef $ xmlPosAncestors pos
						H.td $
							html5Horizontals $ DTC.unTitle title
			when (depth > 0) $
				H.ul $ html5ToC (depth - 1) body
		html5ToC depth bs
	 _ -> html5ToC depth bs

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

html5SectionRef :: [(XmlName,Int)] -> Html
html5SectionRef as =
	H.a ! HA.href (attrValue $ "#"<>textXmlPosAncestors as) $
		case as of
		 [(_n,c)] -> do
			H.toMarkup $ show c
			H.toMarkup '.'
		 _ ->
			H.toMarkup $
				Text.intercalate "." $
				Text.pack . show . snd <$> 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
	{-
	 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