{-# 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.TreeMap.Strict as TM
import qualified Data.TreeSeq.Strict as TS
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
 { document_head :: !(Maybe Head)
 , document_body :: !Body
 } deriving (Eq,Show)

-- * Type 'Head'
data Head = Head
 { head_section :: !Section
 , head_body    :: !Body
 } deriving (Eq,Show)
instance Default Head where
	def = Head
	 { head_section = def
	 , head_body    = def
	 }
instance Ord Head where
	compare = compare `on` head_section

{-
-- * 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_locTCT :: !TCT.Location
 , section_attrs  :: !CommonAttrs
 , section_about  :: !About
 } deriving (Eq,Show)
instance Ord Section where
	compare = compare `on` section_posXML
instance Default Section where
	def = Section
	 { section_posXML = def
	 , section_locTCT = def
	 , section_attrs  = def
	 , section_about  = def
	 }

-- * Type 'About'
data About = About
 { about_titles      :: ![Title]
 , about_aliases     :: ![Alias]
 , about_authors     :: ![Entity]
 , about_dates       :: ![Date]
 , about_tags        :: ![TL.Text]
 , about_links       :: ![Link]
 , about_series      :: ![Serie]
 , about_description :: ![Para]
 , about_judgments   :: ![Judgment]
 } deriving (Eq,Show)
instance Default About where
	def = About
	 { about_titles      = def
	 , about_aliases     = def
	 , about_dates       = def
	 , about_authors     = def
	 , about_tags        = def
	 , about_links       = def
	 , about_series      = def
	 , about_description = def
	 , about_judgments   = def
	 }
instance Semigroup About where
	x <> y = About
	 { about_titles      = about_titles      x <> about_titles      y
	 , about_aliases     = about_aliases     x <> about_aliases     y
	 , about_dates       = about_dates       x <> about_dates       y
	 , about_authors     = about_authors     x <> about_authors     y
	 , about_tags        = about_tags        x <> about_tags        y
	 , about_links       = about_links       x <> about_links       y
	 , about_series      = about_series      x <> about_series      y
	 , about_description = about_description x <> about_description y
	 , about_judgments   = about_judgments   x <> about_judgments   y
	 }
instance Monoid About where
	mempty  = def
	mappend = (<>)

-- * 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
                   , index    :: !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 'Index'
type Index = TM.TreeMap Word Pos

-- * 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_hide             :: !(Maybe Bool)
 , judgment_question         :: !(Maybe Title)
 , judgment_choices          :: ![Choice]
 } deriving (Eq,Show)
instance Default Judgment where
	def = Judgment
	 { judgment_opinionsByChoice = def
	 -- , judgment_judges           = def
	 -- , judgment_grades           = def
	 , judgment_posXML           = def
	 , judgment_locTCT           = def
	 , judgment_judgesId         = def
	 , judgment_gradesId         = def
	 , judgment_importance       = def
	 , judgment_hide             = def
	 , judgment_question         = def
	 , judgment_choices          = def
	 }

-- ** Type 'JudgmentKey'
data JudgmentKey = JudgmentKey
 { judgmentKey_judgesId :: !Ident
 , judgmentKey_gradesId :: !Ident
 , judgmentKey_question :: !(Maybe Title)
 } deriving (Eq,Show,Generic)
instance Hashable JudgmentKey

