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

import Control.Applicative (Applicative(..))
import Control.Category
import Control.Monad (Monad(..), mapM, join)
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.Text (Text)
import Data.Traversable (Traversable(..))
import Data.TreeMap.Strict (TreeMap(..))
import Data.TreeSeq.Strict (Tree(..))
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 as Text
import qualified Data.TreeMap.Strict as TreeMap
-- import qualified Data.TreeSeq.Strict as Tree

import Language.DTC.Document

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

pathFromWords :: Words -> Maybe PathWord
pathFromWords ws =
	case ws >>= unSpace of
	 p:ps | not (Text.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 'State'
data State
 =   State
 {   state_irefs   :: Irefs
 ,   state_rrefs   :: Rrefs
 ,   state_section :: Pos
 }
state :: State
state = State
 { state_irefs   = mempty
 , state_rrefs   = mempty
 , state_section = def
 }

-- * Class 'Anchorify'
class Anchorify a where
	anchorify :: a -> S.State State a
instance Anchorify (Tree k a) => Anchorify [Tree k a] where
	anchorify = mapM anchorify
instance Anchorify (Tree BodyKey BodyValue) where
	anchorify = \case
	 Tree0 v -> Tree0 <$> anchorify v
	 TreeN k v ->
		case k of
		 Section{..} -> do
			before@State{state_section} <- S.get
			S.put before{state_section = pos}
			t <- TreeN <$> anchorify k <*> anchorify v
			after <- S.get
			S.put after{state_section}
			return t
instance Anchorify Body where
	anchorify = mapM anchorify
instance Anchorify BodyKey where
	anchorify = \case
	 Section{..} ->
		Section pos attrs
		 <$> anchorify title
		 <*> pure aliases
instance Anchorify BodyValue where
	anchorify = \case
	 d@ToC{} -> pure d
	 d@ToF{} -> pure d
	 d@Index{} -> pure d
	 Figure{..} ->
		Figure pos attrs type_
		 <$> anchorify title
		 <*> anchorify blocks
	 References{..} ->
		References pos attrs
		 <$> anchorify refs
	 Block v ->
		Block <$> anchorify v
instance Anchorify [Reference] where
	anchorify = mapM anchorify
instance Anchorify [Block] where
	anchorify = mapM anchorify
instance Anchorify [[Block]] where
	anchorify = mapM (mapM anchorify)
instance Anchorify Title where
	anchorify (Title t) = Title <$> anchorify t
instance Anchorify Block where
	anchorify = \case
	 Para{..}    -> Para    pos attrs <$> anchorify para
	 OL{..}      -> OL      pos attrs <$> anchorify items
	 UL{..}      -> UL      pos attrs <$> anchorify items
	 Artwork{..} -> Artwork pos attrs <$> anchorify art
	 d@Comment{} -> pure d
instance Anchorify Para where
	anchorify ls = do
		State{..} <- S.get
		indexed <-
			if null state_irefs
			then return ls
			else join <$> traverse indexifyLines ls
		traverse referencifyLines indexed
instance Anchorify Reference where
	anchorify = return
instance Anchorify Artwork where
	anchorify = return

referencifyLines :: Lines -> S.State State Lines
referencifyLines t =
	case t of
	 Tree0{} -> return t
	 TreeN k ts -> do
		k' <-
			case k of
			 Rref{..} -> 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 Rref{anchor=Just anch, to}
			 _ -> return k
		TreeN k'
		 <$> traverse referencifyLines ts

indexifyLines :: Lines -> S.State State Para
indexifyLines = \case
 Tree0 a -> indexifyPlain a
 TreeN k@Iref{term} ts
  | Just words <- pathFromWords term -> do
	State{state_irefs, state_section} <- S.get
	case TreeMap.lookup words state_irefs of
	 Strict.Nothing ->
		Seq.singleton . TreeN k . join
		 <$> traverse indexifyLines 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}
		Seq.singleton . TreeN Iref{term, anchor=Just anch} . join
		 <$> traverse indexifyLines ts
 TreeN k ts ->
	Seq.singleton . TreeN k . join
	 <$> traverse indexifyLines ts

indexifyPlain :: LineValue -> S.State State Para
indexifyPlain = \case
 BR -> pure $ Seq.singleton $ Tree0 BR
 Plain p -> do
	State{..} <- S.get
	let (irefs,ts) = indexifyWords state_section state_irefs (wordify p)
	S.modify $ \s -> s{state_irefs=irefs}
	return ts

indexifyWords :: Pos -> Irefs -> Words -> (Irefs, Para)
indexifyWords section = go mempty
	where
	go :: Para -> Irefs -> Words -> (Irefs, Para)
	go acc irefs inp =
		case inp of
		 [] -> (irefs, acc)
		 Space : next ->
			go (acc |> Tree0 (Plain " ")) irefs next
		 Word w : next ->
			case goWords irefs [] inp of
			 Nothing -> go (acc |> Tree0 (Plain w)) irefs next
			 Just (anch, ls, ns, rs) ->
				let term = List.reverse ls in
				let lines = Seq.fromList $ Tree0 . Plain . plainifyWord <$> term in
				go (acc |> TreeN Iref{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 :: Text -> Words
wordify = List.reverse . go []
	where
	go :: Words -> Text -> Words
	go acc t =
		case Text.span Char.isAlphaNum t of
		 ("",_) ->
			case Text.span Char.isSpace t of
			 ("",_) ->
				case Text.uncons t of
				 Nothing -> acc
				 Just (c,r) -> go (Word (Text.singleton c) : acc) r
			 (_s,r) -> go (Space : acc) r
		 (w,r) -> go (Word w : acc) r

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

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

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