{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
module Hdoc.DTC.Write.HTML5.Ident where

import Control.Category as Cat
import Control.Monad (Monad(..))
import Data.Bool
import Data.Char (Char)
import Data.Default.Class (Default(..))
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Function (($))
import Data.Int (Int)
import Data.Locale (Loqualization)
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString(..))
import Data.TreeSeq.Strict (Tree(..))
import Data.Tuple (snd)
import Text.Show (Show(..))
import qualified Data.ByteString.Lazy as BS
import qualified Data.Char as Char
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TL.Builder
import qualified Data.Text.Lazy.Builder.Int as TL.Builder
import qualified Data.Text.Lazy.Encoding as TL
import qualified Text.Blaze.Html5 as H

import Text.Blaze.Utils

import Hdoc.Utils ()
import Hdoc.DTC.Document as DTC
import qualified Hdoc.DTC.Index as Index
import qualified Hdoc.DTC.Write.Plain as Plain

-- * Class 'Identify'
class Identify a where
	identify :: a -> Ident
instance Identify Char where
	identify = Ident . TL.singleton
instance Identify String where
	identify = Ident . TL.pack
instance Identify TL.Text where
	identify = Ident
instance Identify Ident where
	identify (Ident p) = identify p
instance Identify XmlPosPath where
	identify =
		Ident .
		escapeIdentHead .
		snd . foldl' (\(nameParent,acc) (name,rank) ->
			(name,
				(if TL.null acc then acc else acc <> ".") <>
				(if name == nameParent
					then unIdent $ identify $ show rank
					else identifyString (show name)<>"."<>identifyString (show rank))
			)
		 )
		 ("",mempty)
		where identifyString = escapeIdentTail . TL.pack
instance Identify XmlPos where
	identify = identify . xmlPos_Ancestors
instance Identify Path where
	identify (Path a) = identify a
instance Identify Int where
	identify = fromString . show
instance Identify Nat where
	identify (Nat a) = identify a
instance Identify Nat1 where
	identify (Nat1 a) = identify a
instance Identify Anchor where
	identify Anchor{..} = identify section <> "." <> identify count

refIdent :: Ident -> H.AttributeValue
refIdent i = "#"<>attrify i

escapeIdent :: TL.Text -> Ident
escapeIdent = Ident . escapeIdentHead . escapeIdentTail
escapeIdentHead :: TL.Text -> TL.Text
escapeIdentHead = Cat.id
escapeIdentTail :: TL.Text -> TL.Text
escapeIdentTail =
	TL.foldr
	 (\c accum -> (<> accum) $ case c of
		 ' ' -> "+"
		 _ | Char.isAlphaNum c
		   || c == '-'
		   -> TL.singleton c
		 _ -> "_"<>bytes
			where
			enc    = TL.encodeUtf8 $ TL.singleton c
			bytes  = BS.foldr (\b acc -> escape b<>acc) "" enc
			escape = TL.Builder.toLazyText . TL.Builder.hexadecimal
	 ) ""

identifyIref :: Words -> Ident
identifyIref term =
	"iref"
	 <> "." <> identify (Index.plainifyWords term)
identifyIrefCount :: Words -> Nat1 -> Ident
identifyIrefCount term count =
	"iref"
	 <> "." <> identify (Index.plainifyWords term)
	 <> "." <> identify count

identifyTag :: Ident -> Loqualization (Plain.L10n Plain.Plain) -> Plain -> Maybe Nat1 -> Ident
identifyTag suffix state_l10n to count =
	"tag" <> suffix
	 <> "." <> identifyPlain state_l10n to
	 <> maybe "" (("."<>) . identify) count

identifyReference :: Ident -> Ident -> Maybe Nat1 -> Ident
identifyReference suffix to count =
	"reference" <> suffix
	 <> "." <> to
	 <> maybe "" (("."<>) . identify) count

cleanPlain :: Plain -> Plain
cleanPlain ps =
	ps >>= \case
	 Tree PlainIref{} ls -> cleanPlain ls
	 Tree PlainNote{} _  -> mempty
	 Tree n ts -> return $ Tree n $ cleanPlain ts

identifyPlain :: Loqualization (Plain.L10n Plain.Plain) -> Plain -> Ident
identifyPlain state_l10n =
	escapeIdent .
	Plain.text def{Plain.state_l10n}

identifyTitle :: Loqualization (Plain.L10n Plain.Plain) -> Title -> Ident
identifyTitle state_l10n = identifyPlain state_l10n . unTitle