{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
module Hdoc.DTC.Collect where
import Control.Applicative (Applicative(..))
import Control.Monad
import Data.Bool
import Data.Default.Class (Default(..))
import Data.Either (Either(..))
import Data.Foldable (Foldable(..), any)
import Data.Function (($))
import Data.Functor ((<$>), (<$))
import Data.Map.Strict (Map)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Monoid (Monoid(..))
import Data.Sequence (Seq)
import Data.Semigroup (Semigroup(..))
import Data.TreeSeq.Strict (Tree(..))
import Text.Show (Show(..))
import qualified Data.HashMap.Strict as HM
import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq
import qualified Data.Text.Lazy as TL
import qualified Data.TreeSeq.Strict as TS
import qualified Hjugement as MJ
import qualified Data.Tree as Tree

-- import Hdoc.Utils ()
import Hdoc.DTC.Document as DTC
import qualified Hdoc.XML as XML

-- * Type 'All'
-- | Collect 'Block's by mapping them by their 'XmlPos' or 'Ident'.
data All = All
 { all_index     :: Map XML.Pos Terms
 , all_figure    :: Map TL.Text (Map XML.Pos (Maybe Title))
 , all_reference :: HM.HashMap Ident (Seq Reference)
 , all_section   :: HM.HashMap Title (Seq (Either Head Section))
 , all_judges    :: HM.HashMap Ident Judges
 , all_grades    :: HM.HashMap Ident [Grade]
 , all_judgments :: HM.HashMap Judgment [Tree.Tree (Maybe MJ.Share, [Choice])]
 } deriving (Show)
instance Default All where
	def = All
	 { all_index     = def
	 , all_figure    = def
	 , all_section   = def
	 , all_reference = def
	 , all_judges    = def
	 , all_grades    = def
	 , all_judgments = def
	 }
instance Semigroup All where
	x<>y = All
	 { all_index     = Map.union (all_index x) (all_index y)
	 , all_figure    = Map.unionWith (<>) (all_figure x) (all_figure y)
	 , all_section   = HM.unionWith (<>) (all_section x) (all_section y)
	 , all_reference = HM.unionWith (<>) (all_reference x) (all_reference y)
	 , all_judges    = HM.union (all_judges x) (all_judges y)
	 , all_grades    = HM.union (all_grades x) (all_grades y)
	 , all_judgments = HM.unionWith (<>) (all_judgments x) (all_judgments y)
	 }
instance Monoid All where
	mempty  = def
	mappend = (<>)

-- * Class 'Collect'
class Collect a where
	collect :: a -> All
instance Collect Document where
	collect Document{head=head@Head{about=About{titles}, judgments=js}, body} =
		def{ all_section = HM.fromListWith (<>) $ (\t -> (t, pure $ Left head)) <$> titles } <>
		(foldMap collect body)
		 { all_judgments =
			choicesBySectionByJudgment HM.empty $
			TS.Tree (choicesByJudgment js) $
			choicesByJudgmentBySection body
		 }
instance Collect (Tree BodyNode) where
	collect (Tree n ts) =
		case n of
		 BodyBlock b -> collect b
		 BodySection s@Section{..} ->
			def{ all_section = HM.fromListWith (<>) $
				(\(Alias t) -> (t, pure $ Right s))
				 <$> (Alias section_title : section_aliases)
			 } <>
			foldMap collect ts
instance Collect DTC.Block where
	collect = \case
	 BlockPara _p    -> def -- collect p
	 BlockBreak{}    -> def
	 BlockToC{}      -> def
	 BlockToF{}      -> def
	 BlockAside{..}  -> foldMap collect blocks
	 BlockIndex{..}  -> def{all_index = Map.singleton posXML terms}
	 BlockFigure{..} ->
		def{all_figure=
			Map.singleton type_ (Map.singleton posXML mayTitle)}
		-- <> foldMap collect paras
	 BlockReferences{..} ->
		def{all_reference=
			HM.fromListWith (<>) $ (<$> refs) $ \ref@DTC.Reference{..} -> (reference_id, pure ref)
		 }
	 BlockGrades{attrs=CommonAttrs{id=i}, ..} ->
		def{all_grades = HM.singleton (fromMaybe "" i) scale}
	 BlockJudges judges@Judges{judges_attrs=CommonAttrs{id=i}, ..} ->
		def{all_judges = HM.singleton (fromMaybe "" i) judges}
{-
instance Collect Judgment where
	collect Judgment{..} = def
		def{all_judgments =
			HM.singleton
			 (judges,grades,question)
			 (Tree.Node choices [])
		 }
		-- <> foldMap collect choices
instance Collect Para where
	collect = \case
	 ParaItem item -> collect item
	 ParaItems{..} -> foldMap collect items
instance Collect ParaItem where
	collect = \case
	 ParaPlain{}    -> def
	 ParaArtwork{}  -> def
	 ParaQuote{..}  -> foldMap collect paras
	 ParaComment{}  -> def
	 ParaOL items   -> foldMap collect items
	 ParaUL items   -> foldMap (foldMap collect) items
	 ParaJudgment{} -> def
instance Collect ListItem where
	collect ListItem{..} = foldMap collect paras
instance Collect Choice where
	collect Choice{..} =
		foldMap collect title <>
		foldMap collect opinions
instance Collect Opinion where
	collect Opinion{..} =
		foldMap collect comment
instance Collect Title where
	collect (Title t) = collect t
instance Collect Plain where
	collect = foldMap collect
instance Collect (Tree PlainNode) where
	collect (Tree n ts) =
		case n of
		 PlainBreak    -> def
		 PlainText{}   -> def
		 PlainGroup    -> collect ts
		 PlainB        -> collect ts
		 PlainCode     -> collect ts
		 PlainDel      -> collect ts
		 PlainI        -> collect ts
		 PlainSpan{}   -> collect ts
		 PlainSub      -> collect ts
		 PlainSup      -> collect ts
		 PlainSC       -> collect ts
		 PlainU        -> collect ts
		 PlainNote{..} -> foldMap collect note
		 PlainQ        -> collect ts
		 PlainEref{}   -> collect ts
		 PlainIref{}   -> collect ts
		 PlainTag{}    -> collect ts
		 PlainRref{..} -> collect ts
-}

choicesByJudgment :: [Judgment] -> HM.HashMap Judgment (Maybe MJ.Share, [Choice])
choicesByJudgment js =
	HM.fromList $ (<$> js) $ \j@Judgment{..} ->
		(j,(judgment_importance, judgment_choices))

choicesByJudgmentBySection :: Body -> TS.Trees (HM.HashMap Judgment (Maybe MJ.Share, [Choice]))
choicesByJudgmentBySection bod = bod >>= \(Tree b bs) ->
	case b of
	 BodyBlock{} -> mempty
	 BodySection Section{..} ->
		pure $
			let choicesJ = choicesByJudgment section_judgments in
			Tree choicesJ $
				-- NOTE: if the 'BodySection' has a child which
				-- is not a 'BodySection' itself, then add "phantom" 'Judgment's
				-- which will inherit from this 'BodySection'.
				-- This enables judges to express something on material not in a sub 'BodySection'.
				let childrenBlocksJudgments =
					if (`any`bs) $ \case
						 Tree BodyBlock{} _ -> True
						 _ -> False
					then Seq.singleton $ Tree ((Nothing,[]) <$ choicesJ) Seq.empty
					else Seq.empty in
				childrenBlocksJudgments <>
				choicesByJudgmentBySection bs

choicesBySectionByJudgment ::
 HM.HashMap Judgment [Tree.Tree (Maybe MJ.Share, [Choice])] ->
 TS.Tree (HM.HashMap Judgment (Maybe MJ.Share, [Choice])) ->
 HM.HashMap Judgment [Tree.Tree (Maybe MJ.Share, [Choice])]
choicesBySectionByJudgment inh (TS.Tree selfJ childrenJS) =
	HM.unionWith
	 (\selfS childrenS ->
		(<$> selfS) $ \(Tree.Node choices old) ->
			Tree.Node choices (old<>childrenS))
	 (selfSJ <> inh)
	 childrenSJ
	where
	selfSJ = (\cs -> [Tree.Node cs []]) <$> selfJ
	childrenSJ =
		foldl'
		 (\accJ childJ ->
			HM.unionWith (<>) accJ $
			choicesBySectionByJudgment
			 (([Tree.Node (Nothing,[]) []] <$ selfJ) <> inh)
			 childJ
		 )
		 HM.empty
		 childrenJS