{-# 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.Category
import Control.Monad
import Data.Bool
import Data.Char (Char)
import Data.Default.Class (Default(..))
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
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(..), maybe, mapMaybe, fromJust, listToMaybe)
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.Sequence as Seq
import qualified Data.Strict.Maybe as Strict
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
import qualified Data.TreeMap.Strict as TreeMap
import qualified Data.TreeSeq.Strict as Tree
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 (DTC.Terms, Index.Refs)
 }
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 DTC.Terms
 } 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.Para where
	html5ify = mapM_ html5ify
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) =
		case foldMap Index.refsOfTerms keys_index of
		 refs | null refs -> (body, mempty)
		      | otherwise ->
			(<$> S.runState
				 (Index.indexify body)
				 Index.state
					 { Index.state_refs = refs
					 }) $ \Index.State{state_refs} ->
				(<$> keys_index) $ \terms ->
					(terms,) $
					TreeMap.intersection const state_refs $
					Index.refsOfTerms 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) $ \z ->
			forM_ (Tree.axis_repeat Tree.axis_following_sibling_nearest `Tree.runAxis` z) $
				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 `Tree.runAxis` z) $
				html5ify
html5BodyValue :: BodyCursor -> DTC.BodyValue -> Html5
html5BodyValue z = \case
	 DTC.Block b -> html5ify b
	 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 `Tree.runAxis` 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 `Tree.runAxis` z) $
						html5ToF d
		where d = case depth of { Just (DTC.Nat n) -> n; _ -> 0 }
	 DTC.Figure{..} ->
		html5CommonAttrs attrs $
		H.div ! HA.class_ ("figure " <> 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_
							html5ify $ MsgHTML5_Colon
							" "
						H.td ! HA.class_ "figure-name" $$
							html5ify title
			H.div ! HA.class_ "figure-content" $$ do
				html5ify blocks
	 DTC.Index{pos} -> do
		(allTerms,refsByTerm) <- liftStateMarkup $ S.gets $ (Map.! pos) . indexs
		let chars = Index.termsByChar allTerms
		H.div ! HA.class_ "index"
		      ! HA.id (attrValue pos) $$ do
			H.nav ! HA.class_ "index-nav" $$ do
				forM_ (Map.keys chars) $ \char ->
					H.a ! HA.href ("#"<>(attrValue pos <> "." <> attrValue char)) $$
						html5ify char
			H.dl ! HA.class_ "index-chars" $$
				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-term" $$ do
						forM_ terms $ \aliases -> do
							H.dt $$
								H.ul ! HA.class_ "index-aliases" $$
									forM_ (listToMaybe aliases) $ \term ->
										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) $ \words -> fromJust $ do
										path <- Index.pathFromWords words
										Strict.maybe Nothing (Just . List.reverse) $
											TreeMap.lookup path refsByTerm
								sequence_ $
									List.intersperse ", " $
									(<$> refs) $ \ref@Index.Ref{..} ->
										H.a ! HA.href ("#"<>attrValue ref) $$
											html5ify $
												List.intercalate "." $
												List.reverse $
												(<$> xmlPosAncestors section) $ \(_n,c) -> show c

instance Html5ify DTC.Words where
	html5ify = html5ify . Index.plainifyWords

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 >>= \ts -> Tree.bindTrees ts $ \case
								 TreeN DTC.Iref{} ls -> ls
								 TreeN DTC.Note{} _ -> mempty
								 h -> pure h
			let sections =
				(`Tree.runAxis` 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.Block] where
	html5ify = mapM_ html5ify
