{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
module Hdoc.DTC.Document
 ( module Hdoc.DTC.Document
 , Ident(..), URL(..), Nat(..), Nat1(..)
 , succNat, succNat1
 , FilePath
 ) where

import Control.Applicative (Applicative(..))
import Data.Bool
import Data.Default.Class (Default(..))
import Data.Default.Instances.Containers ()
import Data.Eq (Eq(..))
import Control.Monad (Monad(..))
import Data.Foldable (Foldable(..))
import Data.Function (on, ($), (.))
import Data.Hashable (Hashable(..))
import Data.Int (Int)
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
-- import Data.Sequence (Seq(..))
import Data.String (IsString)
import GHC.Generics (Generic)
import System.FilePath (FilePath)
import Text.Show (Show)
import qualified Data.Char as Char
import qualified Data.HashMap.Strict as HM
import qualified Data.List as List
import qualified Data.Text.Lazy as TL
import qualified Data.TreeSeq.Strict as TS
import qualified Data.TreeMap.Strict as TM
import qualified Majority.Judgment as MJ

import Hdoc.Utils (Nat(..), Nat1(..), succNat, succNat1)
import Hdoc.XML (Ident(..), URL(..))
import qualified Hdoc.XML as XML
import qualified Hdoc.TCT.Cell as TCT

-- * Type 'Document'
data Document = Document
 { head :: !Head
 , body :: !Body
 } deriving (Eq,Show)
instance Default Document where
	def = Document
	 { head = def
	 , body = def
	 }

-- * Type 'Head'
data Head = Head
 { head_about     :: !About
 , head_judgments :: ![Judgment]
   -- [(Judgment, [Tree.Tree (Maybe MJ.Share, [Choice])])]
 } deriving (Eq,Show)
instance Default Head where
	def = Head
	 { head_about     = def
	 , head_judgments = def
	 }

-- ** Type 'About'
data About = About
 { about_titles      :: ![Title]
 , about_url         :: !(Maybe URL)
 , about_authors     :: ![Entity]
 , about_editor      :: !(Maybe Entity)
 , about_date        :: !(Maybe Date)
 , about_tags        :: ![TL.Text]
 , about_links       :: ![Link]
 , about_series      :: ![Serie]
 , about_description :: !(Maybe Para)
 , about_headers     :: ![Header]
 } deriving (Eq,Show)
instance Default About where
	def = About
	 { about_titles      = def
	 , about_url         = def
	 , about_date        = def
	 , about_editor      = def
	 , about_authors     = def
	 , about_tags        = def
	 , about_links       = def
	 , about_series      = def
	 , about_description = def
	 , about_headers     = def
	 }

-- * Type 'Header'
data Header = Header
 { header_name  :: !TL.Text
 , header_value :: !Plain
 } deriving (Eq,Show)

-- * Type 'Body'
type Body = TS.Trees BodyNode

-- ** Type 'BodyNode'
data BodyNode
 = BodySection !Section -- ^ node
 | BodyBlock   !Block   -- ^ leaf
 deriving (Eq,Show)

-- Type 'Section'
data Section = Section
 { section_posXML    :: !XML.Pos
 , section_attrs     :: !CommonAttrs
 , section_title     :: !Title
 , section_aliases   :: ![Alias]
 , section_judgments :: ![Judgment]
 } deriving (Eq,Show)

-- * Type 'Block'
data Block
 = BlockPara       Para
 | BlockBreak      { attrs    :: !CommonAttrs }
 | BlockToC        { posXML   :: !XML.Pos
                   , attrs    :: !CommonAttrs
                   , depth    :: !(Maybe Nat)
                   }
 | BlockToF        { posXML   :: !XML.Pos
                   , attrs    :: !CommonAttrs
                   , types    :: ![TL.Text]
                   }
 | BlockAside      { posXML   :: !XML.Pos
                   , attrs    :: !CommonAttrs
                   , blocks   :: ![Block]
                   }
 | BlockFigure     { posXML   :: !XML.Pos
                   , type_    :: !TL.Text
                   , attrs    :: !CommonAttrs
                   , mayTitle :: !(Maybe Title)
                   , paras    :: ![Para]
                   }
 | BlockIndex      { posXML   :: !XML.Pos
                   , attrs    :: !CommonAttrs
                   , terms    :: !Terms
                   }
 | BlockReferences { posXML   :: !XML.Pos
                   , attrs    :: !CommonAttrs
                   , refs     :: ![Reference]
                   } -- FIXME: move to ParaReferences?
 | BlockJudges     !Judges
 | BlockGrades     { posXML   :: !XML.Pos
                   , attrs    :: !CommonAttrs
                   , scale    :: ![Grade]
                   }
 deriving (Eq,Show)

-- * Type 'Judgment'
data Judgment = Judgment
 { judgment_opinionsByChoice :: !(Maybe (MJ.OpinionsByChoice Choice Name (MJ.Ranked Grade)))
 , judgment_judges           :: !(Maybe Judges)
 , judgment_grades           :: !(Maybe (MJ.Grades (MJ.Ranked Grade)))
 , judgment_posXML           :: !XML.Pos
 , judgment_locTCT           :: !TCT.Location
 , judgment_judgesId         :: !Ident
 , judgment_gradesId         :: !Ident
 , judgment_importance       :: !(Maybe MJ.Share)
 , judgment_question         :: !(Maybe Title)
 , judgment_choices          :: ![Choice]
 } deriving (Show)
instance Eq Judgment where
	x==y =
		judgment_judgesId x == judgment_judgesId y &&
		judgment_gradesId x == judgment_gradesId y &&
		judgment_question x == judgment_question y
instance Hashable Judgment where
	hashWithSalt s Judgment{..} =
		s`hashWithSalt`judgment_judgesId
		 `hashWithSalt`judgment_gradesId
		 `hashWithSalt`judgment_question

-- ** Type 'ErrorJudgment'
data ErrorJudgment
 =   ErrorJudgment_Judges
 |   ErrorJudgment_Grades
 deriving (Eq,Show)

-- ** Type 'Judges'
data Judges = Judges
 { judges_locTCT :: !TCT.Location
 , judges_posXML :: !XML.Pos
 , judges_attrs  :: !CommonAttrs
 , judges_byName :: !(HM.HashMap Name [Judge])
 } deriving (Eq,Show)

-- ** Type 'Judge'
data Judge = Judge
 { judge_locTCT        :: !TCT.Location
 , judge_posXML        :: !XML.Pos
 , judge_name          :: !Name
 , judge_title         :: !(Maybe Title)
 , judge_defaultGrades :: !(HM.HashMap Ident [Name])
 } deriving (Eq,Show)

-- ** Type 'Grade'
data Grade = Grade
 { grade_posXML    :: !XML.Pos
 , grade_name      :: !Name
 , grade_color     :: !TL.Text
 , grade_isDefault :: !Bool
 , grade_title     :: !(Maybe Title)
 } deriving (Eq,Show)

-- ** Type 'Choice'
data Choice = Choice
 { choice_locTCT   :: TCT.Location
 , choice_posXML   :: XML.Pos
 , choice_title    :: !(Maybe Title)
 , choice_opinions :: ![Opinion]
 } deriving (Show)
instance Eq Choice where
	(==) = (==)`on`choice_title
instance Hashable Choice where
	hashWithSalt s Choice{..} =
		hashWithSalt s choice_title

-- ** Type 'Opinion'
data Opinion = Opinion
 { opinion_locTCT     :: !TCT.Location
 , opinion_posXML     :: !XML.Pos
 , opinion_judge      :: !Name
 , opinion_grade      :: !Name
 , opinion_importance :: !(Maybe MJ.Share)
 , opinion_comment    :: !(Maybe Title)
 } deriving (Eq,Show)

-- * Type 'Para'
data Para
 = ParaItem  { item   :: !ParaItem }
 | ParaItems { posXML :: !XML.Pos
             , attrs  :: !CommonAttrs
             , items  :: ![ParaItem]
             }
 deriving (Eq,Show)

-- ** Type 'ParaItem'
data ParaItem
 = ParaPlain    !Plain
 | ParaComment  !TL.Text
 | ParaOL       ![ListItem]
 | ParaUL       ![[Para]]
 | ParaQuote    { type_  :: !TL.Text
                , paras  :: ![Para]
                }
 | ParaArtwork  { type_  :: !TL.Text
                , text   :: !TL.Text
                }
 | ParaJudgment !Judgment
 deriving (Eq,Show)

-- *** Type 'ListItem'
data ListItem = ListItem
 { name  :: !Name
 , paras :: ![Para]
 } deriving (Eq,Show)

-- * Type 'Plain'
type Plain = TS.Trees PlainNode

-- ** Type 'PlainNode'
data PlainNode
 -- Nodes
 = PlainB     -- ^ Bold
 | PlainCode  -- ^ Code (monospaced)
 | PlainDel   -- ^ Deleted (crossed-over)
 | PlainI     -- ^ Italic
 | PlainGroup -- ^ Group subTrees (neutral)
 | PlainQ     -- ^ Quoted
 | PlainSC    -- ^ Small Caps
 | PlainSub   -- ^ Subscript
 | PlainSup   -- ^ Superscript
 | PlainU     -- ^ Underlined
 | PlainEref { eref_href :: !URL } -- ^ External reference
 | PlainIref { iref_term :: !Words
             } -- ^ Index reference
 | PlainTag  { tag_locTCT :: !TCT.Location
             , tag_posXML :: !XML.Pos
             } -- ^ Reference
 | PlainRref { rref_locTCT :: !TCT.Location
             , rref_posXML :: !XML.Pos
             , rref_to     :: !Ident
             } -- ^ Reference reference
 | PlainSpan { attrs :: !CommonAttrs } -- ^ Neutral node
 -- Leafs
 | PlainBreak -- ^ Line break (\n)
 | PlainText TL.Text
 | PlainNote { note_paras :: ![Para]
             } -- ^ Footnote
 deriving (Eq,Show)

{-
-- * Type 'ErrorTarget'
data ErrorTarget
 =   ErrorTarget_Unknown !Nat1
 |   ErrorTarget_Ambiguous !(Maybe Nat1)
 deriving (Eq,Show)

-- * Type 'ErrorAnchor'
data ErrorAnchor
 =   ErrorAnchor_Ambiguous !Nat1
 deriving (Eq,Show)
-}

-- * Type 'CommonAttrs'
data CommonAttrs = CommonAttrs
 { id      :: !(Maybe Ident)
 , classes :: ![TL.Text]
 } deriving (Eq,Ord,Show)
instance Default CommonAttrs where
	def = CommonAttrs
	 { id      = def
	 , classes = def
	 }

-- ** Type 'Anchor'
data Anchor = Anchor
 { anchor_section :: !XML.Pos
 , anchor_count   :: !Nat1
 } deriving (Eq,Ord,Show)

-- * Type 'Name'
newtype Name = Name { unName :: TL.Text }
 deriving (Eq,Ord,Show,Semigroup,Monoid,Default,IsString,Hashable)

-- * Type 'Title'
newtype Title = Title { unTitle :: Plain }
 deriving (Show,Semigroup,Monoid,Default)
instance Eq Title where
	(==) = (==) `on` similarPlain . unTitle
-- | Return a similar version of a 'Plain' by removing:
--
-- * parsing residues ('PlainGroup'),
-- * notes ('PlainNote'),
-- * and position specific annotations ('Ident' and 'Anchor').
similarPlain :: Plain -> Plain
similarPlain = foldMap $ \(TS.Tree n ts) ->
	let skip = similarPlain ts in
	let keep = pure $ TS.Tree n $ skip in
	case n of
	 PlainGroup       -> skip
	 PlainNote{}      -> skip
	 PlainIref{..}    -> keep
	 PlainRref{..}    -> pure $ TS.Tree PlainRref{ rref_locTCT = def
	                                             , .. } skip
	 PlainSpan attrs  -> pure $ TS.Tree n' skip
	                     where n' = PlainSpan{attrs = CommonAttrs{ id      = Nothing
	                                                             , classes = List.sort $ classes attrs }}
	 PlainB           -> keep
	 PlainCode        -> keep
	 PlainDel         -> keep
	 PlainI           -> keep
	 PlainQ           -> keep
	 PlainSC          -> keep
	 PlainSub         -> keep
	 PlainSup         -> keep
	 PlainU           -> keep
	 PlainEref{..}    -> keep
	 PlainTag{..}     -> pure $ TS.Tree PlainTag{tag_locTCT=def, ..} skip
	 PlainBreak       -> keep
	 PlainText{}      -> keep
