{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Textphile.DTC.Write.HTML5.Base where

import Control.Monad (Monad(..))
import Data.Bool
import Data.Char (Char)
import Data.Default.Class (Default(..))
import Data.Either (Either(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), (.), id)
import Data.Functor ((<$>))
import Data.Functor.Compose (Compose(..))
import Data.Int (Int)
import Data.Locale hiding (Index)
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (Seq)
import Data.String (String, IsString(..))
import Data.Text (Text)
import Prelude (mod)
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.Text.Lazy as TL
import qualified Data.TreeMap.Strict as TM
import qualified Majority.Judgment as MJ
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Internal as H

import Control.Monad.Utils
import Textphile.Utils ()
import Textphile.DTC.Document as DTC
import Textphile.DTC.Write.XML ()
import qualified Textphile.DTC.Analyze.Check   as Analyze
import qualified Textphile.DTC.Analyze.Collect as Analyze
-- import qualified Textphile.DTC.Analyze.Index   as Analyze
import qualified Textphile.DTC.Write.Plain as Plain
import qualified Text.Blaze.Internal as B

-- * Type 'HTML5'
type HTML5 = ComposeRWS Reader Writer State B.MarkupM ()
instance IsString HTML5 where
	fromString = html5ify

-- ** Type 'Config'
data Config =
 forall locales.
 ( Locales   locales
 , Loqualize locales (L10n HTML5)
 , Loqualize locales (Plain.L10n Plain.Plain)
 ) =>
 Config
 { config_css       :: Either FilePath TL.Text
 , config_js        :: Either FilePath TL.Text
 , config_locale    :: LocaleIn locales
 , config_generator :: TL.Text
 }
instance Default Config where
	def = Config
	 { config_css       = Right "style/dtc-html5.css"
	 , config_js        = Right "" -- "style/dtc-html5.js"
	 , config_locale    = LocaleIn @'[EN] en_US
	 , config_generator = "https://hackage.haskell.org/package/textphile"
	 }

-- ** Type 'Reader'
data Reader = Reader
 { reader_l10n     :: Loqualization (L10n HTML5)
 , reader_plainify :: Plain.Reader
 , reader_italic   :: Bool
 , reader_all      :: Analyze.All
 , reader_body     :: Body
 , reader_section  :: [Section]
 }
instance Default Reader where
	def = Reader
	 { reader_l10n     = Loqualization EN_US
	 , reader_plainify = def
	 , reader_italic   = False
	 , reader_all      = def
	 , reader_body     = def
	 , reader_section  = def
	 }

-- ** Type 'Writer'
data Writer = Writer
 { writer_scripts :: HS.HashSet FilePath
 , writer_styles  :: HS.HashSet (Either FilePath TL.Text)
 }
instance Default Writer where
	def = Writer
	 { writer_scripts = def
	 , writer_styles  = def
	 }
instance Semigroup Writer where
	x <> y = Writer
	 { writer_scripts = HS.union (writer_scripts x) (writer_scripts y)
	 , writer_styles  = HS.union (writer_styles  x) (writer_styles  y)
	 }
instance Monoid Writer where
	mempty  = def
	mappend = (<>)

-- ** Type 'State'
data State = State
 { state_errors           :: !(Analyze.Errors Nat1)
 , state_ref              :: !(HM.HashMap Ident Nat1)
 , state_pageRef          :: !(HM.HashMap PathPage Nat1)
 , state_at               :: !(HM.HashMap Ident Nat1)
 , state_tag              :: !(HM.HashMap Ident Nat1)
 , state_irefs            :: !(TM.TreeMap Word Nat1)
 , state_indices          :: ![(Terms, Index)]
 , state_notes            :: ![Seq [Para]]
 , state_note_num_ref     :: !Nat1
 , state_note_num_content :: !Nat1
 , state_judgments        :: !(HM.HashMap JudgmentKey [MJ.OpinionsByChoice Choice Name (MJ.Ranked Grade)])
 } deriving (Show)
instance Default State where
	def = State
	 { state_errors           = def
	 , state_ref              = def
	 , state_pageRef          = def
	 , state_at               = def
	 , state_tag              = def
	 , state_irefs            = def
	 , state_indices          = def
	 , state_notes            = def
	 , state_note_num_ref     = def
	 , state_note_num_content = def
	 , state_judgments        = def
	 }

-- * Class 'Html5ify'
class Html5ify a where
	html5ify :: a -> HTML5
instance Html5ify H.Markup where
	html5ify = Compose . return
instance Html5ify Char where
	html5ify = html5ify . H.toMarkup
instance Html5ify Text where
	html5ify = html5ify . H.toMarkup
instance Html5ify TL.Text where
	html5ify = html5ify . H.toMarkup
instance Html5ify String where
	html5ify = html5ify . H.toMarkup
instance Html5ify Ident where
	html5ify (Ident i) = html5ify i
instance Html5ify Int where
	html5ify = html5ify . show
instance Html5ify Name where
	html5ify (Name i) = html5ify i
instance Html5ify Nat where
	html5ify (Nat n) = html5ify n
instance Html5ify Nat1 where
	html5ify (Nat1 n) = html5ify n
instance Html5ify a => Html5ify (Maybe a) where
	html5ify = foldMap html5ify

html5AttrClass :: [TL.Text] -> HTML5 -> HTML5
html5AttrClass = \case
 [] -> id
 cls  ->
	Compose .
	(H.AddCustomAttribute "class"
	 (H.String $ TL.unpack $ TL.unwords cls) <$>) .
	getCompose

html5AttrId :: Ident -> HTML5 -> HTML5
html5AttrId (Ident id_) =
	Compose .
	(H.AddCustomAttribute "id"
	 (H.String $ TL.unpack id_) <$>) .
	getCompose

html5CommonAttrs :: CommonAttrs -> HTML5 -> HTML5
html5CommonAttrs CommonAttrs{..} =
	html5AttrClass attrs_classes .
	maybe id html5AttrId attrs_id

-- * Class 'L10n'
class
 ( Plain.L10n msg lang
 , Plain.L10n TL.Text lang
 ) => L10n msg lang where
	l10n_Header_Address                   :: FullLocale lang -> msg
	l10n_Header_Date                      :: FullLocale lang -> msg
	l10n_Header_Version                   :: FullLocale lang -> msg
	l10n_Header_Origin                    :: FullLocale lang -> msg
	l10n_Header_Source                    :: FullLocale lang -> msg
	l10n_Errors_All                       :: FullLocale lang -> Nat -> msg
	l10n_Error_At_unknown                 :: FullLocale lang -> msg
	l10n_Error_At_ambiguous               :: FullLocale lang -> msg
	l10n_Error_Rref_unknown               :: FullLocale lang -> msg
	l10n_Error_Reference_ambiguous        :: FullLocale lang -> msg
	l10n_Error_Judgment_Judges_unknown    :: FullLocale lang -> msg
	l10n_Error_Judgment_Judge_unknown     :: FullLocale lang -> msg
	l10n_Error_Judgment_Judge_duplicated  :: FullLocale lang -> msg
	l10n_Error_Judgment_Grades_unknown    :: FullLocale lang -> msg
	l10n_Error_Judgment_Grades_duplicated :: FullLocale lang -> msg
	l10n_Error_Judgment_Grade_unknown     :: FullLocale lang -> msg
	l10n_Error_Judgment_Choice_duplicated :: FullLocale lang -> msg
instance L10n HTML5 EN where
	l10n_Header_Address _l10n = "Address"
	l10n_Header_Date    _l10n = "Date"
	l10n_Header_Origin  _l10n = "Origin"
	l10n_Header_Source  _l10n = "Source"
	l10n_Header_Version _l10n = "Version"
	l10n_Errors_All _l10n n = "All errors ("<>html5ify n<>")"
	l10n_Error_At_unknown   _l10n = "Unknown anchor"
	l10n_Error_At_ambiguous _l10n = "Ambiguous anchor"
	l10n_Error_Rref_unknown        _l10n = "Unknown reference"
	l10n_Error_Reference_ambiguous _l10n = "Ambiguous reference"
	l10n_Error_Judgment_Judges_unknown    _l10n = "Unknown judges"
	l10n_Error_Judgment_Judge_unknown     _l10n = "Unknown judge"
	l10n_Error_Judgment_Judge_duplicated  _l10n = "Duplicated judge"
	l10n_Error_Judgment_Grades_unknown    _l10n = "Unknown grades"
	l10n_Error_Judgment_Grades_duplicated _l10n = "Duplicated grades"
	l10n_Error_Judgment_Grade_unknown     _l10n = "Unknown grade"
	l10n_Error_Judgment_Choice_duplicated _l10n = "Duplicated choice"
instance L10n HTML5 FR where
	l10n_Header_Address _l10n = "Adresse"
	l10n_Header_Date    _l10n = "Date"
	l10n_Header_Origin  _l10n = "Origine"
	l10n_Header_Source  _l10n = "Source"
	l10n_Header_Version _l10n = "Version"
	l10n_Errors_All _l10n n = "Toutes les erreurs ("<>html5ify n<>")"
	l10n_Error_At_unknown   _l10n = "Ancre inconnue"
	l10n_Error_At_ambiguous _l10n = "Ancre ambiguë"
	l10n_Error_Rref_unknown        _l10n = "Référence inconnue"
	l10n_Error_Reference_ambiguous _l10n = "Référence ambiguë"
	l10n_Error_Judgment_Judges_unknown    _l10n = "Juges inconnu·es"
	l10n_Error_Judgment_Judge_unknown     _l10n = "Juge unconnu·e"
	l10n_Error_Judgment_Judge_duplicated  _l10n = "Juge en double"
	l10n_Error_Judgment_Grades_unknown    _l10n = "Mentions inconnues"
	l10n_Error_Judgment_Grades_duplicated _l10n = "Mentions en double"
	l10n_Error_Judgment_Grade_unknown     _l10n = "Mention inconnue"
	l10n_Error_Judgment_Choice_duplicated _l10n = "Choix en double"

instance Plain.L10n HTML5 EN where
	l10n_Colon             l10n = html5ify (Plain.l10n_Colon l10n :: TL.Text)
	l10n_Table_of_Contents l10n = html5ify (Plain.l10n_Table_of_Contents l10n :: TL.Text)
	l10n_Date date         l10n = html5ify (Plain.l10n_Date date l10n :: TL.Text)
	l10n_Quote msg _l10n = do
		depth <- composeLift $ RWS.asks $ Plain.reader_quote . reader_plainify
		let (o,c) :: (HTML5, HTML5) =
			case unNat depth `mod` 3 of
			 0 -> ("“","”")
			 1 -> ("« "," »")
			 _ -> ("‟","„")
		o
		localComposeRWS (\ro -> ro
		 {reader_plainify = (reader_plainify ro)
			 {Plain.reader_quote = succNat depth}}) $
			msg
		c
instance Plain.L10n HTML5 FR where
	l10n_Colon             l10n = html5ify (Plain.l10n_Colon l10n :: TL.Text)
	l10n_Table_of_Contents l10n = html5ify (Plain.l10n_Table_of_Contents l10n :: TL.Text)
	l10n_Date date         l10n = html5ify (Plain.l10n_Date date l10n :: TL.Text)
	l10n_Quote msg _l10n = do
		depth <- composeLift $ RWS.asks $ Plain.reader_quote . reader_plainify
		let (o,c) :: (HTML5, HTML5) =
			case unNat depth `mod` 3 of
			 0 -> ("« "," »")
			 1 -> ("“","”")
			 _ -> ("‟","„")
		o
		localComposeRWS (\ro -> ro
		 {reader_plainify = (reader_plainify ro)
			 {Plain.reader_quote = succNat depth}}) $
			msg
		c