{-# 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.Map.Strict (Map)
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (Seq, ViewR(..), viewr)
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

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

-- * 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 { pos       :: Pos
               , attrs     :: CommonAttrs
               , title     :: Title
               , aliases   :: [Alias]
               , judgments :: [Judgment]
               }
 | BodyBlock Block -- ^ leaf
 deriving (Eq,Show)

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

-- * Type 'Judgment'
data Judgment = Judgment
 { 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
 { pos       :: Pos
 , 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 { pos   :: 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 { href :: URL } -- ^ External reference
 | PlainIref { anchor :: Maybe Anchor -- ^ Set by 'anchorify'.
             , term   :: Words
             } -- ^ Index reference
 | PlainRef  { to :: Ident }
             -- ^ Reference
 | PlainRref { anchor :: Maybe Anchor -- ^ Set by 'anchorify'.
             , 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 'Pos'
data Pos = Pos
 { pos_Ancestors                :: PosPath
 , pos_AncestorsWithFigureNames :: PosPath
 , pos_PrecedingSiblings        :: Map XmlName Rank
 } deriving (Eq,Show)
instance Ord Pos where
	compare = compare`on`pos_Ancestors
-- | Return only the hash on 'pos_Ancestors',
-- which is unique because 'PosPath'
-- includes the 'Rank' of each 'XmlNode'.
instance Hashable Pos where
	hashWithSalt s Pos{..} =
		s`hashWithSalt`pos_Ancestors
instance Default Pos where
	def = Pos mempty mempty mempty

-- *** Type 'PosPath'
type PosPath = Seq (XmlName,Rank)

posParent :: PosPath -> Maybe PosPath
posParent p =
	case viewr p of
	 EmptyR -> Nothing
	 ls :> _ -> Just ls

-- * 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 :: Pos
 , 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 _anchor term -> pure $ TS.Tree PlainIref{anchor=Nothing, term} skip
	 PlainRref _anchor to   -> pure $ TS.Tree PlainRref{anchor=Nothing, to} 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
	 PlainRef _to           -> keep
	 PlainBreak             -> keep
	 PlainText{}            -> keep
-- | Return the same hash if 'similarPlain' is applied on the 'Title' before hashing.
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
			 PlainRef{..}  -> s`hashWithSalt`(1::Int)`hashWithSalt`to
			 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'
data Include = Include
 { href :: Path
 } deriving (Eq,Show)
instance Default Include where
	def = Include
	 { href = def
	 }

-- * Type 'Reference'
data Reference = Reference
 { id    :: Ident
 , about :: About
 } deriving (Eq,Show)
reference :: Ident -> Reference
reference id =
	Reference
	 { id
	 , about = def
	 }
instance Default Reference where
	def = reference def

-- * 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'
data Alias = Alias
 { id :: Ident
 } deriving (Eq,Show)
instance Default Alias where
	def = Alias
	 { id = def
	 }

-- * 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