Hdoc/DTC/Check.hs

   1 {-# LANGUAGE DuplicateRecordFields #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE FlexibleContexts #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 {-# OPTIONS_GHC -fno-warn-orphans #-}
   6 module Hdoc.DTC.Check where
   7
   8 import Control.Applicative (Applicative(..))
   9 import Control.Category
  10 import Control.Monad (Monad(..))
  11 import Data.Bool
  12 import Data.Char (Char)
  13 import Data.Default.Class (Default(..))
  14 import Data.Eq (Eq)
  15 import Data.Foldable (Foldable(..), concat)
  16 import Data.Function (($), const)
  17 import Data.Functor ((<$>))
  18 import Data.Map.Strict (Map)
  19 import Data.IntMap.Strict (IntMap)
  20 import Data.Maybe (Maybe(..), maybe)
  21 import Data.Monoid (Monoid(..))
  22 import Data.Semigroup (Semigroup(..))
  23 import Data.Sequence ((|>))
  24 import Data.Traversable (Traversable(..))
  25 import Data.TreeMap.Strict (TreeMap(..))
  26 import Data.TreeSeq.Strict (Tree(..), tree0)
  27 import Text.Show (Show)
  28 import qualified Control.Monad.Trans.State as S
  29 import qualified Data.Char as Char
  30 import qualified Data.List as List
  31 import qualified Data.Map.Strict as Map
  32 import qualified Data.IntMap.Strict as IntMap
  33 import qualified Data.Sequence as Seq
  34 import qualified Data.Strict.Maybe as Strict
  35 import qualified Data.Text.Lazy as TL
  36 import qualified Data.TreeMap.Strict as TreeMap
  37 -- import qualified Data.TreeSeq.Strict as TreeSeq
  38 import qualified Hjugement as MJ
  39
  40 import Hdoc.DTC.Document
  41 import Hdoc.DTC.Index
  42
  43 -- * Type 'Rrefs'
  44 type Rrefs = Map Ident [Anchor]
  45
  46 -- * Type 'NotesBySection'
  47 type NotesBySection = Map PosPath Notes
  48
  49 -- ** Type 'Notes'
  50 type Notes = IntMap [Para]
  51
  52 -- * Type 'State'
  53 data State = State
  54  { state_section :: Pos -- RO
  55  , state_irefs   :: Irefs
  56  , state_rrefs   :: Rrefs
  57  , state_notes   :: NotesBySection
  58  , state_note    :: Nat1
  59  , state_errors  :: [Error]
  60  }
  61 instance Default State where
  62         def = State
  63          { state_section = def
  64          , state_irefs   = TreeMap.empty
  65          , state_rrefs   = def
  66          , state_notes   = def
  67          , state_note    = def
  68          , state_errors  = def
  69          }
  70
  71 -- * Type 'Error'
  72 data Error
  73  = Error_Judgment (MJ.ErrorSection Choice Judge Grade)
  74  | Error_Rref_missing
  75  deriving (Eq,Show)
  76
  77 -- * Class 'Check'
  78 class Check a where
  79         check :: a -> S.State State a
  80 instance Check a => Check (Maybe a) where
  81         check = traverse check
  82 instance Check Body where
  83         check = traverse check
  84 instance Check (Tree BodyNode) where
  85         check = \case
  86          Tree n ts ->
  87                 case n of
  88                  BodySection{..} -> do
  89                         before@State{state_section} <- S.get
  90                         S.put before{state_section = pos}
  91                         t <- Tree <$> check n <*> check ts
  92                         S.modify' $ \s -> s{state_section}
  93                         return t
  94                  BodyBlock{} -> tree0 <$> check n
  95 instance Check BodyNode where
  96         check = \case
  97          BodySection{..} ->
  98                 BodySection pos attrs
  99                  <$> check title
 100                  <*> pure aliases
 101                  <*> traverse check judgments
 102          BodyBlock b -> BodyBlock <$> check b
 103 instance Check Block where
 104         check = \case
 105          BlockPara p    -> BlockPara <$> check p
 106          b@BlockBreak{} -> return b
 107          b@BlockToC{}   -> return b
 108          b@BlockToF{}   -> return b
 109          b@BlockIndex{} -> return b
 110          BlockAside{..} ->
 111                 BlockAside pos attrs
 112                  <$> traverse check blocks
 113          BlockFigure{..} ->
 114                 BlockFigure pos type_ attrs
 115                  <$> check mayTitle
 116                  <*> traverse check paras
 117          BlockReferences{..} ->
 118                 BlockReferences pos attrs
 119                  <$> traverse check refs
 120          BlockJudges{..} ->
 121                 BlockJudges pos attrs
 122                  <$> traverse check jury
 123          BlockGrades{..} ->
 124                 BlockGrades pos attrs
 125                  <$> traverse check scale
 126 instance Check Para where
 127         check = \case
 128          ParaItem{..}  -> ParaItem <$> check item
 129          ParaItems{..} -> ParaItems pos attrs <$> traverse check items
 130 instance Check ParaItem where
 131         check = \case
 132          ParaPlain plain -> ParaPlain       <$> check plain
 133          ParaOL items    -> ParaOL          <$> traverse check items
 134          ParaUL items    -> ParaUL          <$> traverse (traverse check) items
 135          ParaQuote{..}   -> ParaQuote type_ <$> traverse check paras
 136          p@ParaArtwork{} -> return p
 137          p@ParaComment{} -> return p
 138          ParaJudgment j  -> ParaJudgment <$> check j
 139 instance Check ListItem where
 140         check ListItem{..} = ListItem name <$> traverse check paras
 141 instance Check Plain where
 142         check = traverse check
 143 instance Check (Tree PlainNode) where
 144         check (Tree n ts) = do
 145                 State{..} <- S.get
 146                 case n of
 147                  PlainIref{term}
 148                   | not $ null state_irefs
 149                   , Just words <- pathFromWords term
 150                   , Strict.Just anchs <- TreeMap.lookup words state_irefs -> do
 151                         -- NOTE: Insert new anchor for this index ref.
 152                         let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c
 153                         let anch = Anchor{count, section=state_section}
 154                         S.modify' $ \s -> s
 155                          { state_irefs = TreeMap.insert const words (anch:anchs) state_irefs }
 156                         Tree PlainIref{term, anchor=Just anch}
 157                          <$> traverse check ts
 158                  PlainText txt
 159                   | not $ null state_irefs -> do
 160                         -- NOTE: Find indexed words in this text.
 161                         let (irefs,para) = indexifyWords state_section state_irefs (wordify txt)
 162                         S.modify' $ \s -> s
 163                          { state_irefs = irefs }
 164                         return $ Tree PlainGroup para
 165                  PlainNote{..} -> do
 166                         -- NOTE: Insert new note for this section.
 167                         let section = pos_Ancestors state_section
 168                         S.modify' $ \s -> s
 169                          { state_note = succNat1 state_note }
 170                         note' <- traverse check note
 171                         let noteByNumber = IntMap.singleton (unNat1 state_note) note'
 172                         State{state_notes=notes} <- S.get
 173                         S.modify' $ \s -> s
 174                          { state_notes = Map.insertWith (<>) section noteByNumber notes }
 175                         Tree PlainNote{number=Just state_note, note=note'}
 176                          <$> traverse check ts -- NOTE: normally ts is empty anyway
 177                  PlainRref{..} -> do
 178                         -- NOTE: Insert new anchor for this reference ref.
 179                         let anchs = Map.findWithDefault [] to state_rrefs
 180                         let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c
 181                         let anch = Anchor{count, section=state_section}
 182                         S.modify' $ \s -> s
 183                          { state_rrefs = Map.insert to (anch:anchs) state_rrefs }
 184                         Tree PlainRref{anchor=Just anch, to}
 185                          <$> traverse check ts
 186                  _ -> Tree n <$> traverse check ts
 187 instance Check Title where
 188         check (Title p) = Title <$> check p
 189 instance Check Reference where
 190         check = return
 191 instance Check Judgment where
 192         check Judgment{..} =
 193                 Judgment opinionsByChoice judges grades importance
 194                  <$> check question
 195                  <*> traverse check choices
 196 instance Check Choice where
 197         check Choice{..} =
 198                 Choice
 199                  <$> check title
 200                  <*> traverse check opinions
 201 instance Check Opinion where
 202         check Opinion{..} =
 203                 Opinion judge grade importance
 204                  <$> check comment
 205 instance Check Grade where
 206         check Grade{..} =
 207                 Grade pos name color isDefault
 208                  <$> check title
 209 instance Check Judge where
 210         check Judge{..} =
 211                 Judge name
 212                  <$> check title
 213                  <*> pure defaultGrades