-- | Return the same hash if 'similarPlain' is applied on the 'Title' before hashing.
--
-- Warning: when using the key of HashMap or HashSet,
-- only the data taken into account by this 'Hashable' instance is reliable.
instance Hashable Title where
	hashWithSalt salt (Title ps) = hs salt ps
		where
		hs = foldr h
		h (TS.Tree n ts) s =
			(`hs` ts) $
			case n of
			 PlainGroup    -> s
			 PlainNote{}   -> s
			 PlainIref{..} -> s`hashWithSalt`(0::Int)`hashWithSalt`iref_term
			 PlainTag{..}  -> s`hashWithSalt`(1::Int)
			 PlainSpan{..} -> s`hashWithSalt`(2::Int)`hashWithSalt`List.sort (classes attrs)
			 PlainB        -> s`hashWithSalt`(3::Int)
			 PlainCode     -> s`hashWithSalt`(4::Int)
			 PlainDel      -> s`hashWithSalt`(5::Int)
			 PlainI        -> s`hashWithSalt`(6::Int)
			 PlainQ        -> s`hashWithSalt`(7::Int)
			 PlainSC       -> s`hashWithSalt`(8::Int)
			 PlainSub      -> s`hashWithSalt`(9::Int)
			 PlainSup      -> s`hashWithSalt`(10::Int)
			 PlainU        -> s`hashWithSalt`(11::Int)
			 PlainEref{..} -> s`hashWithSalt`(12::Int)`hashWithSalt`eref_href
			 PlainRref{..} -> s`hashWithSalt`(13::Int)`hashWithSalt`rref_to
			 PlainBreak    -> s`hashWithSalt`(14::Int)
			 PlainText t   -> s`hashWithSalt`(15::Int)`hashWithSalt`t

