{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hdoc.DTC.Write.HTML5.Error where

import Control.Applicative (Applicative(..))
import Control.Monad (forM_, mapM_)
import Data.Default.Class (Default(..))
import Data.Either (Either(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), (.))
import Data.Functor ((<$>))
import Data.Int (Int)
import Data.Locale hiding (Index)
import Data.Map.Strict (Map)
import Data.Maybe (Maybe(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (Seq(..))
import Data.TreeSeq.Strict (tree0)
import Data.Tuple (fst, snd)
import Text.Blaze ((!))
import Text.Show (Show(..))
import qualified Control.Monad.Trans.RWS.Strict as RWS
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Text.Lazy as TL
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes  as HA

import Control.Monad.Utils
import Hdoc.DTC.Document as DTC
import Hdoc.DTC.Write.HTML5.Base
import Hdoc.DTC.Write.HTML5.Ident
import Hdoc.DTC.Write.XML ()
import Text.Blaze.Utils
import qualified Hdoc.DTC.Analyze.Check as Analyze
import qualified Hdoc.DTC.Analyze.Collect as Analyze
import qualified Hdoc.DTC.Write.Plain as Plain
import qualified Hdoc.TCT.Cell as TCT
import qualified Hdoc.XML as XML

instance (Html5ify Plain, Html5ify TCT.Location) => Html5ify (Analyze.Errors (Seq Location)) where
	html5ify Analyze.Errors{..} = do
		Reader
		 { reader_all  = Analyze.All{..}
		 , reader_l10n = Loqualization (l10n::FullLocale lang)
		 , ..
		 } <- composeLift RWS.ask
		let errors :: [ ( Int{-errKind-}
		                , HTML5{-errKindDescr-}
		                , [(Plain{-errTypeKey-}, [(TCT.Location{-errPos-}, Ident{-errId-})])]
		                ) ] =
			List.zipWith
			 (\errKind (errKindDescr, errByPosByKey) ->
				(errKind, errKindDescr l10n, errByPosByKey))
			 [1::Int ..]
			 [ (l10n_Error_At_unknown                , errorAt "-unknown"   errors_at_unknown)
			 , (l10n_Error_At_ambiguous              , errorAt "-ambiguous" errors_at_ambiguous)
			 , (l10n_Error_Rref_unknown              , errorReference "-unknown"   errors_ref_unknown)
			 , (l10n_Error_Reference_ambiguous       , errorReference "-ambiguous" errors_reference_ambiguous)
			 , (l10n_Error_Judgment_Judges_unknown   , errorIdent errors_judgment_judges_unknown)
			 , (l10n_Error_Judgment_Grades_unknown   , errorIdent errors_judgment_grades_unknown)
			 , (l10n_Error_Judgment_Grades_duplicated, errorIdent errors_judgment_grades_duplicated)
			 , (l10n_Error_Judgment_Judge_unknown    , errorName  errors_judgment_judge_unknown)
			 , (l10n_Error_Judgment_Judge_duplicated , errorName  errors_judgment_judge_duplicated)
			 , (l10n_Error_Judgment_Choice_duplicated, errorTitle errors_judgment_choice_duplicated)
			 , (l10n_Error_Judgment_Grade_unknown    , errorName  errors_judgment_grade_unknown)
			 ]
		let numErrors = Nat $ sum $ (<$> errors) $ \(_typ, _descr, errByPosByKey) ->
			sum $ length . snd <$> errByPosByKey
		when (numErrors > Nat 0) $ do
			composeLift $ RWS.tell def
			 { writer_styles  = HS.fromList
				 [ Left "dtc-errors.css"
				 , Right $
					-- NOTE: Implement a CSS-powered show/hide logic, using :target
					"\n@media screen {" <>
					"\n\t.error-filter:target .errors-list > li {display:none;}" <>
					(`foldMap` errors) (\(num, _description, errs) ->
						if null errs then "" else
							let err = "error-type"<>TL.pack (show num)<>"\\." in
							"\n\t.error-filter#"<>err<>":target .errors-list > li."<>err
							 <>" {display:list-item}" <>
							"\n\t.error-filter#"<>err<>":target .errors-nav > ul > li."<>err
							 <>" {list-style-type:disc;}"
					 ) <>
					"\n}"
				 ]
			 }
			filterIds errors $ H.div ! HA.class_ "document-errors" ! HA.id "document-errors." $$ do
				H.nav ! HA.class_ "errors-nav" $$ do
					H.p ! HA.class_ "errors-all" $$
						H.a ! HA.href (refIdent "document-errors.") $$ do
							l10n_Errors_All l10n numErrors :: HTML5
					H.ul $$
						forM_ errors $
						 \(errKind, errKindDescr, errs) -> do
							unless (null errs) $ do
								H.li ! HA.class_ (attrify $ errorType errKind) $$ do
									H.a ! HA.href (refIdent $ errorType errKind) $$ do
										errKindDescr
										" ("::HTML5
										html5ify $ sum $ length . snd <$> errs
										")"
				H.ol ! HA.class_ "errors-list" $$ do
					let errByPosByKind :: Map TCT.Location{-errPos-}
					                          (Seq ( Int{-errKind-}
					                               , HTML5{-errKindDescr-}
					                               , Plain{-errKey-}
					                               , [(TCT.Location{-errPos-}, Ident{-errId-})] )) =
						Map.unionsWith (<>) $ (<$> errors) $ \(errKind, errKindDescr, errByKey) ->
							Map.unionsWith (<>) $ (<$> errByKey) $ \(errKey, errByPos) ->
								Map.singleton (fst $ List.head errByPos) $
								 -- NOTE: sort using the first position of this errKind with this errKey.
									pure (errKind, errKindDescr, errKey, errByPos)
					forM_ errByPosByKind $
						mapM_ $ \(errKind, errKindDescr, errKey, errByPos) -> do
							H.li ! HA.class_ (attrify $ errorType errKind) $$ do
								H.span ! HA.class_ "error-message" $$ do
									H.span ! HA.class_ "error-kind" $$ do
										errKindDescr
										Plain.l10n_Colon l10n :: HTML5
									html5ify errKey
								H.ol ! HA.class_ "error-location" $$
									forM_ errByPos $ \(errPos, errId) ->
										H.li $$
											H.a ! HA.href (refIdent errId) $$
												html5ify errPos
		where
		errorType num = identify $ "error-type"<>show num<>"."
		-- | Nest error id= to enable showing/hidding errors using :target pseudo-class.
		filterIds [] h = h
		filterIds ((num, _description, errs):es) h =
			if null errs
			 then filterIds es h
			 else do
				H.div ! HA.class_ "error-filter"
				      ! HA.id (attrify $ errorType num) $$
					filterIds es h
		errorAt :: Ident -> HM.HashMap Ident (Seq (TCT.Location, XML.Pos)) -> [(Plain, [(TCT.Location,Ident)])]
		errorAt suffix errs =
			(<$> HM.toList errs) $ \(ref, errPositions) ->
				( pure $ tree0 $ PlainText $ unIdent ref
				, List.zipWith
				 (\num (locTCT, _posXML) -> (locTCT, identifyAt suffix ref (Just $ Nat1 num)))
				 [1::Int ..] (toList errPositions)
				)
		errorReference :: Ident -> HM.HashMap Ident (Seq (TCT.Location, XML.Pos)) -> [(Plain, [(TCT.Location,Ident)])]
		errorReference suffix errs =
			(<$> HM.toList errs) $ \(id, errPositions) ->
				( pure $ tree0 $ PlainText $ unIdent id
				, List.zipWith
				 (\num (locTCT, _posXML) -> (locTCT, identifyReference suffix id (Just $ Nat1 num)))
				 [1::Int ..] (toList errPositions)
				)
		errorIdent :: HM.HashMap Ident (Seq (TCT.Location, XML.Pos)) -> [(Plain, [(TCT.Location,Ident)])]
		errorIdent errs =
			(<$> HM.toList errs) $ \(id, errPositions) ->
				( pure $ tree0 $ PlainText $ unIdent id
				, (\(locTCT, posXML) ->
					(locTCT, identify $ XML.pos_ancestorsWithFigureNames posXML))
				 <$> toList errPositions
				)
		errorName :: HM.HashMap Name (Seq (TCT.Location, XML.Pos)) -> [(Plain, [(TCT.Location,Ident)])]
		errorName errs =
			(<$> HM.toList errs) $ \(name, errPositions) ->
				( pure $ tree0 $ PlainText $ unName name
				, (\(locTCT, posXML) ->
					(locTCT, identify $ XML.pos_ancestorsWithFigureNames posXML))
				 <$> toList errPositions
				)
		errorTitle :: HM.HashMap Title (Seq (TCT.Location, XML.Pos)) -> [(Plain, [(TCT.Location,Ident)])]
		errorTitle errs =
			(<$> HM.toList errs) $ \(title, errPositions) ->
				( unTitle title
				, (\(locTCT, posXML) ->
					(locTCT, identify $ XML.pos_ancestorsWithFigureNames posXML))
				 <$> toList errPositions
				)