instance Html5ify DTC.Block where
	html5ify = \case
	 DTC.Para{..} ->
		html5CommonAttrs attrs $
		H.p ! HA.class_ "para"
		    ! HA.id (attrValue pos) $$ do
			html5ify para
	 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.Lines where
	html5ify = \case
	 Tree0 v ->
		case v of
		 DTC.BR      -> html5ify H.br
		 DTC.Plain t -> html5ify t
	 TreeN k ls ->
		case k of
		 DTC.B    -> H.strong $$ html5ify ls
		 DTC.Code -> H.code   $$ html5ify ls
		 DTC.Del  -> H.del    $$ html5ify ls
		 DTC.I    -> H.i      $$ html5ify ls
		 DTC.Sub  -> H.sub    $$ html5ify ls
		 DTC.Sup  -> H.sup    $$ html5ify ls
		 DTC.SC   -> H.span ! HA.class_ "smallcaps" $$ html5ify ls
		 DTC.U    -> H.span ! HA.class_ "underline" $$ html5ify ls
		 DTC.Note -> ""
		 DTC.Q ->
			H.span ! HA.class_ "q" $$ do
				html5ify MsgHTML5_QuoteOpen
				H.i $$ html5ify ls
				html5ify MsgHTML5_QuoteClose
		 DTC.Eref{..} ->
			H.a ! HA.class_ "eref"
			    ! HA.href (attrValue href) $$
				html5ify ls
		 DTC.Iref{..} ->
			H.span ! HA.class_ "iref"
			       ! HA.id (attrValue Index.Ref{term, count, section=def}) $$
				html5ify ls
		 DTC.Ref{..} ->
			H.a ! HA.class_ "ref"
			    ! HA.href ("#"<>attrValue to) $$
			if null ls
			then html5ify to
			else html5ify ls
		 DTC.Rref{..} ->
			H.a ! HA.class_ "rref"
			    ! HA.href (attrValue to) $$
				html5ify ls
instance AttrValue Index.Ref where
	attrValue Index.Ref{..} =
		"iref" <> "." <> attrValue (Index.plainifyWords term) <>
		if count > 0
		then "." <> attrValue count
		else ""
instance Html5ify DTC.About where
	html5ify DTC.About{..} =
		forM_ titles $ \(DTC.Title title) ->
			html5ify $ Seq.singleton $ TreeN DTC.Q title
instance Html5ify DTC.Reference where
	html5ify DTC.Reference{id=id_, ..} =
		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{id=id_, ..} =
	Compose . (addClass . addId <$>) . getCompose
	where
	addClass =
		case classes of
		 [] -> id
		 _  -> H.AddCustomAttribute "class" (H.Text $ Text.unwords classes)
	addId = maybe id (\(DTC.Ident i) ->
		H.AddCustomAttribute "id" (H.Text i)) id_

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
		when (not (null as) || null rs) $ do
			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 TL.Text where
	plainify = id
instance Plainify Text where
	plainify = TL.fromStrict
instance Plainify DTC.Para where
	plainify = foldMap plainify
instance Plainify DTC.Lines where
	plainify = \case
	 Tree0 v ->
		case v of
		 DTC.BR -> "\n"
		 DTC.Plain p -> plainify p
	 TreeN k ls ->
		case k of
		 DTC.B        -> "*"<>plainify ls<>"*"
		 DTC.Code     -> "`"<>plainify ls<>"`"
		 DTC.Del      -> "-"<>plainify ls<>"-"
		 DTC.I        -> "/"<>plainify ls<>"/"
		 DTC.Note     -> ""
		 DTC.Q        -> "« "<>plainify ls<>" »"
		 DTC.SC       -> plainify ls
		 DTC.Sub      -> plainify ls
		 DTC.Sup      -> plainify ls
		 DTC.U        -> "_"<>plainify ls<>"_"
		 DTC.Eref{..} -> plainify ls
		 DTC.Iref{..} -> plainify ls
		 DTC.Ref{..}  -> plainify ls
		 DTC.Rref{..} -> plainify ls
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
 |   MsgHTML5_Colon
 |   MsgHTML5_QuoteOpen
 |   MsgHTML5_QuoteClose
 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"
	 MsgHTML5_Colon -> " :"
	 MsgHTML5_QuoteOpen -> "« "
	 MsgHTML5_QuoteClose -> " »"
instance LocalizeIn EN Html5 MsgHtml5 where
	localizeIn _ = \case
	 MsgHTML5_Table_of_Contents -> "Summary"
	 MsgHTML5_Colon -> ":"
	 MsgHTML5_QuoteOpen  -> "“"
	 MsgHTML5_QuoteClose -> "”"