Hdoc/DTC/Check/Judgment.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE UndecidableInstances #-}
   3 {-# OPTIONS_GHC -fno-warn-orphans #-}
   4 module Hdoc.DTC.Check.Judgment where
   5
   6 import Control.Arrow (second)
   7 import Control.Applicative (Applicative(..))
   8 import Control.Monad (Monad(..), forM, forM_, join)
   9 import Data.Bool
  10 import Data.Default.Class (Default(..))
  11 import Data.Eq (Eq(..))
  12 import Data.Foldable (Foldable(..))
  13 import Data.Function (($), (.), flip)
  14 import Data.Functor ((<$>), (<$))
  15 import Data.Functor.Compose (Compose(..))
  16 import Data.Maybe (Maybe(..), fromMaybe, listToMaybe)
  17 import Data.Ord (Ord(..))
  18 import Data.Semigroup (Semigroup(..))
  19 import Data.Traversable (Traversable(..))
  20 import Data.Tuple (snd)
  21 import qualified Control.Monad.Trans.State as S
  22 import qualified Data.HashMap.Strict as HM
  23 import qualified Data.HashSet as HS
  24 import qualified Data.List as List
  25 import qualified Data.Sequence as Seq
  26 import qualified Data.Set as Set
  27 import qualified Hjugement as MJ
  28
  29 import Hdoc.DTC.Document
  30 import Hdoc.DTC.Collect
  31 import Hdoc.DTC.Check.Base
  32 import Control.Monad.Utils
  33
  34 instance Check Title => Check Judges where
  35         check Judges{..} = do
  36                 let duplicatedJudges = HM.filter ((> 1) . length) judges_byName
  37                 unless (null duplicatedJudges) $ do
  38                         S.modify' $ \s@State{state_errors} -> s
  39                          { state_errors = state_errors
  40                                  { errors_judgment_judge_duplicated =
  41                                         HM.unionWith (flip (<>))
  42                                         (Seq.fromList . ((\Judge{..} -> (judge_locTCT, judge_posXML)) <$>) <$> duplicatedJudges) $
  43                                         errors_judgment_judge_duplicated state_errors
  44                                  }
  45                          }
  46                 Judges
  47                  judges_locTCT
  48                  judges_posXML
  49                  judges_attrs
  50                  <$> traverse (traverse check) judges_byName
  51 instance Check Title => Check [Grade] where
  52         check = traverse check
  53 instance Check Title => Check Judgment where
  54         check Judgment{..} = do
  55                 State{state_collect=All{..}} <- S.get
  56                 mayJudges <- do
  57                         case HM.lookup judgment_judgesId all_judges of
  58                          Just js -> return $ Just js
  59                          Nothing -> do
  60                                 S.modify' $ \s@State{state_errors} -> s
  61                                  { state_errors = state_errors
  62                                          { errors_judgment_judges_unknown =
  63                                                 HM.insertWith (flip (<>)) judgment_judgesId (pure (judgment_locTCT, judgment_posXML)) $
  64                                                 errors_judgment_judges_unknown state_errors
  65                                          }
  66                                  }
  67                                 return Nothing
  68                 mayGrades <- do
  69                         case HM.lookup judgment_gradesId all_grades of
  70                          Just gs -> return $ Just $ MJ.grades gs
  71                          Nothing -> do
  72                                 S.modify' $ \s@State{state_errors} -> s
  73                                  { state_errors = state_errors
  74                                          { errors_judgment_grades_unknown =
  75                                                 HM.insertWith (flip (<>)) judgment_gradesId (pure (judgment_locTCT, judgment_posXML)) $
  76                                                 errors_judgment_grades_unknown state_errors
  77                                          }
  78                                  }
  79                                 return Nothing
  80                 mayOpinionsByChoice  <- getCompose $ do
  81                         Judges{..} <- Compose $ return mayJudges
  82                         grades <- Compose $ return mayGrades
  83                         let defaultGradeByJudge =
  84                                 let defaultGrade =
  85                                         List.head
  86                                          [ g | g <- Set.toList grades
  87                                          , grade_isDefault $ MJ.unRank g
  88                                          ] in
  89                                 (<$> judges_byName) $ \js ->
  90                                         let Judge{..} = List.head js in
  91                                         let judgeDefaultGrade = do
  92                                                 grade <- join $ listToMaybe <$> HM.lookup judgment_gradesId judge_defaultGrades
  93                                                 listToMaybe
  94                                                  [ g | g <- Set.toList grades
  95                                                  , grade_name (MJ.unRank g) == grade
  96                                                  ] in
  97                                         defaultGrade`fromMaybe`judgeDefaultGrade
  98                         opinionsByChoice <-
  99                                 forM judgment_choices $ \choice@Choice{..} -> do
 100                                         gradeByJudge <- forM choice_opinions $ \opinion@Opinion{..} -> do
 101                                                 let mayGrade = do
 102                                                         listToMaybe
 103                                                          [ MJ.singleGrade g | g <- Set.toList grades
 104                                                          , grade_name (MJ.unRank g) == opinion_grade
 105                                                          ]
 106                                                 case mayGrade of
 107                                                  Just grd -> Compose $ return $ Just (opinion_judge, (opinion, grd))
 108                                                  Nothing -> do
 109                                                         liftComposeState $ S.modify' $ \s@State{state_errors} -> s
 110                                                          { state_errors = state_errors
 111                                                                  { errors_judgment_grade_unknown =
 112                                                                         HM.insertWith (flip (<>)) opinion_grade (pure (judgment_locTCT, judgment_posXML)) $
 113                                                                         errors_judgment_grade_unknown state_errors
 114                                                                  }
 115                                                          }
 116                                                         Compose $ return Nothing
 117                                         let gradeByJudges = HM.fromListWith (flip (<>)) $ second pure <$> gradeByJudge
 118                                         let duplicateJudges = HM.filter ((> 1) . length) gradeByJudges
 119                                         unless (null duplicateJudges) (do
 120                                                 liftComposeState $ S.modify' $ \s@State{state_errors} -> s
 121                                                  { state_errors = state_errors
 122                                                          { errors_judgment_judge_duplicated =
 123                                                                 HM.unionWith (flip (<>))
 124                                                                 (((\(Opinion{..}, _g) -> (opinion_locTCT, opinion_posXML)) <$>) <$> duplicateJudges) $
 125                                                                 errors_judgment_judge_duplicated state_errors
 126                                                          }
 127                                                  }
 128                                                 Compose $ return (Nothing::Maybe ())
 129                                          ) *>
 130                                          case MJ.opinions defaultGradeByJudge $ snd . List.head . toList <$> gradeByJudges of
 131                                          (ok,ko) | null ko   -> Compose $ return $ Just (choice, Seq.singleton (choice, ok))
 132                                                  | otherwise -> do
 133                                                 liftComposeState $ S.modify' $ \s@State{state_errors} -> s
 134                                                  { state_errors = state_errors
 135                                                          { errors_judgment_judge_unknown =
 136                                                                 HM.unionWith (flip (<>))
 137                                                                 (pure (judgment_locTCT, judgment_posXML) <$ HS.toMap ko) $
 138                                                                 errors_judgment_judge_unknown state_errors
 139                                                          }
 140                                                  }
 141                                                 Compose $ return Nothing
 142                         let opinionsByChoices = HM.fromListWith (flip (<>)) opinionsByChoice
 143                         let duplicateChoices = HM.filter ((> 1) . length) opinionsByChoices
 144                         unless (null duplicateChoices) $ do
 145                                 liftComposeState $ S.modify' $ \s@State{state_errors} -> s
 146                                  { state_errors = state_errors
 147                                          { errors_judgment_choice_duplicated =
 148                                                 HM.unionWith (flip (<>))
 149                                                 (HM.fromList $ (\(choice, os) ->
 150                                                         ( fromMaybe def $ choice_title choice
 151                                                         , (<$> os) $ \(Choice{..}, _ok) -> (choice_locTCT, choice_posXML)
 152                                                         )) <$> HM.toList duplicateChoices) $
 153                                                 errors_judgment_choice_duplicated state_errors
 154                                          }
 155                                  }
 156                                 Compose $ return (Nothing::Maybe ())
 157                         Compose $ return $ Just $
 158                                 snd . List.head . toList
 159                                  <$> opinionsByChoices
 160                 Judgment mayOpinionsByChoice mayJudges mayGrades
 161                  judgment_posXML
 162                  judgment_locTCT
 163                  judgment_judgesId
 164                  judgment_gradesId
 165                  judgment_importance
 166                  <$> check judgment_question
 167                  <*> traverse check judgment_choices
 168 instance Check Title => Check Choice where
 169         check Choice{..} =
 170                 Choice choice_locTCT  choice_posXML
 171                  <$> check choice_title
 172                  <*> traverse check choice_opinions
 173 instance Check Title => Check Opinion where
 174         check Opinion{..} =
 175                 Opinion
 176                  opinion_locTCT
 177                  opinion_posXML
 178                  opinion_judge
 179                  opinion_grade
 180                  opinion_importance
 181                  <$> check opinion_comment
 182 instance Check Title => Check Grade where
 183         check Grade{..} =
 184                 Grade grade_posXML grade_name grade_color grade_isDefault
 185                  <$> check grade_title
 186 instance Check Title => Check Judge where
 187         check Judge{..} = do
 188                 State{state_collect=All{..}} <- S.get
 189                 let duplicatedGrades = HM.filter ((> 1) . length) judge_defaultGrades
 190                 unless (null duplicatedGrades) $ do
 191                         S.modify' $ \s@State{state_errors} -> s
 192                          { state_errors = state_errors
 193                                  { errors_judgment_grades_duplicated =
 194                                         HM.unionWith (flip (<>))
 195                                         (Seq.fromList . ((judge_locTCT, judge_posXML) <$) <$> duplicatedGrades) $
 196                                         errors_judgment_grades_duplicated state_errors
 197                                  }
 198                          }
 199                 forM_ (HM.toList judge_defaultGrades) $ \(gradesId,gradeId) ->
 200                         case HM.lookup gradesId all_grades of
 201                          Just grades -> do
 202                                 return ()
 203                          Nothing -> do
 204                                 S.modify' $ \s@State{state_errors} -> s
 205                                  { state_errors = state_errors
 206                                          { errors_judgment_grades_unknown =
 207                                                 HM.insertWith (flip (<>)) gradesId (pure (judge_locTCT, judge_posXML)) $
 208                                                 errors_judgment_grades_unknown state_errors
 209                                          }
 210                                  }
 211                 Judge
 212                  judge_locTCT
 213                  judge_posXML
 214                  judge_name
 215                  <$> check judge_title
 216                  <*> pure judge_defaultGrades