{-# 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.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), const, flip, on)
import Data.Functor (Functor(..), (<$>))
import Data.Functor.Compose (Compose(..))
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 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 qualified Language.DTC.Document as DTC
import qualified Language.DTC.Anchor as Anchor

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

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

-- ** Type 'State'
data State
 =   State
 { state_styles   :: Map FilePath CSS
 , state_scripts  :: Map FilePath Script
 , state_localize :: MsgHtml5 -> Html5
 , state_indexs   :: Map DTC.Pos (DTC.Terms, Anchor.Irefs)
 , state_figures  :: Map Text (Map DTC.Pos DTC.Title)
 }
state :: State
state = State
 { state_styles   = mempty
 , state_scripts  = mempty
 , state_localize = html5ify . show
 , state_indexs   = mempty
 , state_figures  = mempty
 }
type CSS = Text
type Script = Text

-- ** Type 'Keys'
data Keys
 = Keys
 { keys_index  :: Map DTC.Pos DTC.Terms
 , keys_figure :: Map Text (Map DTC.Pos DTC.Title)
 } deriving (Show)

keys :: Trees DTC.BodyKey DTC.BodyValue -> Keys
keys body = foldl' flt (Keys mempty mempty) (Compose body)
	where
	flt acc = \case
	 DTC.Index{..} -> acc{keys_index =
		Map.insert pos terms $ keys_index acc}
	 DTC.Figure{..} -> acc{keys_figure =
		Map.insertWith (<>)
		 type_ (Map.singleton pos title) $
		keys_figure 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',state_indexs) =
		let irefs = foldMap Anchor.irefsOfTerms keys_index in
		(<$> S.runState (Anchor.anchorify body) Anchor.state
			 { Anchor.state_irefs = irefs }) $ \Anchor.State{state_irefs} ->
			(<$> keys_index) $ \terms ->
				(terms,) $
				TreeMap.intersection const state_irefs $
				Anchor.irefsOfTerms terms
	let (html5Body, State{state_styles,state_scripts}) =
		runStateMarkup state{state_indexs, state_figures=keys_figure} $ do
			liftStateMarkup $ S.modify $ \s -> s{state_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_ state_styles $ \style ->
				H.style ! HA.type_ "text/css" $
					H.toMarkup style
			forM_ state_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 $ DTC.posAncestors pos
							H.td ! HA.class_ "section-title" $$ do
								(case List.length $ DTC.posAncestors 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) $
					html5ifyToC depth
	 DTC.ToF{..} -> do
		H.nav ! HA.class_ "tof"
		      ! HA.id (attrValue pos) $$
			H.table ! HA.class_ "tof" $$
				H.tbody $$
					html5ifyToF types
	 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) $$ do
								html5ify type_
								html5ify $ DTC.posAncestors pos
							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) . state_indexs
		let chars = Anchor.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 term) $$
											html5ify term
							H.dd $$ do
								let anchs =
									List.sortBy (compare `on` DTC.section . snd) $
									(`foldMap` aliases) $ \words ->
										fromJust $ do
											path <- Anchor.pathFromWords words
											Strict.maybe Nothing (Just . ((words,) <$>) . List.reverse) $
												TreeMap.lookup path refsByTerm
								sequence_ $
									List.intersperse ", " $
									(<$> anchs) $ \(term,DTC.Anchor{..}) ->
										H.a ! HA.href ("#"<>attrValue (term,count)) $$
											html5ify $
												List.intercalate "." $
												toList $
												(<$> DTC.posAncestors section) $ \(_n,c) -> show c

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

cleanPara :: DTC.Para -> DTC.Para
cleanPara p =
	p >>= (`Tree.bindTrees` \case
	 TreeN DTC.Iref{} ls -> ls
	 TreeN DTC.Note{} _  -> mempty
	 h -> pure h)

