1 {-# LANGUAGE DuplicateRecordFields #-}
2 {-# OPTIONS_GHC -fno-warn-orphans #-}
4 ( {-module Hdoc.DTC.Check
5 ,-} module Hdoc.DTC.Check.Base
6 -- , module Hdoc.DTC.Check.Judgment
9 import Control.Applicative (Applicative(..))
10 import Control.Monad (Monad(..))
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
31 import Hdoc.DTC.Document
33 import Hdoc.DTC.Collect
34 import Hdoc.DTC.Check.Base
35 import Hdoc.DTC.Check.Judgment ()
36 import qualified Hdoc.XML as XML
38 instance Check Body where
39 check = traverse check
40 instance Check (Tree BodyNode) where
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}
50 BodyBlock{} -> tree0 <$> check n
51 instance Check BodyNode where
53 BodySection s -> BodySection <$> check s
54 BodyBlock b -> BodyBlock <$> check b
55 instance Check Section where
57 Section section_posXML section_attrs
58 <$> check section_title
59 <*> pure section_aliases
60 <*> traverse check section_judgments
61 instance Check Block where
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
69 BlockAside posXML attrs
70 <$> traverse check blocks
72 BlockFigure posXML type_ attrs
74 <*> traverse check paras
75 BlockReferences{..} ->
76 BlockReferences posXML attrs
77 <$> traverse check refs
78 BlockJudges js -> BlockJudges <$> check js
80 BlockGrades posXML attrs
82 instance Check Para where
84 ParaItem{..} -> ParaItem <$> check item
85 ParaItems{..} -> ParaItems posXML attrs <$> traverse check items
86 instance Check ParaItem where
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
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.
109 { anchor_count = maybe def (succNat1 . anchor_count) $ listToMaybe anchors
110 , anchor_section = maybe def section_posXML state_section
113 { state_irefs = TreeMap.insert const words (anchor:anchors) state_irefs }
116 , iref_anchor = Just anchor }
117 <$> traverse check ts
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)
123 { state_irefs = irefs }
124 return $ Tree PlainGroup para
126 -- NOTE: Insert new note for this section.
127 let section = XML.pos_ancestors $ maybe def section_posXML state_section
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
134 { state_notes = Map.insertWith (<>) section noteByNumber notes }
136 { note_number = Just state_note
137 , note_paras = paras }
138 <$> traverse check ts -- NOTE: normally ts is empty anyway
140 let targets = HM.lookupDefault Seq.empty rref_to all_reference
141 case toList targets of
144 HM.insertWith (flip (<>)) rref_to (pure rref_locTCT) $
145 errors_rref_unknown state_errors
147 { state_errors = state_errors
148 { errors_rref_unknown = err }
151 { rref_error = Just $ ErrorTarget_Unknown $ Nat1 $ length $ err HM.!rref_to
153 <$> traverse check ts
155 let rrefs = HM.insertWith
157 let (_sec,num) = List.head old in
158 (state_section, succNat1 num) : old)
159 rref_to [(state_section, Nat1 1)]
162 { state_rrefs = rrefs }
164 { rref_error = Nothing
165 , rref_number = Just $ snd $ List.head $ rrefs HM.!rref_to
167 <$> traverse check ts
169 -- NOTE: ambiguity is checked when checking 'Reference'.
171 { rref_error = Just $ ErrorTarget_Ambiguous Nothing
172 , rref_number = Nothing
174 <$> traverse check ts
176 let tag_to = Title ts
177 let targets = HM.lookupDefault Seq.empty tag_to all_section
178 case toList targets of
181 HM.insertWith (flip (<>)) tag_to (pure tag_locTCT) $
182 errors_tag_unknown state_errors
184 { state_errors = state_errors
185 { errors_tag_unknown = err }
188 { tag_error = Just $ ErrorTarget_Unknown $ Nat1 $ length $ err HM.!tag_to
190 <$> traverse check ts
192 Tree PlainTag{tag_error = Nothing, ..}
193 <$> traverse check ts
196 HM.insertWith (flip (<>)) tag_to (pure tag_locTCT) $
197 errors_tag_ambiguous state_errors
199 { state_errors = state_errors
200 { errors_tag_ambiguous = err }
203 { tag_error = Just $ ErrorTarget_Ambiguous $ Just $ Nat1 $ length $ err HM.!tag_to
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
212 <$> traverse check titles
214 <*> traverse check authors
215 <*> traverse check editor
216 <*> traverse check date
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
234 about <- check reference_about
236 { reference_error = Nothing
237 , reference_about = about
241 HM.insertWith (flip (<>)) reference_id (pure reference_locTCT) $
242 errors_reference_ambiguous state_errors
244 { state_errors = state_errors
245 { errors_reference_ambiguous = err }
247 about <- check reference_about
249 { reference_error = Just $ ErrorAnchor_Ambiguous $ Nat1 $ length $ err HM.!reference_id
250 , reference_about = about