-- ** Type 'Entity'
data Entity = Entity
 { entity_name    :: !TL.Text
 , entity_street  :: !TL.Text
 , entity_zipcode :: !TL.Text
 , entity_city    :: !TL.Text
 , entity_region  :: !TL.Text
 , entity_country :: !TL.Text
 , entity_email   :: !TL.Text
 , entity_tel     :: !TL.Text
 , entity_fax     :: !TL.Text
 , entity_url     :: !(Maybe URL)
 , entity_org     :: !(Maybe Entity)
 } deriving (Eq,Show)
instance Default Entity where
	def = Entity
	 { entity_name    = def
	 , entity_street  = def
	 , entity_zipcode = def
	 , entity_city    = def
	 , entity_region  = def
	 , entity_country = def
	 , entity_email   = def
	 , entity_tel     = def
	 , entity_fax     = def
	 , entity_url     = def
	 , entity_org     = def
	 }

-- * Type 'Include'
newtype Include = Include
 { href :: FilePath
 } deriving (Eq,Show)
instance Default Include where
	def = Include
	 { href = def
	 }

-- * Type 'Reference'
data Reference = Reference
 { {-reference_error  :: !(Maybe ErrorAnchor)
 ,-} reference_posXML :: !XML.Pos
 , reference_locTCT :: !TCT.Location
 , reference_id     :: !Ident
 , reference_about  :: !About
 } deriving (Eq,Show)