html5ifyToC :: Maybe DTC.Nat -> BodyCursor -> Html5
html5ifyToC 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 $ DTC.posAncestors pos
						H.td ! HA.class_ "section-title" $$
							html5ify $ cleanPara $ DTC.unTitle title
			when (maybe True (> DTC.Nat 1) depth && not (null sections)) $
				H.ul $$
					forM_ sections $
						html5ifyToC (depth >>= DTC.predNat)
	 _ -> pure ()
	where
	sections =
		(`Tree.runAxis` z) $
		Tree.axis_child
		`Tree.axis_filter_current` \case
		 TreeN DTC.Section{} _ -> True
		 _ -> False

html5ifyToF :: [Text] -> Html5
html5ifyToF types = do
	figsByType <- liftStateMarkup $ S.gets state_figures
	let figs =
		Map.foldMapWithKey (\ty -> ((ty,) <$>)) $
		if null types
		then figsByType
		else
			Map.intersection figsByType $
			Map.fromList [(ty,()) | ty <- types]
	forM_ (Map.toList figs) $ \(pos, (type_, title)) ->
		H.tr $$ do
			H.td ! HA.class_ "figure-number" $$
				H.a ! HA.href ("#"<>attrValue pos) $$ do
					html5ify type_
					html5ify $ DTC.posAncestors pos
			H.td ! HA.class_ "figure-name" $$
				html5ify $ cleanPara $ DTC.unTitle title

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{..} ->
			case anchor of
			 Nothing -> html5ify ls
			 Just DTC.Anchor{..} ->
				H.span ! HA.class_ "iref"
				       ! HA.id (attrValue (term,count)) $$
					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 DTC.Words where
	attrValue term =
		"iref" <> "." <> attrValue (Anchor.plainifyWords term)
instance AttrValue (DTC.Words,DTC.Nat1) where
	attrValue (term,count) =
		"iref"
		 <> "." <> attrValue (Anchor.plainifyWords term)
		 <> "." <> attrValue count
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 ref@DTC.Reference{about} =
		H.tr $$ do
			H.td ! HA.class_ "reference-key" $$
				html5ifyReference ref
			H.td ! HA.class_ "reference-content" $$
				html5ify about

html5ifyReference :: DTC.Reference -> Html5
html5ifyReference DTC.Reference{id=id_, ..} = do
	let i = "reference."<>attrValue id_
	"["::Html5
	H.a ! HA.id i ! HA.href ("#"<>i) $$
		html5ify id_
	"]"

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 :: DTC.PosPath -> Html5
html5SectionNumber = go mempty
	where
	go :: DTC.PosPath -> DTC.PosPath -> Html5
	go prev next =
		case Seq.viewl next of
		 Seq.EmptyL -> pure ()
		 a@(_n,rank) Seq.:< as -> do
			H.a ! HA.href ("#"<>attrValue (prev Seq.|>a)) $$
				html5ify $ show rank
			when (not (null as) || null prev) $ do
				html5ify '.'
				go (prev Seq.|>a) as

html5SectionRef :: DTC.PosPath -> Html5
html5SectionRef as =
	H.a ! HA.href ("#"<>attrValue as) $$
		html5ify as

instance Html5ify DTC.PosPath where
	html5ify ancs =
		case toList ancs of
		 [(_n,c)] -> do
			html5ify $ show c
			html5ify '.'
		 as ->
			html5ify $
				Text.intercalate "." $
				Text.pack . show . snd <$> as

instance AttrValue DTC.PosPath where
	attrValue = attrValue . plainify
instance AttrValue DTC.Pos where
	attrValue = attrValue . DTC.posAncestors

-- * 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 Plainify DTC.PosPath where
	plainify =
		snd . foldl' (\(nParent,acc) (n,c) ->
			(n,
				(if TL.null acc
					then acc
					else acc <> ".") <>
				TL.pack
				 (if n == nParent
					then show c
					else show n<>show c)
			)
		 )
		 ("","")

-- * 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 state_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 -> "”"