{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hdoc.DTC.Anchor 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.Foldable (Foldable(..), concat)
import Data.Function (($), const)
import Data.Functor ((<$>))
import Data.Map.Strict (Map)
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 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.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 Hdoc.DTC.Document

-- * Type 'PathWord'
type PathWord = TreeMap.Path Word

pathFromWords :: Words -> Maybe PathWord
pathFromWords ws =
	case ws >>= unSpace of
	 p:ps | not (TL.null p) -> Just (TreeMap.path p ps)
	 _ -> Nothing
	where
	unSpace = \case
	 Space  -> []
	 Word w -> [w]

-- * Type 'Irefs'
type Irefs = TreeMap Word [Anchor]

irefsOfTerms :: Terms -> Irefs
irefsOfTerms = TreeMap.fromList const . (>>= f) . concat
	where
	f [] = []
	f ws = maybe [] (\p -> [(p,[])]) $ pathFromWords ws

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

-- * Type 'Notes'
type Notes = Map PosPath [Note]
data Note
 =   Note
 {   note_number  :: Nat1
 ,   note_content :: [Para]
 } -- deriving (Eq,Show)

-- * Type 'State'
data State
 =   State
 {   state_section :: Pos
 ,   state_irefs   :: Irefs
 ,   state_rrefs   :: Rrefs
 ,   state_notes   :: Notes
 ,   state_note    :: Nat1
 }
instance Default State where
	def = State
	 { state_section = def
	 , state_irefs   = mempty
	 , state_rrefs   = def
	 , state_notes   = def
	 , state_note    = def
	 }

-- * Class 'Anchorify'
class Anchorify a where
	anchorify :: a -> S.State State a
instance Anchorify a => Anchorify (Maybe a) where
	anchorify = traverse anchorify
instance Anchorify Body where
	anchorify = traverse anchorify
instance Anchorify (Tree BodyNode) where
	anchorify = \case
	 Tree n ts ->
		case n of
		 BodySection{..} -> do
			before@State{state_section} <- S.get
			S.put before{state_section = pos}
			t <- Tree <$> anchorify n <*> anchorify ts
			after <- S.get
			S.put after{state_section}
			return t
		 BodyBlock{} -> tree0 <$> anchorify n
instance Anchorify BodyNode where
	anchorify = \case
	 BodySection{..} ->
		BodySection pos attrs
		 <$> anchorify title
		 <*> pure aliases
		 <*> traverse anchorify judgments
	 BodyBlock b -> BodyBlock <$> anchorify b
instance Anchorify Block where
	anchorify = \case
	 BlockPara p     -> BlockPara <$> anchorify p
	 b@BlockBreak{}  -> return b
	 b@BlockToC{}    -> return b
	 b@BlockToF{}    -> return b
	 b@BlockIndex{}  -> return b
	 BlockAside{..} ->
		BlockAside pos attrs
		 <$> traverse anchorify blocks
	 BlockFigure{..} ->
		BlockFigure pos type_ attrs
		 <$> anchorify mayTitle
		 <*> traverse anchorify paras
	 BlockReferences{..} ->
		BlockReferences pos attrs
		 <$> traverse anchorify refs
	 BlockJudges{..} ->
		BlockJudges pos attrs
		 <$> traverse anchorify jury
	 BlockGrades{..} ->
		BlockGrades pos attrs
		 <$> traverse anchorify scale
instance Anchorify Para where
	anchorify = \case
	 ParaItem{..}  -> ParaItem <$> anchorify item
	 ParaItems{..} -> ParaItems pos attrs <$> traverse anchorify items
instance Anchorify ParaItem where
	anchorify = \case
	 ParaPlain plain -> ParaPlain       <$> anchorify plain
	 ParaOL items    -> ParaOL          <$> traverse anchorify items
	 ParaUL items    -> ParaUL          <$> traverse (traverse anchorify) items
	 ParaQuote{..}   -> ParaQuote type_ <$> traverse anchorify paras
	 p@ParaArtwork{} -> return p
	 p@ParaComment{} -> return p
	 ParaJudgment j  -> ParaJudgment <$> anchorify j
instance Anchorify ListItem where
	anchorify ListItem{..} = ListItem name <$> traverse anchorify paras
instance Anchorify Judgment where
	anchorify Judgment{..} =
		Judgment judges grades importance
		 <$> anchorify question
		 <*> traverse anchorify choices
instance Anchorify Plain where
	anchorify p = do
		State{..} <- S.get
		indexed <-
			if null state_irefs
			then return p
			else traverse anchorify p
		traverse (traverse collect) indexed
		where
		-- TODO: maybe move to Anchorify (Tree PlainNode)
		collect :: PlainNode -> S.State State PlainNode
		collect = \case
		 PlainNote{..} -> do
			State{..} <- S.get
			let notes = Map.findWithDefault [] (pos_Ancestors state_section) state_notes
			S.modify $ \s -> s
			 { state_notes = Map.insert (pos_Ancestors state_section) (Note state_note note:notes) state_notes
			 , state_note  = succNat1 state_note }
			return PlainNote{number=Just state_note, note}
		 PlainRref{..} -> do
			State{..} <- S.get
			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}
			return PlainRref{anchor=Just anch, to}
		 n -> return n