-- * Type 'Date'
data Date = Date
 { year  :: !Int
 , month :: !(Maybe Nat1)
 , day   :: !(Maybe Nat1)
 } deriving (Eq,Show)
instance Default Date where
	def = Date
	 { year  = 1970
	 , month = Just (Nat1 01)
	 , day   = Just (Nat1 01)
	 }
instance Semigroup Date where
	_x <> y = y

-- * Type 'Link'
data Link = Link
 { name  :: !Name
 , href  :: !URL
 , rel   :: !TL.Text
 , type_ :: !(Maybe TL.Text)
 , plain :: !Plain
 } deriving (Eq,Show)
instance Default Link where
	def = Link
	 { name  = def
	 , href  = def
	 , rel   = def
	 , type_ = def
	 , plain = def
	 }

-- * Type 'Alias'
newtype Alias = Alias
 { title :: Title
 } deriving (Eq,Show)

-- * Type 'Serie'
data Serie = Serie
 { name :: !Name
 , id   :: !TL.Text
 } deriving (Eq,Show)
instance Default Serie where
	def = Serie
	 { name = def
	 , id   = def
	 }

-- | Builtins 'URL' recognized from |Serie|'s 'name'.
urlSerie :: Serie -> Maybe URL
urlSerie Serie{id=id_, name} =
	case name of
	 "RFC" | TL.all Char.isDigit id_ ->
		Just $ URL $ "https://tools.ietf.org/html/rfc"<>id_
	 "DOI" -> Just $ URL $ "https://dx.doi.org/"<>id_
	 _ -> Nothing

-- * Type 'Word'
type Word = TL.Text

-- ** Type 'Words'
type Words = [WordOrSpace]

-- *** Type 'WordOrSpace'
data WordOrSpace
 = Word !Word
 | Space
 deriving (Eq,Ord,Show,Generic)
instance Hashable WordOrSpace

-- ** Type 'Terms'
type Terms = [Aliases]

-- *** Type 'Aliases'
type Aliases = [Words]

-- ** Type 'PathWord'
type PathWord = TM.Path Word

pathFromWords :: Words -> Maybe PathWord
pathFromWords ws =
	case ws >>= unSpace of
	 p:ps | not (TL.null p) -> Just (TM.path p ps)
	 _ -> Nothing
	where
	unSpace = \case
	 Space  -> []
	 Word w -> [w]

-- * Type 'Location'
type Location = (TCT.Location, XML.Pos)