Hdoc/DTC/Check.hs

   1 {-# LANGUAGE DuplicateRecordFields #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE FlexibleContexts #-}
   4 {-# OPTIONS_GHC -fno-warn-orphans #-}
   5 module Hdoc.DTC.Check where
   6
   7 -- import Control.Category
   8 -- import Data.Char (Char)
   9 -- import Data.Monoid (Monoid(..))
  10 -- import Data.TreeMap.Strict (TreeMap(..))
  11 -- import qualified Data.Char as Char
  12 -- import qualified Data.Text.Lazy as TL
  13 -- import qualified Data.TreeSeq.Strict as TreeSeq
  14 -- import qualified Hjugement as MJ
  15 import Control.Applicative (Applicative(..))
  16 import Control.Monad (Monad(..))
  17 import Data.Bool
  18 import Data.Default.Class (Default(..))
  19 import Data.Eq (Eq)
  20 import Data.Foldable (Foldable(..))
  21 import Data.Function (($), const, flip)
  22 import Data.Functor ((<$>))
  23 import Data.IntMap.Strict (IntMap)
  24 import Data.Map.Strict (Map)
  25 import Data.Maybe (Maybe(..), maybe)
  26 import Data.Semigroup (Semigroup(..))
  27 import Data.Sequence (Seq)
  28 import Data.Traversable (Traversable(..))
  29 import Data.TreeSeq.Strict (Tree(..), tree0)
  30 import Data.Tuple (snd)
  31 import Text.Show (Show)
  32 import qualified Control.Monad.Trans.State as S
  33 import qualified Data.HashMap.Strict as HM
  34 import qualified Data.IntMap.Strict as IntMap
  35 import qualified Data.List as List
  36 import qualified Data.Map.Strict as Map
  37 import qualified Data.Sequence as Seq
  38 import qualified Data.Strict.Maybe as Strict
  39 import qualified Data.TreeMap.Strict as TreeMap
  40 import qualified Prelude (error)
  41
  42 import Hdoc.DTC.Document
  43 import Hdoc.DTC.Index
  44 import Hdoc.DTC.Collect
  45 import qualified Hdoc.TCT.Cell as TCT
  46
  47 -- * Type 'State'
  48 data State = State
  49  { state_section :: Maybe Section -- RO
  50  , state_irefs   :: Irefs
  51  , state_rrefs   :: HM.HashMap Ident [(Maybe Section, Nat1)]
  52  -- , state_refs    :: AnchorByIdent
  53  , state_notes   :: NotesBySection
  54  , state_note    :: Nat1
  55  , state_errors  :: Errors
  56  , state_collect :: All
  57  }
  58 instance Default State where
  59         def = State
  60          { state_section = def
  61          , state_irefs   = TreeMap.empty
  62          , state_rrefs   = def
  63          -- , state_refs    = def
  64          , state_notes   = def
  65          , state_note    = def
  66          , state_errors  = def
  67          , state_collect = def
  68          }
  69
  70 -- ** Type 'AnchorByIdent'
  71 type AnchorByIdent = HM.HashMap Ident [Anchor]
  72
  73 -- ** Type 'Notes'
  74 type Notes = IntMap [Para]
  75
  76 -- *** Type 'NotesBySection'
  77 type NotesBySection = Map XmlPosPath Notes
  78
  79 -- * Type 'Errors'
  80 data Errors = Errors
  81  { errors_tag_unknown         :: HM.HashMap Title (Seq TCT.Spans)
  82  , errors_tag_ambiguous       :: HM.HashMap Title (Seq TCT.Spans)
  83  , errors_rref_unknown        :: HM.HashMap Ident (Seq TCT.Spans)
  84  , errors_reference_ambiguous :: HM.HashMap Ident (Seq TCT.Spans)
  85  } deriving (Eq,Show)
  86 instance Default Errors where
  87         def = Errors
  88          { errors_tag_unknown         = def
  89          , errors_tag_ambiguous       = def
  90          , errors_rref_unknown        = def
  91          , errors_reference_ambiguous = def
  92          }
  93
  94 -- * Class 'Check'
  95 class Check a where
  96         check :: a -> S.State State a
  97 instance Check a => Check (Maybe a) where
  98         check = traverse check
  99 instance Check Body where
 100         check = traverse check
 101 instance Check (Tree BodyNode) where
 102         check = \case
 103          Tree n ts ->
 104                 case n of
 105                  BodySection section@Section{..} -> do
 106                         before@State{state_section} <- S.get
 107                         S.put before{state_section = Just section}
 108                         t <- Tree <$> check n <*> check ts
 109                         S.modify' $ \s -> s{state_section}
 110                         return t
 111                  BodyBlock{} -> tree0 <$> check n
 112 instance Check BodyNode where
 113         check = \case
 114          BodySection s -> BodySection <$> check s
 115          BodyBlock   b -> BodyBlock   <$> check b
 116 instance Check Section where
 117         check Section{..} =
 118                 Section xmlPos attrs
 119                  <$> check title
 120                  <*> pure aliases
 121                  <*> traverse check judgments
 122 instance Check Block where
 123         check = \case
 124          BlockPara p    -> BlockPara <$> check p
 125          b@BlockBreak{} -> return b
 126          b@BlockToC{}   -> return b
 127          b@BlockToF{}   -> return b
 128          b@BlockIndex{} -> return b
 129          BlockAside{..} ->
 130                 BlockAside xmlPos attrs
 131                  <$> traverse check blocks
 132          BlockFigure{..} ->
 133                 BlockFigure xmlPos type_ attrs
 134                  <$> check mayTitle
 135                  <*> traverse check paras
 136          BlockReferences{..} ->
 137                 BlockReferences xmlPos attrs
 138                  <$> traverse check refs
 139          BlockJudges{..} ->
 140                 BlockJudges xmlPos attrs
 141                  <$> traverse check jury
 142          BlockGrades{..} ->
 143                 BlockGrades xmlPos attrs
 144                  <$> traverse check scale
 145 instance Check Para where
 146         check = \case
 147          ParaItem{..}  -> ParaItem <$> check item
 148          ParaItems{..} -> ParaItems xmlPos attrs <$> traverse check items
 149 instance Check ParaItem where
 150         check = \case
 151          ParaPlain plain -> ParaPlain       <$> check plain
 152          ParaOL items    -> ParaOL          <$> traverse check items
 153          ParaUL items    -> ParaUL          <$> traverse (traverse check) items
 154          ParaQuote{..}   -> ParaQuote type_ <$> traverse check paras
 155          p@ParaArtwork{} -> return p
 156          p@ParaComment{} -> return p
 157          ParaJudgment j  -> ParaJudgment <$> check j
 158 instance Check ListItem where
 159         check ListItem{..} = ListItem name <$> traverse check paras
 160 instance Check Plain where
 161         check = traverse check
 162 instance Check (Tree PlainNode) where
 163         check (Tree n ts) = do
 164                 st@State{state_collect=All{..}, ..} <- S.get
 165                 case n of
 166                  PlainIref{term}
 167                   | not $ null state_irefs
 168                   , Just words <- pathFromWords term
 169                   , Strict.Just anchs <- TreeMap.lookup words state_irefs -> do
 170                         -- NOTE: Insert new anchor for this index ref.
 171                         let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c
 172                         let anch = Anchor{count, section=maybe def (xmlPos::Section -> XmlPos) state_section}
 173                         S.put st
 174                          { state_irefs = TreeMap.insert const words (anch:anchs) state_irefs }
 175                         Tree PlainIref{term, anchor=Just anch}
 176                          <$> traverse check ts
 177                  PlainText txt
 178                   | not $ null state_irefs -> do
 179                         -- NOTE: Find indexed words in this text.
 180                         let (irefs,para) = indexifyWords (maybe def (xmlPos::Section -> XmlPos) state_section) state_irefs (wordify txt)
 181                         S.put st
 182                          { state_irefs = irefs }
 183                         return $ Tree PlainGroup para
 184                  PlainNote{..} -> do
 185                         -- NOTE: Insert new note for this section.
 186                         let section = xmlPos_Ancestors $ maybe def (xmlPos::Section -> XmlPos) state_section
 187                         S.put st
 188                          { state_note = succNat1 state_note }
 189                         note' <- traverse check note
 190                         let noteByNumber = IntMap.singleton (unNat1 state_note) note'
 191                         State{state_notes=notes} <- S.get
 192                         S.modify' $ \s -> s
 193                          { state_notes = Map.insertWith (<>) section noteByNumber notes }
 194                         Tree PlainNote{number=Just state_note, note=note'}
 195                          <$> traverse check ts -- NOTE: normally ts is empty anyway
 196                  PlainRref{..} -> do
 197                         let targets = HM.lookupDefault Seq.empty to all_reference
 198                         case toList targets of
 199                          [] -> do
 200                                 let err =
 201                                         HM.insertWith (flip (<>)) to (pure tctPos) $
 202                                         errors_rref_unknown state_errors
 203                                 S.put st
 204                                  { state_errors = state_errors
 205                                          { errors_rref_unknown = err }
 206                                  }
 207                                 Tree PlainRref{error = Just $ ErrorTarget_Unknown $ Nat1 $ length $ err HM.!to, ..}
 208                                  <$> traverse check ts
 209                          [_] -> do
 210                                 let rrefs = HM.insertWith
 211                                          (const $ \old ->
 212                                                 let (_sec,num) = List.head old in
 213                                                 (state_section, succNat1 num) : old)
 214                                          to [(state_section, Nat1 1)]
 215                                          state_rrefs
 216                                 S.put st
 217                                  { state_rrefs = rrefs }
 218                                 Tree PlainRref{error = Nothing, number = Just $ snd $ List.head $ rrefs HM.!to, ..}
 219                                  <$> traverse check ts
 220                          _ ->
 221                                 -- NOTE: ambiguity is checked when checking 'Reference'.
 222                                 Tree PlainRref{error = Just $ ErrorTarget_Ambiguous Nothing, number = Nothing, ..}
 223                                  <$> traverse check ts
 224                  PlainTag{tctPos} -> do
 225                         let to = Title ts
 226                         let targets = HM.lookupDefault Seq.empty to all_section
 227                         case toList targets of
 228                          [] -> do
 229                                 let err =
 230                                         HM.insertWith (flip (<>)) to (pure tctPos) $
 231                                         errors_tag_unknown state_errors
 232                                 S.put st
 233                                  { state_errors = state_errors
 234                                          { errors_tag_unknown = err }
 235                                  }
 236                                 Tree PlainTag{error = Just $ ErrorTarget_Unknown $ Nat1 $ length $ err HM.!to, ..}
 237                                  <$> traverse check ts
 238                          [_] ->
 239                                 Tree PlainTag{error = Nothing, ..}
 240                                  <$> traverse check ts
 241                          _ -> do
 242                                 let err =
 243                                         HM.insertWith (flip (<>)) to (pure tctPos) $
 244                                         errors_tag_ambiguous state_errors
 245                                 S.put st
 246                                  { state_errors = state_errors
 247                                          { errors_tag_ambiguous = err }
 248                                  }
 249                                 Tree PlainTag{error = Just $ ErrorTarget_Ambiguous $ Just $ Nat1 $ length $ err HM.!to, ..}
 250                                  <$> traverse check ts
 251                  _ -> Tree n <$> traverse check ts
 252 instance Check Title where
 253         check (Title p) = Title <$> check p
 254 instance Check About where
 255         check About{..} =
 256                 About headers
 257                  <$> traverse check titles
 258                  <*> pure url
 259                  <*> traverse check authors
 260                  <*> traverse check editor
 261                  <*> traverse check date
 262                  <*> pure tags
 263                  <*> pure links
 264                  <*> pure series
 265                  <*> traverse check includes
 266 instance Check Entity where
 267         check = return -- TODO: to be coded
 268 instance Check Date where
 269         check = return -- TODO: to be coded
 270 instance Check Include where
 271         check = return -- TODO: to be coded
 272 instance Check Reference where
 273         check Reference{..} = do
 274                 st@State{state_collect=All{..}, ..} <- S.get
 275                 let targets = HM.lookupDefault Seq.empty id all_reference
 276                 case toList targets of
 277                  [] -> Prelude.error "[BUG] check Reference"
 278                  [_] -> do
 279                         about' <- check about
 280                         return $ Reference{error=Nothing, about=about', ..}
 281                  _ -> do
 282                         let err =
 283                                 HM.insertWith (flip (<>)) id (pure tctPos) $
 284                                 errors_reference_ambiguous state_errors
 285                         S.put st
 286                          { state_errors = state_errors
 287                                  { errors_reference_ambiguous = err }
 288                          }
 289                         about' <- check about
 290                         return $ Reference{error=Just $ ErrorAnchor_Ambiguous $ Nat1 $ length $ err HM.!id, about=about', ..}
 291 instance Check Judgment where
 292         check Judgment{..} =
 293                 Judgment opinionsByChoice judges grades importance
 294                  <$> check question
 295                  <*> traverse check choices
 296 instance Check Choice where
 297         check Choice{..} =
 298                 Choice
 299                  <$> check title
 300                  <*> traverse check opinions
 301 instance Check Opinion where
 302         check Opinion{..} =
 303                 Opinion judge grade importance
 304                  <$> check comment
 305 instance Check Grade where
 306         check Grade{..} =
 307                 Grade xmlPos name color isDefault
 308                  <$> check title
 309 instance Check Judge where
 310         check Judge{..} =
 311                 Judge name
 312                  <$> check title
 313                  <*> pure defaultGrades