{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hdoc.DTC.Check where

-- import Control.Category
-- import Data.Char (Char)
-- import Data.Monoid (Monoid(..))
-- import Data.TreeMap.Strict (TreeMap(..))
-- import qualified Data.Char as Char
-- import qualified Data.Text.Lazy as TL
-- import qualified Data.TreeSeq.Strict as TreeSeq
-- import qualified Hjugement as MJ
import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..))
import Data.Bool
import Data.Default.Class (Default(..))
import Data.Eq (Eq)
import Data.Foldable (Foldable(..))
import Data.Function (($), const, flip)
import Data.Functor ((<$>))
import Data.IntMap.Strict (IntMap)
import Data.Map.Strict (Map)
import Data.Maybe (Maybe(..), maybe)
import Data.Semigroup (Semigroup(..))
import Data.Sequence (Seq)
import Data.Traversable (Traversable(..))
import Data.TreeSeq.Strict (Tree(..), tree0)
import Data.Tuple (snd)
import Text.Show (Show)
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 qualified Prelude (error)

import Hdoc.DTC.Document
import Hdoc.DTC.Index
import Hdoc.DTC.Collect
import qualified Hdoc.TCT.Cell as TCT
import qualified Hdoc.XML as XML

-- * Type 'State'
data State = State
 { state_section :: Maybe Section -- RO
 , state_irefs   :: Irefs
 , state_rrefs   :: HM.HashMap Ident [(Maybe Section, Nat1)]
 -- , state_refs    :: AnchorByIdent
 , state_notes   :: NotesBySection
 , state_note    :: Nat1
 , state_errors  :: Errors
 , state_collect :: All
 }
instance Default State where
	def = State
	 { state_section = def
	 , state_irefs   = TreeMap.empty
	 , state_rrefs   = def
	 -- , state_refs    = def
	 , state_notes   = def
	 , state_note    = def
	 , state_errors  = def
	 , state_collect = def
	 }

-- ** Type 'AnchorByIdent'
type AnchorByIdent = HM.HashMap Ident [Anchor]

-- ** Type 'Notes'
type Notes = IntMap [Para]

-- *** Type 'NotesBySection'
type NotesBySection = Map XML.Ancestors Notes

-- * Type 'Errors'
data Errors = Errors
 { errors_tag_unknown         :: HM.HashMap Title (Seq TCT.Location)
 , errors_tag_ambiguous       :: HM.HashMap Title (Seq TCT.Location)
 , errors_rref_unknown        :: HM.HashMap Ident (Seq TCT.Location)
 , errors_reference_ambiguous :: HM.HashMap Ident (Seq TCT.Location)
 } deriving (Eq,Show)
instance Default Errors where
	def = Errors
	 { errors_tag_unknown         = def
	 , errors_tag_ambiguous       = def
	 , errors_rref_unknown        = def
	 , errors_reference_ambiguous = def
	 }

-- * Class 'Check'
class Check a where
	check :: a -> S.State State a
instance Check a => Check (Maybe a) where
	check = traverse check
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 xmlPos attrs
		 <$> check title
		 <*> pure aliases
		 <*> traverse check 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 xmlPos attrs
		 <$> traverse check blocks
	 BlockFigure{..} ->
		BlockFigure xmlPos type_ attrs
		 <$> check mayTitle
		 <*> traverse check paras
	 BlockReferences{..} ->
		BlockReferences xmlPos attrs
		 <$> traverse check refs
	 BlockJudges{..} ->
		BlockJudges xmlPos attrs
		 <$> traverse check jury
	 BlockGrades{..} ->
		BlockGrades xmlPos attrs
		 <$> traverse check scale
