{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
module Hdoc.DTC.Document
 ( module Hdoc.DTC.Document
 , module Hdoc.XML
 ) where

import Control.Applicative (Applicative(..))
import Data.Bool
import Data.Default.Class (Default(..))
import Data.Default.Instances.Containers ()
import Data.Eq (Eq(..))
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.String (IsString)
import GHC.Generics (Generic)
import Text.Show (Show)
import qualified Data.Char as Char
-- import qualified Data.HashMap.Strict as HM
-- import qualified Data.HashSet as HS
import qualified Data.List as List
import qualified Data.Text.Lazy as TL
-- import qualified Data.Tree as Tree
import qualified Data.TreeSeq.Strict as TS
import qualified Hjugement as MJ

import Hdoc.Utils ()
import Hdoc.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
 { about     :: !About
 , judgments :: ![Judgment]
   -- [(Judgment, [Tree.Tree (Maybe MJ.Share, [Choice])])]
 } deriving (Eq,Show)
instance Default Head where
	def = Head
	 { about     = def
	 , judgments = def
	 }

-- ** Type 'About'
data About = About
 { headers  :: ![Header]
 , titles   :: ![Title]
 , url      :: !(Maybe URL)
 , authors  :: ![Entity]
 , editor   :: !(Maybe Entity)
 , date     :: !(Maybe Date)
 , tags     :: ![TL.Text]
 , links    :: ![Link]
 , series   :: ![Serie]
 , includes :: ![Include] -- FIXME: remove?
 } deriving (Eq,Show)
instance Default About where
	def = About
	 { headers  = def
	 , includes = def
	 , titles   = def
	 , url      = def
	 , date     = def
	 , editor   = def
	 , authors  = def
	 , tags     = def
	 , links    = def
	 , series   = def
	 }
instance Semigroup About where
	x <> y = About
	 { headers  = headers  x <> headers  y
	 , titles   = titles   x <> titles   y
	 , url      = url (x::About) <> url (y::About)
	 , authors  = authors  x <> authors  y
	 , editor   = editor   x <> editor   y
	 , date     = date     x <> date     y
	 , tags     = tags     x <> tags     y
	 , links    = links    x <> links    y
	 , series   = series   x <> series   y
	 , includes = includes x <> includes y
	 }

-- * Type 'Header'
data Header = Header
 { name  :: !TL.Text
 , 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
 { xmlPos    :: !XmlPos
 , attrs     :: !CommonAttrs
 , title     :: !Title
 , aliases   :: ![Alias]
 , judgments :: ![Judgment]
 } deriving (Eq,Show)

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

-- * Type 'Judgment'
data Judgment = Judgment
 { opinionsByChoice :: !(Maybe (MJ.OpinionsByChoice Choice Judge Grade))
 , judges           :: !Ident
 , grades           :: !Ident
 , importance       :: !(Maybe MJ.Share)
 , question         :: !(Maybe Title)
 , choices          :: ![Choice]
 } deriving (Show)
instance Eq Judgment where
	x==y =
		judges   x == judges   y &&
		grades   x == grades   y &&
		question x == question y
instance Hashable Judgment where
	hashWithSalt s Judgment{..} =
		s`hashWithSalt`judges
		 `hashWithSalt`grades
		 `hashWithSalt`question

-- ** Type 'Judge'
data Judge = Judge
 { name          :: !Name
 , title         :: !(Maybe Title)
 , defaultGrades :: ![(Ident, Name)]
 } deriving (Eq,Show)

-- ** Type 'Grade'
data Grade = Grade
 { xmlPos    :: !XmlPos
 , name      :: !Name
 , color     :: !TL.Text
 , isDefault :: !Bool
 , title     :: !(Maybe Title)
 } deriving (Eq,Show)

-- ** Type 'Choice'
data Choice = Choice
 { title    :: !(Maybe Title)
 , opinions :: ![Opinion]
 } deriving (Show)
instance Eq Choice where
	(==) = (==)`on`(title::Choice -> Maybe Title)
instance Hashable Choice where
	hashWithSalt s Choice{..} =
		hashWithSalt s title

-- ** Type 'Opinion'
data Opinion = Opinion
 { judge      :: !Name
 , grade      :: !Name
 , importance :: !(Maybe MJ.Share)
 , comment    :: !(Maybe Title)
 } deriving (Eq,Show)

-- * Type 'Para'
data Para
 = ParaItem  { item   :: !ParaItem }
 | ParaItems { xmlPos :: !XmlPos
             , 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 { href   :: !URL } -- ^ External reference
 | PlainIref { anchor :: !(Maybe Anchor)
             , term   :: !Words
             } -- ^ Index reference
 | PlainTag  { error  :: !(Maybe ErrorTarget)
             , tctPos :: !TCT.Spans
             } -- ^ Reference
 | PlainRref { error  :: !(Maybe ErrorTarget)
             , number :: !(Maybe Nat1)
             , tctPos :: !TCT.Spans
             , to     :: !Ident
             } -- ^ Reference reference
 | PlainSpan { attrs  :: !CommonAttrs } -- ^ Neutral node
 -- Leafs
 | PlainBreak -- ^ Line break (\n)
 | PlainText TL.Text
 | PlainNote { number :: !(Maybe Nat1)
             , note   :: ![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
 { section :: !XmlPos
 , 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{..}    -> pure $ TS.Tree PlainIref{anchor=Nothing, ..} skip
	 PlainRref{..}    -> pure $ TS.Tree PlainRref{error=Nothing, number=Nothing, tctPos=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 _to    -> keep
	 PlainTag{..}     -> pure $ TS.Tree PlainTag{tctPos=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`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`href
			 PlainRref{..} -> s`hashWithSalt`(13::Int)`hashWithSalt`to
			 PlainBreak    -> s`hashWithSalt`(14::Int)
			 PlainText t   -> s`hashWithSalt`(15::Int)`hashWithSalt`t

-- ** Type 'Entity'
data Entity = Entity
 { name    :: !TL.Text
 , street  :: !TL.Text
 , zipcode :: !TL.Text
 , city    :: !TL.Text
 , region  :: !TL.Text
 , country :: !TL.Text
 , email   :: !TL.Text
 , tel     :: !TL.Text
 , fax     :: !TL.Text
 , url     :: !(Maybe URL)
 , org     :: !(Maybe Entity)
 } deriving (Eq,Show)
instance Default Entity where
	def = Entity
	 { name    = def
	 , street  = def
	 , zipcode = def
	 , city    = def
	 , region  = def
	 , country = def
	 , email   = def
	 , tel     = def
	 , fax     = def
	 , url     = def
	 , org     = def
	 }
instance Semigroup Entity where
	_x <> y = y

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

-- * Type 'Reference'
data Reference = Reference
 { error  :: !(Maybe ErrorAnchor)
 , xmlPos :: !XmlPos
 , tctPos :: !TCT.Spans
 , id     :: !Ident
 , 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 'Aliases'
type Aliases = [Words]

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

-- * Type 'Count'
type Count = Int