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