instance Check Para where
	check = \case
	 ParaItem{..}  -> ParaItem <$> check item
	 ParaItems{..} -> ParaItems xmlPos 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{term}
		  | not $ null state_irefs
		  , Just words <- pathFromWords term
		  , Strict.Just anchs <- TreeMap.lookup words state_irefs -> do
			-- NOTE: Insert new anchor for this index ref.
			let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c
			let anch = Anchor{count, section=maybe def (xmlPos::Section -> XML.Pos) state_section}
			S.put st
			 { state_irefs = TreeMap.insert const words (anch:anchs) state_irefs }
			Tree PlainIref{term, anchor=Just anch}
			 <$> traverse check ts
		 PlainText txt
		  | not $ null state_irefs -> do
			-- NOTE: Find indexed words in this text.
			let (irefs,para) = indexifyWords (maybe def (xmlPos::Section -> XML.Pos) 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 (xmlPos::Section -> XML.Pos) state_section
			S.put st
			 { state_note = succNat1 state_note }
			note' <- traverse check note
			let noteByNumber = IntMap.singleton (unNat1 state_note) note'
			State{state_notes=notes} <- S.get
			S.modify' $ \s -> s
			 { state_notes = Map.insertWith (<>) section noteByNumber notes }
			Tree PlainNote{number=Just state_note, note=note'}
			 <$> traverse check ts -- NOTE: normally ts is empty anyway
		 PlainRref{..} -> do
			let targets = HM.lookupDefault Seq.empty to all_reference
			case toList targets of
			 [] -> do
				let err =
					HM.insertWith (flip (<>)) to (pure locTCT) $
					errors_rref_unknown state_errors
				S.put st
				 { state_errors = state_errors
					 { errors_rref_unknown = err }
				 }
				Tree PlainRref{error = Just $ ErrorTarget_Unknown $ Nat1 $ length $ err HM.!to, ..}
				 <$> traverse check ts
			 [_] -> do
				let rrefs = HM.insertWith
					 (const $ \old ->
						let (_sec,num) = List.head old in
						(state_section, succNat1 num) : old)
					 to [(state_section, Nat1 1)]
					 state_rrefs
				S.put st
				 { state_rrefs = rrefs }
				Tree PlainRref{error = Nothing, number = Just $ snd $ List.head $ rrefs HM.!to, ..}
				 <$> traverse check ts
			 _ ->
				-- NOTE: ambiguity is checked when checking 'Reference'.
				Tree PlainRref{error = Just $ ErrorTarget_Ambiguous Nothing, number = Nothing, ..}
				 <$> traverse check ts
		 PlainTag{locTCT} -> do
			let to = Title ts
			let targets = HM.lookupDefault Seq.empty to all_section
			case toList targets of
			 [] -> do
				let err =
					HM.insertWith (flip (<>)) to (pure locTCT) $
					errors_tag_unknown state_errors
				S.put st
				 { state_errors = state_errors
					 { errors_tag_unknown = err }
				 }
				Tree PlainTag{error = Just $ ErrorTarget_Unknown $ Nat1 $ length $ err HM.!to, ..}
				 <$> traverse check ts
			 [_] ->
				Tree PlainTag{error = Nothing, ..}
				 <$> traverse check ts
			 _ -> do
				let err =
					HM.insertWith (flip (<>)) to (pure locTCT) $
					errors_tag_ambiguous state_errors
				S.put st
				 { state_errors = state_errors
					 { errors_tag_ambiguous = err }
				 }
				Tree PlainTag{error = Just $ ErrorTarget_Ambiguous $ Just $ Nat1 $ length $ err HM.!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 id all_reference
		case toList targets of
		 [] -> Prelude.error "[BUG] check Reference"
		 [_] -> do
			about' <- check about
			return $ Reference{error=Nothing, about=about', ..}
		 _ -> do
			let err =
				HM.insertWith (flip (<>)) id (pure locTCT) $
				errors_reference_ambiguous state_errors
			S.put st
			 { state_errors = state_errors
				 { errors_reference_ambiguous = err }
			 }
			about' <- check about
			return $ Reference{error=Just $ ErrorAnchor_Ambiguous $ Nat1 $ length $ err HM.!id, about=about', ..}
instance Check Judgment where
	check Judgment{..} =
		Judgment opinionsByChoice judges grades importance
		 <$> check question
		 <*> traverse check choices
instance Check Choice where
	check Choice{..} =
		Choice
		 <$> check title
		 <*> traverse check opinions
instance Check Opinion where
	check Opinion{..} =
		Opinion judge grade importance
		 <$> check comment
instance Check Grade where
	check Grade{..} =
		Grade xmlPos name color isDefault
		 <$> check title
instance Check Judge where
	check Judge{..} =
		Judge name
		 <$> check title
		 <*> pure defaultGrades