instance Anchorify (Tree PlainNode) where
	anchorify (Tree n ts) =
		case n of
		 PlainIref{term} | Just words <- pathFromWords term -> do
			State{state_irefs, state_section} <- S.get
			case TreeMap.lookup words state_irefs of
			 Strict.Nothing ->
				Tree n <$> traverse anchorify ts
			 Strict.Just anchs -> do
				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 anchorify ts
		 PlainText txt -> do
			State{..} <- S.get
			let (irefs,para) = indexifyWords state_section state_irefs (wordify txt)
			S.modify $ \s -> s{state_irefs=irefs}
			return $ Tree PlainGroup para
		 _ -> Tree n <$> traverse anchorify ts
instance Anchorify Title where
	anchorify (Title p) = Title <$> anchorify p
instance Anchorify Reference where
	anchorify = return
instance Anchorify Choice where
	anchorify Choice{..} =
		Choice
		 <$> anchorify title
		 <*> traverse anchorify opinions
instance Anchorify Opinion where
	anchorify Opinion{..} =
		Opinion judge grade importance
		 <$> anchorify comment
instance Anchorify Grade where
	anchorify Grade{..} =
		Grade pos name color isDefault
		 <$> anchorify title
instance Anchorify Judge where
	anchorify Judge{..} =
		Judge name
		 <$> anchorify title
		 <*> pure defaultGrades

indexifyWords :: Pos -> Irefs -> Words -> (Irefs, Plain)
indexifyWords section = go mempty
	where
	go :: Plain -> Irefs -> Words -> (Irefs, Plain)
	go acc irefs inp =
		case inp of
		 [] -> (irefs, acc)
		 Space : next ->
			go (acc |> tree0 (PlainText " ")) irefs next
		 Word w : next ->
			case goWords irefs [] inp of
			 Nothing -> go (acc |> tree0 (PlainText w)) irefs next
			 Just (anch, ls, ns, rs) ->
				let term = List.reverse ls in
				let lines = Seq.fromList $ tree0 . PlainText . plainifyWord <$> term in
				go (acc |> Tree PlainIref{term, anchor=Just anch} lines) rs ns
	goWords ::
	 Irefs ->
	 Words -> Words ->
	 Maybe (Anchor, Words, Words, Irefs)
	goWords m@(TreeMap irefsByWord) prev inp =
		case inp of
		 [] -> Nothing
		 curr@Space : next -> goWords m (curr:prev) next
		 curr@(Word w) : next ->
			case Map.lookup w irefsByWord of
			 Nothing -> Nothing
			 Just nod@TreeMap.Node{..} ->
				let prev' = curr:prev in
				case node_value of
				 Strict.Nothing
				  | null node_descendants -> Nothing
				  | otherwise ->
					(<$> goWords node_descendants prev' next) $ \(anch, ls, ns, rs) ->
						(anch, ls, ns, TreeMap $
							Map.insert w nod{TreeMap.node_descendants = rs} irefsByWord)
				 Strict.Just anchs ->
					case goWords node_descendants prev' next of
					 Nothing ->
						let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c in
						let anch  = Anchor{count, section} in
						Just (anch, prev', next, TreeMap $
							Map.insert w nod{TreeMap.node_value = Strict.Just $ anch:anchs} irefsByWord)
					 Just (anch, ls, ns, rs) ->
						Just (anch, ls, ns, TreeMap $
							Map.insert w nod{TreeMap.node_descendants = rs} irefsByWord)

wordify :: TL.Text -> Words
wordify = List.reverse . go []
	where
	go :: Words -> TL.Text -> Words
	go acc t =
		case TL.span Char.isAlphaNum t of
		 ("",_) ->
			case TL.span Char.isSpace t of
			 ("",_) ->
				case TL.uncons t of
				 Nothing -> acc
				 Just (c,r) -> go (Word (TL.singleton c) : acc) r
			 (_s,r) -> go (Space : acc) r
		 (w,r) -> go (Word w : acc) r

plainifyWord :: WordOrSpace -> TL.Text
plainifyWord = \case
 Word w -> w
 Space  -> " "

plainifyWords :: Words -> TL.Text
plainifyWords = TL.concat . (plainifyWord <$>)

termsByChar :: Terms -> Map Char Terms
termsByChar =
	foldr (\aliases acc ->
		case aliases of
		 (Word w:_):_ | not (TL.null w) ->
			Map.insertWith (<>)
			 (Char.toUpper $ TL.index w 0)
			 [aliases] acc
		 _ -> acc
		) Map.empty