{-# LANGUAGE DuplicateRecordFields #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hdoc.DTC.Check
 ( {-module Hdoc.DTC.Check
 ,-} module Hdoc.DTC.Check.Base
 -- , module Hdoc.DTC.Check.Judgment
 ) where

import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..))
import Data.Bool
import Data.Default.Class (Default(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), (.), const, flip)
import Data.Functor ((<$>))
import Data.Maybe (Maybe(..), maybe, listToMaybe)
import Data.Semigroup (Semigroup(..))
import Data.Traversable (Traversable(..))
import Data.TreeSeq.Strict (Tree(..), tree0)
import Data.Tuple (snd)
import Prelude (undefined)
import qualified Control.Monad.Trans.State as S
import qualified Data.HashMap.Strict as HM
import qualified Data.IntMap.Strict as IntMap
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq
import qualified Data.Strict.Maybe as Strict
import qualified Data.TreeMap.Strict as TreeMap

import Hdoc.DTC.Document
import Hdoc.DTC.Index
import Hdoc.DTC.Collect
import Hdoc.DTC.Check.Base
import Hdoc.DTC.Check.Judgment ()
import qualified Hdoc.XML as XML

instance Check Body where
	check = traverse check
instance Check (Tree BodyNode) where
	check = \case
	 Tree n ts ->
		case n of
		 BodySection section@Section{..} -> do
			before@State{state_section} <- S.get
			S.put before{state_section = Just section}
			t <- Tree <$> check n <*> check ts
			S.modify' $ \s -> s{state_section}
			return t
		 BodyBlock{} -> tree0 <$> check n
instance Check BodyNode where
	check = \case
	 BodySection s -> BodySection <$> check s
	 BodyBlock   b -> BodyBlock   <$> check b
instance Check Section where
	check Section{..} =
		Section section_posXML section_attrs
		 <$> check section_title
		 <*> pure section_aliases
		 <*> traverse check section_judgments
instance Check Block where
	check = \case
	 BlockPara p    -> BlockPara <$> check p
	 b@BlockBreak{} -> return b
	 b@BlockToC{}   -> return b
	 b@BlockToF{}   -> return b
	 b@BlockIndex{} -> return b
	 BlockAside{..} ->
		BlockAside posXML attrs
		 <$> traverse check blocks
	 BlockFigure{..} ->
		BlockFigure posXML type_ attrs
		 <$> check mayTitle
		 <*> traverse check paras
	 BlockReferences{..} ->
		BlockReferences posXML attrs
		 <$> traverse check refs
	 BlockJudges js -> BlockJudges <$> check js
	 BlockGrades{..} ->
		BlockGrades posXML attrs
		 <$> check scale
instance Check Para where
	check = \case
	 ParaItem{..}  -> ParaItem <$> check item
	 ParaItems{..} -> ParaItems posXML attrs <$> traverse check items
instance Check ParaItem where
	check = \case
	 ParaPlain plain -> ParaPlain       <$> check plain
	 ParaOL items    -> ParaOL          <$> traverse check items
	 ParaUL items    -> ParaUL          <$> traverse (traverse check) items
	 ParaQuote{..}   -> ParaQuote type_ <$> traverse check paras
	 p@ParaArtwork{} -> return p
	 p@ParaComment{} -> return p
	 ParaJudgment j  -> ParaJudgment <$> check j
instance Check ListItem where
	check ListItem{..} = ListItem name <$> traverse check paras
instance Check Plain where
	check = traverse check
