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_at_unknown                 :: HM.HashMap Ident  a
  24  , errors_at_ambiguous               :: HM.HashMap Ident  a
  25  , errors_ref_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_grade_duplicated  :: HM.HashMap Ident  a
  31  , errors_judgment_judge_unknown     :: HM.HashMap Name   a
  32  , errors_judgment_judge_duplicated  :: HM.HashMap Name   a
  33  , errors_judgment_grade_unknown     :: HM.HashMap Name   a
  34  , errors_judgment_choice_duplicated :: HM.HashMap Title  a
  35  } deriving (Eq,Show)
  36 instance Default (Errors a) where
  37         def = Errors
  38          { errors_at_unknown                 = def
  39          , errors_at_ambiguous               = def
  40          , errors_ref_unknown                = def
  41          , errors_reference_ambiguous        = def
  42          , errors_judgment_judges_unknown    = def
  43          , errors_judgment_judge_unknown     = def
  44          , errors_judgment_judge_duplicated  = def
  45          , errors_judgment_grades_unknown    = def
  46          , errors_judgment_grades_duplicated = def
  47          , errors_judgment_grade_duplicated  = def
  48          , errors_judgment_grade_unknown     = def
  49          , errors_judgment_choice_duplicated = def
  50          }
  51 instance Semigroup a => Semigroup (Errors a) where
  52         x<>y = Errors
  53          { errors_at_unknown                 = hm_union errors_at_unknown
  54          , errors_at_ambiguous               = hm_union errors_at_ambiguous
  55          , errors_ref_unknown                = hm_union errors_ref_unknown
  56          , errors_reference_ambiguous        = hm_union errors_reference_ambiguous
  57          , errors_judgment_judges_unknown    = hm_union errors_judgment_judges_unknown
  58          , errors_judgment_judge_unknown     = hm_union errors_judgment_judge_unknown
  59          , errors_judgment_judge_duplicated  = hm_union errors_judgment_judge_duplicated
  60          , errors_judgment_grades_unknown    = hm_union errors_judgment_grades_unknown
  61          , errors_judgment_grades_duplicated = hm_union errors_judgment_grades_duplicated
  62          , errors_judgment_grade_duplicated  = hm_union errors_judgment_grade_duplicated
  63          , errors_judgment_grade_unknown     = hm_union errors_judgment_grade_unknown
  64          , errors_judgment_choice_duplicated = hm_union errors_judgment_choice_duplicated
  65          } where hm_union get = HM.unionWith (<>) (get x) (get y)
  66 instance Semigroup a => Monoid (Errors a) where
  67         mempty  = def
  68         mappend = (<>)
  69 instance Functor Errors where
  70         fmap f Errors{..} = Errors
  71          { errors_at_unknown                 = fmap f errors_at_unknown
  72          , errors_at_ambiguous               = fmap f errors_at_ambiguous
  73          , errors_ref_unknown                = fmap f errors_ref_unknown
  74          , errors_reference_ambiguous        = fmap f errors_reference_ambiguous
  75          , errors_judgment_judges_unknown    = fmap f errors_judgment_judges_unknown
  76          , errors_judgment_judge_unknown     = fmap f errors_judgment_judge_unknown
  77          , errors_judgment_judge_duplicated  = fmap f errors_judgment_judge_duplicated
  78          , errors_judgment_grades_unknown    = fmap f errors_judgment_grades_unknown
  79          , errors_judgment_grades_duplicated = fmap f errors_judgment_grades_duplicated
  80          , errors_judgment_grade_duplicated  = fmap f errors_judgment_grade_duplicated
  81          , errors_judgment_grade_unknown     = fmap f errors_judgment_grade_unknown
  82          , errors_judgment_choice_duplicated = fmap f errors_judgment_choice_duplicated
  83          }
  84
  85 errors :: All -> Errors (Seq Location)
  86 errors All{..} =
  87         def -- FIXME: Errors
  88          { errors_at_unknown =
  89                 (fst <$>) <$>
  90                 HM.difference all_at all_section
  91          , errors_at_ambiguous =
  92                 HM.intersection ((fst <$>) <$> all_at) $
  93                 HM.filter (\x -> length x > 1) all_section
  94          , errors_ref_unknown =
  95                 (fst <$>) <$>
  96                 HM.difference all_ref all_reference
  97          , errors_reference_ambiguous =
  98                 ((&&&) reference_locTCT reference_posXML <$>)
  99                  <$> HM.filter (\x -> length x > 1) all_reference
 100          {-
 101          , errors_judgment_judges_unknown =
 102          , errors_judgment_judge_unknown =
 103          , errors_judgment_judge_duplicated =
 104          , errors_judgment_grades_unknown =
 105          , errors_judgment_grades_duplicated =
 106          , errors_judgment_grade_duplicated =
 107          , errors_judgment_grade_unknown =
 108          , errors_judgment_choice_duplicated =
 109          -}
 110          }