Hdoc/DTC/Check.hs

   1 {-# LANGUAGE DuplicateRecordFields #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3 module Hdoc.DTC.Check
   4  ( {-module Hdoc.DTC.Check
   5  ,-} module Hdoc.DTC.Check.Base
   6  -- , module Hdoc.DTC.Check.Judgment
   7  ) where
   8
   9 import Control.Applicative (Applicative(..))
  10 import Control.Monad (Monad(..))
  11 import Data.Bool
  12 import Data.Default.Class (Default(..))
  13 import Data.Foldable (Foldable(..))
  14 import Data.Function (($), (.), const, flip)
  15 import Data.Functor ((<$>))
  16 import Data.Maybe (Maybe(..), maybe, listToMaybe)
  17 import Data.Semigroup (Semigroup(..))
  18 import Data.Traversable (Traversable(..))
  19 import Data.TreeSeq.Strict (Tree(..), tree0)
  20 import Data.Tuple (snd)
  21 import Prelude (undefined)
  22 import qualified Control.Monad.Trans.State as S
  23 import qualified Data.HashMap.Strict as HM
  24 import qualified Data.IntMap.Strict as IntMap
  25 import qualified Data.List as List
  26 import qualified Data.Map.Strict as Map
  27 import qualified Data.Sequence as Seq
  28 import qualified Data.Strict.Maybe as Strict
  29 import qualified Data.TreeMap.Strict as TreeMap
  30
  31 import Hdoc.DTC.Document
  32 import Hdoc.DTC.Index
  33 import Hdoc.DTC.Collect
  34 import Hdoc.DTC.Check.Base
  35 import Hdoc.DTC.Check.Judgment ()
  36 import qualified Hdoc.XML as XML
  37
  38 instance Check Body where
  39         check = traverse check
  40 instance Check (Tree BodyNode) where
  41         check = \case
  42          Tree n ts ->
  43                 case n of
  44                  BodySection section@Section{..} -> do
  45                         before@State{state_section} <- S.get
  46                         S.put before{state_section = Just section}
  47                         t <- Tree <$> check n <*> check ts
  48                         S.modify' $ \s -> s{state_section}
  49                         return t
  50                  BodyBlock{} -> tree0 <$> check n
  51 instance Check BodyNode where
  52         check = \case
  53          BodySection s -> BodySection <$> check s
  54          BodyBlock   b -> BodyBlock   <$> check b
  55 instance Check Section where
  56         check Section{..} =
  57                 Section section_posXML section_attrs
  58                  <$> check section_title
  59                  <*> pure section_aliases
  60                  <*> traverse check section_judgments
  61 instance Check Block where
  62         check = \case
  63          BlockPara p    -> BlockPara <$> check p
  64          b@BlockBreak{} -> return b
  65          b@BlockToC{}   -> return b
  66          b@BlockToF{}   -> return b
  67          b@BlockIndex{} -> return b
  68          BlockAside{..} ->
  69                 BlockAside posXML attrs
  70                  <$> traverse check blocks
  71          BlockFigure{..} ->
  72                 BlockFigure posXML type_ attrs
  73                  <$> check mayTitle
  74                  <*> traverse check paras
  75          BlockReferences{..} ->
  76                 BlockReferences posXML attrs
  77                  <$> traverse check refs
  78          BlockJudges js -> BlockJudges <$> check js
  79          BlockGrades{..} ->
  80                 BlockGrades posXML attrs
  81                  <$> check scale
  82 instance Check Para where
  83         check = \case
  84          ParaItem{..}  -> ParaItem <$> check item
  85          ParaItems{..} -> ParaItems posXML attrs <$> traverse check items
  86 instance Check ParaItem where
  87         check = \case
  88          ParaPlain plain -> ParaPlain       <$> check plain
  89          ParaOL items    -> ParaOL          <$> traverse check items
  90          ParaUL items    -> ParaUL          <$> traverse (traverse check) items
  91          ParaQuote{..}   -> ParaQuote type_ <$> traverse check paras
  92          p@ParaArtwork{} -> return p
  93          p@ParaComment{} -> return p
  94          ParaJudgment j  -> ParaJudgment <$> check j
  95 instance Check ListItem where
  96         check ListItem{..} = ListItem name <$> traverse check paras
  97 instance Check Plain where
  98         check = traverse check
  99 instance Check (Tree PlainNode) where
 100         check (Tree n ts) = do
 101                 st@State{state_collect=All{..}, ..} <- S.get
 102                 case n of
 103                  PlainIref{..}
 104                   | not $ null state_irefs
 105                   , Just words <- pathFromWords iref_term
 106                   , Strict.Just anchors <- TreeMap.lookup words state_irefs -> do
 107                         -- NOTE: Insert new anchor for this index ref.
 108                         let anchor = Anchor
 109                                  { anchor_count   = maybe def (succNat1 . anchor_count) $ listToMaybe anchors
 110                                  , anchor_section = maybe def section_posXML state_section
 111                                  }
 112                         S.put st
 113                          { state_irefs = TreeMap.insert const words (anchor:anchors) state_irefs }
 114                         Tree PlainIref
 115                          { iref_term
 116                          , iref_anchor = Just anchor }
 117                          <$> traverse check ts
 118                  PlainText txt
 119                   | not $ null state_irefs -> do
 120                         -- NOTE: Find indexed words in this text.
 121                         let (irefs,para) = indexifyWords (maybe def section_posXML state_section) state_irefs (wordify txt)
 122                         S.put st
 123                          { state_irefs = irefs }
 124                         return $ Tree PlainGroup para
 125                  PlainNote{..} -> do
 126                         -- NOTE: Insert new note for this section.
 127                         let section = XML.pos_ancestors $ maybe def section_posXML state_section
 128                         S.put st
 129                          { state_note = succNat1 state_note }
 130                         paras <- traverse check note_paras
 131                         let noteByNumber = IntMap.singleton (unNat1 state_note) note_paras
 132                         State{state_notes=notes} <- S.get
 133                         S.modify' $ \s -> s
 134                          { state_notes = Map.insertWith (<>) section noteByNumber notes }
 135                         Tree PlainNote
 136                          { note_number = Just state_note
 137                          , note_paras  = paras }
 138                          <$> traverse check ts -- NOTE: normally ts is empty anyway
 139                  PlainRref{..} -> do
 140                         let targets = HM.lookupDefault Seq.empty rref_to all_reference
 141                         case toList targets of
 142                          [] -> do
 143                                 let err =
 144                                         HM.insertWith (flip (<>)) rref_to (pure rref_locTCT) $
 145                                         errors_rref_unknown state_errors
 146                                 S.put st
 147                                  { state_errors = state_errors
 148                                          { errors_rref_unknown = err }
 149                                  }
 150                                 Tree PlainRref
 151                                  { rref_error = Just $ ErrorTarget_Unknown $ Nat1 $ length $ err HM.!rref_to
 152                                  , .. }
 153                                  <$> traverse check ts
 154                          [_] -> do
 155                                 let rrefs = HM.insertWith
 156                                          (const $ \old ->
 157                                                 let (_sec,num) = List.head old in
 158                                                 (state_section, succNat1 num) : old)
 159                                          rref_to [(state_section, Nat1 1)]
 160                                          state_rrefs
 161                                 S.put st
 162                                  { state_rrefs = rrefs }
 163                                 Tree PlainRref
 164                                  { rref_error  = Nothing
 165                                  , rref_number = Just $ snd $ List.head $ rrefs HM.!rref_to
 166                                  , .. }
 167                                  <$> traverse check ts
 168                          _ ->
 169                                 -- NOTE: ambiguity is checked when checking 'Reference'.
 170                                 Tree PlainRref
 171                                  { rref_error = Just $ ErrorTarget_Ambiguous Nothing
 172                                  , rref_number = Nothing
 173                                  , .. }
 174                                  <$> traverse check ts
 175                  PlainTag{..} -> do
 176                         let tag_to = Title ts
 177                         let targets = HM.lookupDefault Seq.empty tag_to all_section
 178                         case toList targets of
 179                          [] -> do
 180                                 let err =
 181                                         HM.insertWith (flip (<>)) tag_to (pure tag_locTCT) $
 182                                         errors_tag_unknown state_errors
 183                                 S.put st
 184                                  { state_errors = state_errors
 185                                          { errors_tag_unknown = err }
 186                                  }
 187                                 Tree PlainTag
 188                                  { tag_error = Just $ ErrorTarget_Unknown $ Nat1 $ length $ err HM.!tag_to
 189                                  , .. }
 190                                  <$> traverse check ts
 191                          [_] ->
 192                                 Tree PlainTag{tag_error = Nothing, ..}
 193                                  <$> traverse check ts
 194                          _ -> do
 195                                 let err =
 196                                         HM.insertWith (flip (<>)) tag_to (pure tag_locTCT) $
 197                                         errors_tag_ambiguous state_errors
 198                                 S.put st
 199                                  { state_errors = state_errors
 200                                          { errors_tag_ambiguous = err }
 201                                  }
 202                                 Tree PlainTag
 203                                  { tag_error = Just $ ErrorTarget_Ambiguous $ Just $ Nat1 $ length $ err HM.!tag_to
 204                                  , .. }
 205                                  <$> traverse check ts
 206                  _ -> Tree n <$> traverse check ts
 207 instance Check Title where
 208         check (Title p) = Title <$> check p
 209 instance Check About where
 210         check About{..} =
 211                 About headers
 212                  <$> traverse check titles
 213                  <*> pure url
 214                  <*> traverse check authors
 215                  <*> traverse check editor
 216                  <*> traverse check date
 217                  <*> pure tags
 218                  <*> pure links
 219                  <*> pure series
 220                  <*> traverse check includes
 221 instance Check Entity where
 222         check = return -- TODO: to be coded
 223 instance Check Date where
 224         check = return -- TODO: to be coded
 225 instance Check Include where
 226         check = return -- TODO: to be coded
 227 instance Check Reference where
 228         check Reference{..} = do
 229                 st@State{state_collect=All{..}, ..} <- S.get
 230                 let targets = HM.lookupDefault Seq.empty reference_id all_reference
 231                 case toList targets of
 232                  [] -> undefined
 233                  [_] -> do
 234                         about <- check reference_about
 235                         return $ Reference
 236                          { reference_error = Nothing
 237                          , reference_about = about
 238                          , .. }
 239                  _ -> do
 240                         let err =
 241                                 HM.insertWith (flip (<>)) reference_id (pure reference_locTCT) $
 242                                 errors_reference_ambiguous state_errors
 243                         S.put st
 244                          { state_errors = state_errors
 245                                  { errors_reference_ambiguous = err }
 246                          }
 247                         about <- check reference_about
 248                         return $ Reference
 249                          { reference_error = Just $ ErrorAnchor_Ambiguous $ Nat1 $ length $ err HM.!reference_id
 250                          , reference_about = about
 251                          , .. }