-- ** 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_default    :: !(Maybe 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
 | PlainRef  { ref_locTCT :: !TCT.Location
             , ref_posXML :: !XML.Pos
             , ref_ident  :: !Ident
             } -- ^ Reference reference
 | PlainPageRef  { pageRef_locTCT :: !TCT.Location
                 , pageRef_posXML :: !XML.Pos
                 , pageRef_path   :: !PathPage
                 , pageRef_at     :: !(Maybe Ident)
                 } -- ^ Page reference
 | PlainSpan { attrs :: !CommonAttrs } -- ^ Neutral node
 -- Leafs
 | PlainBreak -- ^ Line break (\n)
 | PlainText TL.Text
 | PlainNote { note_paras :: ![Para]
             } -- ^ Footnote
 | PlainTag  { tag_locTCT :: !TCT.Location
             , tag_posXML :: !XML.Pos
             , tag_ident  :: !Ident
             , tag_back   :: !Bool
             }
 | PlainAt   { at_locTCT :: !TCT.Location
             , at_posXML :: !XML.Pos
             , at_ident  :: !Ident
             , at_back   :: !Bool
             }
 deriving (Eq,Show)

{-
-- * Type 'To'
data To
 = To_At !Ident
 | To_Tag  !Ident
 deriving (Eq,Show)

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

{-
-- * 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
 { attrs_id      :: !(Maybe Ident)
 , attrs_classes :: ![TL.Text]
 } deriving (Eq,Ord,Show)
instance Default CommonAttrs where
	def = CommonAttrs
	 { attrs_id      = def
	 , attrs_classes = def
	 }

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

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

-- * 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
	 PlainRef{..}     -> pure $ TS.Tree PlainRef{ ref_locTCT = def
	                                            , ref_posXML = def
	                                            , .. } skip
	 PlainPageRef{..} -> pure $ TS.Tree PlainPageRef{ pageRef_locTCT = def
	                                                , pageRef_posXML = def
	                                                , .. } skip
	 PlainSpan attrs  -> pure $ TS.Tree n' skip
	                     where n' = PlainSpan{attrs = CommonAttrs{ attrs_id      = Nothing
	                                                             , attrs_classes = List.sort $ attrs_classes attrs }}
	 PlainB           -> keep
	 PlainCode        -> keep
	 PlainDel         -> keep
	 PlainI           -> keep
	 PlainQ           -> keep
	 PlainSC          -> keep
	 PlainSub         -> keep
	 PlainSup         -> keep
	 PlainU           -> keep
	 PlainEref{..}    -> keep
	 PlainAt{..}      -> pure $ TS.Tree PlainAt{at_locTCT=def, at_posXML=def, ..} skip
	 PlainTag{..}     -> pure $ TS.Tree PlainTag{tag_locTCT=def, tag_posXML=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)`hashWithSalt`tag_ident`hashWithSalt`tag_back
			 PlainAt{..}       -> s`hashWithSalt`(2::Int)`hashWithSalt`at_ident`hashWithSalt`at_back
			 PlainSpan{..}     -> s`hashWithSalt`(3::Int)`hashWithSalt`List.sort (attrs_classes attrs)
			 PlainB            -> s`hashWithSalt`(4::Int)
			 PlainCode         -> s`hashWithSalt`(5::Int)
			 PlainDel          -> s`hashWithSalt`(6::Int)
			 PlainI            -> s`hashWithSalt`(7::Int)
			 PlainQ            -> s`hashWithSalt`(8::Int)
			 PlainSC           -> s`hashWithSalt`(9::Int)
			 PlainSub          -> s`hashWithSalt`(10::Int)
			 PlainSup          -> s`hashWithSalt`(11::Int)
			 PlainU            -> s`hashWithSalt`(12::Int)
			 PlainEref{..}     -> s`hashWithSalt`(13::Int)`hashWithSalt`eref_href
			 PlainRef{..}      -> s`hashWithSalt`(14::Int)`hashWithSalt`ref_ident
			 PlainPageRef{..}  -> s`hashWithSalt`(15::Int)`hashWithSalt`pageRef_at`hashWithSalt`pageRef_path
			 PlainBreak        -> s`hashWithSalt`(16::Int)
			 PlainText t       -> s`hashWithSalt`(17::Int)`hashWithSalt`t

-- * Type 'Entity'
data Entity = Entity
 { entity_rel     :: !Name
 , entity_role    :: !Name
 , 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     :: ![Entity]
 } deriving (Eq,Show)
instance Default Entity where
	def = Entity
	 { entity_rel     = def
	 , entity_role    = def
	 , 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
 { include_href :: FilePath
 } deriving (Eq,Show)
instance Default Include where
	def = Include
	 { include_href = def
	 }

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

-- * Type 'Date'
data Date = Date
 { date_rel   :: !Name
 , date_role  :: !Name
 , date_year  :: !Int
 , date_month :: !(Maybe Nat1)
 , date_day   :: !(Maybe Nat1)
 } deriving (Eq,Show)
instance Default Date where
	def = Date
	 { date_rel   = def
	 , date_role  = def
	 , date_year  = 1970
	 , date_month = Just (Nat1 01)
	 , date_day   = Just (Nat1 01)
	 }
instance Semigroup Date where
	_x <> y = y

-- * Type 'Link'
data Link = Link
 { link_rel   :: !Name
 , link_role  :: !Name
 , link_url   :: !URL
 , link_plain :: !Plain
 -- , link_type  :: !(Maybe TL.Text)
 } deriving (Eq,Show)
instance Default Link where
	def = Link
	 { link_rel   = def
	 , link_role  = def
	 , link_url   = def
	 , link_plain = def
	 -- , link_type  = def
	 }

-- * Type 'Alias'
data Alias = Alias
 { alias_attrs :: !CommonAttrs
 , alias_title :: !Title
 } deriving (Eq,Show)

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

-- | Builtins 'URL' recognized from |Serie|'s 'name'.
urlSerie :: Serie -> Maybe URL
urlSerie Serie{..} =
	case serie_name of
	 "RFC" | TL.all Char.isDigit serie_id ->
		Just $ URL $ "https://tools.ietf.org/html/rfc"<>serie_id
	 "DOI" -> Just $ URL $ "https://dx.doi.org/"<>serie_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)

-- * Type 'Pos'
type Pos = Seq Section