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

-- import Control.Monad.Trans.Class (MonadTrans(..))
-- import Data.Functor.Identity (Identity(..))
-- import Data.Sequence (Seq)
-- import Data.Set (Set)
-- import Data.Traversable (Traversable(..))
-- import qualified Data.Sequence as Seq
-- import qualified Data.TreeSeq.Strict as Tree
import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..), sequence_, forM_, mapM_, when, (>=>))
import Data.Bool
import Data.Char (Char)
import Data.Default.Class (Default(..))
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..), concat, any)
import Data.Function (($), (.), const, flip, on)
import Data.Functor (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.String (String)
import Data.Text (Text)
import Data.TreeSeq.Strict (Tree(..), Trees)
import Data.Tuple (snd)
import Prelude (Num(..))
import System.FilePath (FilePath)
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.Set as Set
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 Text.Blaze.Utils
import Data.Locale hiding (localize, Index)
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 qualified Language.DTC.Index as Index
-- import Debug.Trace (trace)

(<&>) :: Functor f => f a -> (a -> b) -> f b
(<&>) = flip (<$>)
infixl 4 <&>

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

-- ** Type 'State'
data State
 =   State
 { styles   :: Map FilePath CSS
 , scripts  :: Map FilePath Script
 , localize :: MsgHtml5 -> Html5
 , indexs   :: Map XmlPos ( [[Index.Term]]
                          , Map Index.Term [Index.Ref] )
 }
state :: State
state = State
 { styles   = mempty
 , scripts  = mempty
 , localize = html5ify . show
 , indexs   = mempty
 }
type CSS = Text
type Script = Text

-- ** Type 'Keys'
data Keys
 = Keys
 { keys_index :: Map XmlPos [[Index.Term]]
 } deriving (Show)

keys :: Trees DTC.BodyKey DTC.BodyValue -> Keys
keys body = foldl' flt (Keys mempty) (Compose body)
	where
	flt acc = \case
	 DTC.Index{..} -> acc{keys_index =
		Map.insert pos terms $ keys_index acc}
	 _ -> acc

-- ** 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 Keys{..} = keys body
	let (body',indexs) =
		if null keys_index
		then (body, mempty)
		else
			let allTerms = (Set.fromList . concat) `foldMap` keys_index in
			(<$> S.runState
				 (Index.indexify body)
				 Index.state
					 { Index.state_terms = Map.fromSet (const []) allTerms
					 }) $ \Index.State{state_terms} ->
				(<$> keys_index) $ \terms ->
					(terms,) $
					Map.intersection state_terms $
					Map.fromSet (const ()) $
					Set.fromList $ concat $
					terms
	let (html5Body, State{styles,scripts}) =
		runStateMarkup state{indexs} $ 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@DTC.Section{} _ -> 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 DTC.BodyValue
instance Html5ify DTC.Body where
	html5ify body =
		forM_ (Tree.zippers body >>= Tree.axis_repeat Tree.axis_following1) $
			html5ify

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

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
								(case List.length $ xmlPosAncestors pos of
								 0 -> H.h1
								 1 -> H.h2
								 2 -> H.h3
								 3 -> H.h4
								 4 -> H.h5
								 5 -> H.h6
								 _ -> H.h6) $$
									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
	 DTC.Index{pos} -> do
		(allTerms,refsByTerm) <- liftStateMarkup $ S.gets $ (Map.! pos) . indexs
		let chars = Index.aliasesByChar allTerms
		H.div ! HA.class_ "index"
		      ! HA.id (attrValue pos) $$ do
			H.nav ! HA.class_ "index-nav-chars" $$ do
				forM_ (Map.keys chars) $ \char ->
					H.a ! HA.href ("#"<>(attrValue pos <> "." <> attrValue char)) $$
						html5ify char
			H.dl $$
				forM_ (Map.toList chars) $ \(char,terms) -> do
					H.dt $$
						let i = attrValue pos <> "." <> attrValue char in
						H.a ! HA.id i
						    ! HA.href ("#"<>i) $$
							html5ify char
					H.dd $$
						H.dl ! HA.class_ "index-char-refs" $$ do
						forM_ terms $ \aliases -> do
							H.dt $$
								forM_ aliases $ \term ->
									H.ul $$
										H.li ! HA.id (attrValue Index.Ref{term, count=0, section=def}) $$
											html5ify term
							H.dd $$ do
								let refs =
									List.sortBy
									 (compare `on` Index.section) $
									(`foldMap` aliases) $ \term ->
										refsByTerm Map.! term
								sequence_ $
									List.intersperse ", " $
									(<$> refs) $ \ref@Index.Ref{..} ->
										H.a ! HA.href ("#"<>attrValue ref) $$
											html5ify $
												List.intercalate "." $
												List.reverse $
												(<$> xmlPosAncestors section) $ \(_n,c) -> show c

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 ! HA.class_ "section-number" $$
							html5SectionRef $ xmlPosAncestors pos
						H.td ! HA.class_ "section-title" $$
							html5ify $
								DTC.unTitle title >>= \case
								 DTC.Iref{..} -> text
								 DTC.Note{} -> []
								 h -> [h]
			let sections =
				($ z) $ Tree.axis_child
				`Tree.axis_filter_current` \case
				 TreeN DTC.Section{} _ -> True
				 _ -> False
			when (depth > 0 && not (null sections)) $
				H.ul $$
					forM_ sections $
						html5ToC (depth - 1)
	 _ -> pure ()

html5ToF :: Int -> BodyCursor -> Html5
html5ToF depth z =
	case Tree.current z of
	 Tree0 v ->
		case v of
		 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.p ! 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) ()
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  ->
		H.span ! HA.class_ "q" $$ do
			"« "::Html5
			H.i $$ html5ify hs
			" »"
	 DTC.SC   hs  -> H.span ! HA.class_ "smallcaps" $$ 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.span ! HA.class_ "iref"
		       ! HA.id (attrValue Index.Ref{term, count, section=def}) $$
			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  -> html5ify t
instance AttrValue Index.Ref where
	attrValue Index.Ref{..} =
		"iref" <> "." <> attrValue term <>
		if count > 0
		then "." <> attrValue count
		else ""
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"