{-# 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_at :: !(Maybe Ident) , pageRef_path :: !PathPage } -- ^ 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