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

import Control.Applicative (Applicative(..))
import Control.Category
import Control.Monad (Monad(..))
import Data.Bool
import Data.Char (Char)
import Data.Default.Class (Default(..))
import Data.Eq (Eq)
import Data.Foldable (Foldable(..), concat)
import Data.Function (($), const)
import Data.Functor ((<$>))
import Data.Map.Strict (Map)
import Data.IntMap.Strict (IntMap)
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence ((|>))
import Data.Traversable (Traversable(..))
import Data.TreeMap.Strict (TreeMap(..))
import Data.TreeSeq.Strict (Tree(..), tree0)
import Text.Show (Show)
import qualified Control.Monad.Trans.State as S
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.IntMap.Strict as IntMap
import qualified Data.Sequence as Seq
import qualified Data.Strict.Maybe as Strict
import qualified Data.Text.Lazy as TL
import qualified Data.TreeMap.Strict as TreeMap
-- import qualified Data.TreeSeq.Strict as TreeSeq
import qualified Hjugement as MJ

import Hdoc.DTC.Document
import Hdoc.DTC.Index

-- * Type 'Rrefs'
type Rrefs = Map Ident [Anchor]

-- * Type 'NotesBySection'
type NotesBySection = Map PosPath Notes

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

-- * Type 'State'
data State = State
 { state_section :: Pos -- RO
 , state_irefs   :: Irefs
 , state_rrefs   :: Rrefs
 , state_notes   :: NotesBySection
 , state_note    :: Nat1
 , state_errors  :: [Error]
 }
instance Default State where
	def = State
	 { state_section = def
	 , state_irefs   = TreeMap.empty
	 , state_rrefs   = def
	 , state_notes   = def
	 , state_note    = def
	 , state_errors  = def
	 }

-- * Type 'Error'
data Error
 = Error_Judgment (MJ.ErrorSection Choice Judge Grade)
 | Error_Rref_missing
 deriving (Eq,Show)

-- * 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{..} -> do
			before@State{state_section} <- S.get
			S.put before{state_section = pos}
			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{..} ->
		BodySection pos attrs
		 <$> check title
		 <*> pure aliases
		 <*> traverse check judgments
	 BodyBlock b -> BodyBlock <$> check b
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 pos attrs
		 <$> traverse check blocks
	 BlockFigure{..} ->
		BlockFigure pos type_ attrs
		 <$> check mayTitle
		 <*> traverse check paras
	 BlockReferences{..} ->
		BlockReferences pos attrs
		 <$> traverse check refs
	 BlockJudges{..} ->
		BlockJudges pos attrs
		 <$> traverse check jury
	 BlockGrades{..} ->
		BlockGrades pos attrs
		 <$> traverse check scale
instance Check Para where
	check = \case
	 ParaItem{..}  -> ParaItem <$> check item
	 ParaItems{..} -> ParaItems pos 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
		State{..} <- 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=state_section}
			S.modify' $ \s -> s
			 { 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 state_section state_irefs (wordify txt)
			S.modify' $ \s -> s
			 { state_irefs = irefs }
			return $ Tree PlainGroup para
		 PlainNote{..} -> do
			-- NOTE: Insert new note for this section.
			let section = pos_Ancestors state_section
			S.modify' $ \s -> s
			 { 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
			-- NOTE: Insert new anchor for this reference ref.
			let anchs = Map.findWithDefault [] to state_rrefs
			let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c
			let anch = Anchor{count, section=state_section}
			S.modify' $ \s -> s
			 { state_rrefs = Map.insert to (anch:anchs) state_rrefs }
			Tree PlainRref{anchor=Just anch, to}
			 <$> traverse check ts
		 _ -> Tree n <$> traverse check ts
instance Check Title where
	check (Title p) = Title <$> check p
instance Check Reference where
	check = return
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 pos name color isDefault
		 <$> check title
instance Check Judge where
	check Judge{..} =
		Judge name
		 <$> check title
		 <*> pure defaultGrades