Hdoc/DTC/Check/Base.hs

   1 {-# LANGUAGE DuplicateRecordFields #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE FlexibleContexts #-}
   4 {-# OPTIONS_GHC -fno-warn-orphans #-}
   5 module Hdoc.DTC.Check.Base where
   6
   7 import Data.Default.Class (Default(..))
   8 import Data.Eq (Eq(..))
   9 import Data.IntMap.Strict (IntMap)
  10 import Data.Map.Strict (Map)
  11 import Data.Maybe (Maybe(..))
  12 import Data.Sequence (Seq)
  13 import Data.Traversable (Traversable(..))
  14 import Text.Show (Show)
  15 import qualified Control.Monad.Trans.State as S
  16 import qualified Data.HashMap.Strict as HM
  17 import qualified Data.TreeMap.Strict as TreeMap
  18
  19 import Hdoc.DTC.Document
  20 import Hdoc.DTC.Index
  21 import Hdoc.DTC.Collect
  22 import qualified Hdoc.TCT.Cell as TCT
  23 import qualified Hdoc.XML as XML
  24
  25 -- * Type 'State'
  26 data State = State
  27  { state_section :: Maybe Section -- RO
  28  , state_irefs   :: Irefs
  29  , state_rrefs   :: HM.HashMap Ident [(Maybe Section, Nat1)]
  30  -- , state_tags    :: AnchorByIdent
  31  , state_notes   :: NotesBySection
  32  , state_note    :: Nat1
  33  , state_errors  :: Errors
  34  , state_collect :: All
  35  }
  36 instance Default State where
  37         def = State
  38          { state_section = def
  39          , state_irefs   = TreeMap.empty
  40          , state_rrefs   = def
  41          -- , state_tags    = def
  42          , state_notes   = def
  43          , state_note    = def
  44          , state_errors  = def
  45          , state_collect = def
  46          }
  47
  48 -- ** Type 'AnchorByIdent'
  49 type AnchorByIdent = HM.HashMap Ident [Anchor]
  50
  51 -- ** Type 'Notes'
  52 type Notes = IntMap [Para]
  53
  54 -- *** Type 'NotesBySection'
  55 type NotesBySection = Map XML.Ancestors Notes
  56
  57 -- * Type 'Errors'
  58 data Errors = Errors
  59  { errors_tag_unknown                :: HM.HashMap Title  (Seq TCT.Location)
  60  , errors_tag_ambiguous              :: HM.HashMap Title  (Seq TCT.Location)
  61  , errors_rref_unknown               :: HM.HashMap Ident  (Seq TCT.Location)
  62  , errors_reference_ambiguous        :: HM.HashMap Ident  (Seq TCT.Location)
  63  , errors_judgment_judges_unknown    :: HM.HashMap Ident  (Seq (TCT.Location, XML.Pos))
  64  , errors_judgment_grades_unknown    :: HM.HashMap Ident  (Seq (TCT.Location, XML.Pos))
  65  , errors_judgment_grades_duplicated :: HM.HashMap Ident  (Seq (TCT.Location, XML.Pos))
  66  , errors_judgment_judge_unknown     :: HM.HashMap Name   (Seq (TCT.Location, XML.Pos))
  67  , errors_judgment_judge_duplicated  :: HM.HashMap Name   (Seq (TCT.Location, XML.Pos))
  68  , errors_judgment_grade_unknown     :: HM.HashMap Name   (Seq (TCT.Location, XML.Pos))
  69  , errors_judgment_choice_duplicated :: HM.HashMap Title  (Seq (TCT.Location, XML.Pos))
  70  } deriving (Eq,Show)
  71 instance Default Errors where
  72         def = Errors
  73          { errors_tag_unknown                = def
  74          , errors_tag_ambiguous              = def
  75          , errors_rref_unknown               = def
  76          , errors_reference_ambiguous        = def
  77          , errors_judgment_judges_unknown    = def
  78          , errors_judgment_judge_unknown     = def
  79          , errors_judgment_judge_duplicated  = def
  80          , errors_judgment_grades_unknown    = def
  81          , errors_judgment_grades_duplicated = def
  82          , errors_judgment_grade_unknown     = def
  83          , errors_judgment_choice_duplicated = def
  84          }
  85
  86 -- * Class 'Check'
  87 class Check a where
  88         check :: a -> S.State State a
  89 instance Check a => Check (Maybe a) where
  90         check = traverse check