Hdoc/DTC/Analyze/Check.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 module Hdoc.DTC.Analyze.Check where
   3
   4 import Control.Arrow ((&&&))
   5 import Data.Default.Class (Default(..))
   6 import Data.Eq (Eq(..))
   7 import Data.Foldable (Foldable(..))
   8 import Data.Function (($))
   9 import Data.Functor (Functor(..), (<$>))
  10 import Data.Monoid (Monoid(..))
  11 import Data.Ord (Ord(..))
  12 import Data.Semigroup (Semigroup(..))
  13 import Data.Sequence (Seq)
  14 import Data.Tuple (fst)
  15 import Text.Show (Show(..))
  16 import qualified Data.HashMap.Strict as HM
  17
  18 import Hdoc.DTC.Document
  19 import Hdoc.DTC.Analyze.Collect
  20
  21 -- ** Type 'Errors'
  22 data Errors a = Errors
  23  { errors_tag_unknown                :: HM.HashMap Title  a
  24  , errors_tag_ambiguous              :: HM.HashMap Title  a
  25  , errors_rref_unknown               :: HM.HashMap Ident  a
  26  , errors_reference_ambiguous        :: HM.HashMap Ident  a
  27  , errors_judgment_judges_unknown    :: HM.HashMap Ident  a
  28  , errors_judgment_grades_unknown    :: HM.HashMap Ident  a
  29  , errors_judgment_grades_duplicated :: HM.HashMap Ident  a
  30  , errors_judgment_judge_unknown     :: HM.HashMap Name   a
  31  , errors_judgment_judge_duplicated  :: HM.HashMap Name   a
  32  , errors_judgment_grade_unknown     :: HM.HashMap Name   a
  33  , errors_judgment_choice_duplicated :: HM.HashMap Title  a
  34  } deriving (Eq,Show)
  35 instance Default (Errors a) where
  36         def = Errors
  37          { errors_tag_unknown                = def
  38          , errors_tag_ambiguous              = def
  39          , errors_rref_unknown               = def
  40          , errors_reference_ambiguous        = def
  41          , errors_judgment_judges_unknown    = def
  42          , errors_judgment_judge_unknown     = def
  43          , errors_judgment_judge_duplicated  = def
  44          , errors_judgment_grades_unknown    = def
  45          , errors_judgment_grades_duplicated = def
  46          , errors_judgment_grade_unknown     = def
  47          , errors_judgment_choice_duplicated = def
  48          }
  49 instance Semigroup a => Semigroup (Errors a) where
  50         x<>y = Errors
  51          { errors_tag_unknown                = hm_union errors_tag_unknown
  52          , errors_tag_ambiguous              = hm_union errors_tag_ambiguous
  53          , errors_rref_unknown               = hm_union errors_rref_unknown
  54          , errors_reference_ambiguous        = hm_union errors_reference_ambiguous
  55          , errors_judgment_judges_unknown    = hm_union errors_judgment_judges_unknown
  56          , errors_judgment_judge_unknown     = hm_union errors_judgment_judge_unknown
  57          , errors_judgment_judge_duplicated  = hm_union errors_judgment_judge_duplicated
  58          , errors_judgment_grades_unknown    = hm_union errors_judgment_grades_unknown
  59          , errors_judgment_grades_duplicated = hm_union errors_judgment_grades_duplicated
  60          , errors_judgment_grade_unknown     = hm_union errors_judgment_grade_unknown
  61          , errors_judgment_choice_duplicated = hm_union errors_judgment_choice_duplicated
  62          } where hm_union get = HM.unionWith (<>) (get x) (get y)
  63 instance Semigroup a => Monoid (Errors a) where
  64         mempty  = def
  65         mappend = (<>)
  66 instance Functor Errors where
  67         fmap f Errors{..} = Errors
  68          { errors_tag_unknown                = fmap f errors_tag_unknown
  69          , errors_tag_ambiguous              = fmap f errors_tag_ambiguous
  70          , errors_rref_unknown               = fmap f errors_rref_unknown
  71          , errors_reference_ambiguous        = fmap f errors_reference_ambiguous
  72          , errors_judgment_judges_unknown    = fmap f errors_judgment_judges_unknown
  73          , errors_judgment_judge_unknown     = fmap f errors_judgment_judge_unknown
  74          , errors_judgment_judge_duplicated  = fmap f errors_judgment_judge_duplicated
  75          , errors_judgment_grades_unknown    = fmap f errors_judgment_grades_unknown
  76          , errors_judgment_grades_duplicated = fmap f errors_judgment_grades_duplicated
  77          , errors_judgment_grade_unknown     = fmap f errors_judgment_grade_unknown
  78          , errors_judgment_choice_duplicated = fmap f errors_judgment_choice_duplicated
  79          }
  80
  81 errors :: All -> Errors (Seq Location)
  82 errors All{..} =
  83         def -- FIXME: Errors
  84          { errors_tag_unknown =
  85                 HM.difference all_tag all_section
  86          , errors_tag_ambiguous =
  87                 HM.intersection all_tag $
  88                 HM.filter (\x -> length x > 1) all_section
  89          , errors_rref_unknown =
  90                 (fst <$>) <$>
  91                 HM.difference all_rrefs all_reference
  92          , errors_reference_ambiguous =
  93                 ((&&&) reference_locTCT reference_posXML <$>)
  94                  <$> HM.filter (\x -> length x > 1) all_reference
  95          {-
  96          , errors_judgment_judges_unknown =
  97          , errors_judgment_judge_unknown =
  98          , errors_judgment_judge_duplicated =
  99          , errors_judgment_grades_unknown =
 100          , errors_judgment_grades_duplicated =
 101          , errors_judgment_grade_unknown =
 102          , errors_judgment_choice_duplicated =
 103          -}
 104          }