instance Check (Tree PlainNode) where
	check (Tree n ts) = do
		st@State{state_collect=All{..}, ..} <- S.get
		case n of
		 PlainIref{..}
		  | not $ null state_irefs
		  , Just words <- pathFromWords iref_term
		  , Strict.Just anchors <- TreeMap.lookup words state_irefs -> do
			-- NOTE: Insert new anchor for this index ref.
			let anchor = Anchor
				 { anchor_count   = maybe def (succNat1 . anchor_count) $ listToMaybe anchors
				 , anchor_section = maybe def section_posXML state_section
				 }
			S.put st
			 { state_irefs = TreeMap.insert const words (anchor:anchors) state_irefs }
			Tree PlainIref
			 { iref_term
			 , iref_anchor = Just anchor }
			 <$> traverse check ts
		 PlainText txt
		  | not $ null state_irefs -> do
			-- NOTE: Find indexed words in this text.
			let (irefs,para) = indexifyWords (maybe def section_posXML state_section) state_irefs (wordify txt)
			S.put st
			 { state_irefs = irefs }
			return $ Tree PlainGroup para
		 PlainNote{..} -> do
			-- NOTE: Insert new note for this section.
			let section = XML.pos_ancestors $ maybe def section_posXML state_section
			S.put st
			 { state_note = succNat1 state_note }
			paras <- traverse check note_paras
			let noteByNumber = IntMap.singleton (unNat1 state_note) note_paras
			State{state_notes=notes} <- S.get
			S.modify' $ \s -> s
			 { state_notes = Map.insertWith (<>) section noteByNumber notes }
			Tree PlainNote
			 { note_number = Just state_note
			 , note_paras  = paras }
			 <$> traverse check ts -- NOTE: normally ts is empty anyway
		 PlainRref{..} -> do
			let targets = HM.lookupDefault Seq.empty rref_to all_reference
			case toList targets of
			 [] -> do
				let err =
					HM.insertWith (flip (<>)) rref_to (pure rref_locTCT) $
					errors_rref_unknown state_errors
				S.put st
				 { state_errors = state_errors
					 { errors_rref_unknown = err }
				 }
				Tree PlainRref
				 { rref_error = Just $ ErrorTarget_Unknown $ Nat1 $ length $ err HM.!rref_to
				 , .. }
				 <$> traverse check ts
			 [_] -> do
				let rrefs = HM.insertWith
					 (const $ \old ->
						let (_sec,num) = List.head old in
						(state_section, succNat1 num) : old)
					 rref_to [(state_section, Nat1 1)]
					 state_rrefs
				S.put st
				 { state_rrefs = rrefs }
				Tree PlainRref
				 { rref_error  = Nothing
				 , rref_number = Just $ snd $ List.head $ rrefs HM.!rref_to
				 , .. }
				 <$> traverse check ts
			 _ ->
				-- NOTE: ambiguity is checked when checking 'Reference'.
				Tree PlainRref
				 { rref_error = Just $ ErrorTarget_Ambiguous Nothing
				 , rref_number = Nothing
				 , .. }
				 <$> traverse check ts
		 PlainTag{..} -> do
			let tag_to = Title ts
			let targets = HM.lookupDefault Seq.empty tag_to all_section
			case toList targets of
			 [] -> do
				let err =
					HM.insertWith (flip (<>)) tag_to (pure tag_locTCT) $
					errors_tag_unknown state_errors
				S.put st
				 { state_errors = state_errors
					 { errors_tag_unknown = err }
				 }
				Tree PlainTag
				 { tag_error = Just $ ErrorTarget_Unknown $ Nat1 $ length $ err HM.!tag_to
				 , .. }
				 <$> traverse check ts
			 [_] ->
				Tree PlainTag{tag_error = Nothing, ..}
				 <$> traverse check ts
			 _ -> do
				let err =
					HM.insertWith (flip (<>)) tag_to (pure tag_locTCT) $
					errors_tag_ambiguous state_errors
				S.put st
				 { state_errors = state_errors
					 { errors_tag_ambiguous = err }
				 }
				Tree PlainTag
				 { tag_error = Just $ ErrorTarget_Ambiguous $ Just $ Nat1 $ length $ err HM.!tag_to
				 , .. }
				 <$> traverse check ts
		 _ -> Tree n <$> traverse check ts
instance Check Title where
	check (Title p) = Title <$> check p
instance Check About where
	check About{..} =
		About headers
		 <$> traverse check titles
		 <*> pure url
		 <*> traverse check authors
		 <*> traverse check editor
		 <*> traverse check date
		 <*> pure tags
		 <*> pure links
		 <*> pure series
		 <*> traverse check includes
instance Check Entity where
	check = return -- TODO: to be coded
instance Check Date where
	check = return -- TODO: to be coded
instance Check Include where
	check = return -- TODO: to be coded
instance Check Reference where
	check Reference{..} = do
		st@State{state_collect=All{..}, ..} <- S.get
		let targets = HM.lookupDefault Seq.empty reference_id all_reference
		case toList targets of
		 [] -> undefined
		 [_] -> do
			about <- check reference_about
			return $ Reference
			 { reference_error = Nothing
			 , reference_about = about
			 , .. }
		 _ -> do
			let err =
				HM.insertWith (flip (<>)) reference_id (pure reference_locTCT) $
				errors_reference_ambiguous state_errors
			S.put st
			 { state_errors = state_errors
				 { errors_reference_ambiguous = err }
			 }
			about <- check reference_about
			return $ Reference
			 { reference_error = Just $ ErrorAnchor_Ambiguous $ Nat1 $ length $ err HM.!reference_id
			 , reference_about = about
			 , .. }