{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.TCT.Write.XML where

import Control.Arrow (first)
import Control.Monad (Monad(..), (=<<))
import Data.Bool
import Data.Default.Class (Default(..))
import Data.Eq (Eq(..))
import Data.Foldable (null, foldl', any)
import Data.Function (($), (.), id)
import Data.Functor (Functor(..), (<$>))
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (Seq, ViewL(..), ViewR(..), (<|), (|>))
import Data.Set (Set)
import Data.Text (Text)
import Data.TreeSeq.Strict (Tree(..))
import GHC.Exts (toList)
import Prelude (undefined)
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Sequence as Seq
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
import qualified Control.Monad.Trans.State as S
import qualified Language.TCT.Write.Plain as Plain
import qualified System.FilePath as FP

import Text.Blaze.XML ()
import Language.TCT hiding (Parser)
import Language.XML
import qualified Data.TreeSeq.Strict as TreeSeq

import Debug.Trace (trace)
import Text.Show (show)

xmlDocument :: TCTs -> XMLs
xmlDocument trees =
	-- (`S.evalState` def) $
	case Seq.viewl trees of
	 TreeN (unCell -> KeySection{}) vs :< ts ->
		case spanlTokens vs of
		 (titles@(Seq.viewl -> (Seq.viewl -> (posTree -> bp) :< _) :< _), vs') ->
			let vs'' =
				case Seq.findIndexL
				 (\case
				 TreeN (unCell -> KeyColon "about" _) _ -> True
				 _ -> False) vs' of
				 Nothing -> TreeN (Cell bp bp $ KeyColon "about" "") mempty <| vs'
				 Just{} -> vs' in
			xmlify def
			 { inh_titles = titles
			 , inh_figure = True
			 , inh_tree0  = List.repeat xmlPara
			 } vs'' <>
			xmlify def ts
		 _ -> xmlify def trees
	 _ -> xmlify def trees

{-
-- * Type 'Xmls'
type Xmls = S.State State XMLs
type Xml  = S.State State XML
instance Semigroup Xmls where
	(<>) = liftA2 (<>)
instance Monoid Xmls where
	mempty  = return mempty
	mappend = (<>)

-- * Type 'State'
data State
 =   State
 {   state_pos :: Pos
 }
instance Default State where
	def = State
	 { state_pos = pos1
	 }
-}

-- * Type 'Inh'
data Inh
 =   Inh
 {   inh_figure :: Bool
 ,   inh_tree0  :: [Pos -> XMLs -> XML]
 ,   inh_titles :: Seq Tokens
 }
instance Default Inh where
	def = Inh
	 { inh_figure = False
	 , inh_tree0  = []
	 , inh_titles = mempty
	 }

-- * Class 'Xmlify'
class Xmlify a where
	xmlify :: Inh -> a -> XMLs
instance Xmlify TCTs where
	xmlify inh_orig = go inh_orig
		where
		go :: Inh -> TCTs -> XMLs
		go inh trees =
			case Seq.viewl trees of
			 TreeN (Cell bp ep (KeyBar n _)) _ :< _
			  | (body,ts) <- spanlBar n trees
			  , not (null body) ->
				(<| go inh ts) $
				TreeN (Cell bp ep "artwork") $
					maybe id (\v -> (Tree0 (XmlAttr (Cell bp ep ("type", v))) <|)) (mimetype n) $
					body >>= xmlify inh{inh_tree0=[]}
			
			 TreeN key@(unCell -> KeyColon n _) cs :< ts
			  | (cs',ts') <- spanlKeyColon n ts
			  , not (null cs') ->
				go inh $ TreeN key (cs<>cs') <| ts'
			
			 TreeN (Cell bp ep KeyBrackets{}) _ :< _
			  | (rl,ts) <- spanlBrackets trees
			  , not (null rl) ->
				(<| go inh ts) $
				TreeN (Cell bp ep "references") $
					rl >>= xmlify inh_orig
			
			 _ | (ul,ts) <- spanlItems (==KeyDash) trees
			   , TreeN (Cell bp ep _) _ :< _ <- Seq.viewl ul ->
				(<| go inh ts) $
				TreeN (Cell bp ep "ul") $
					ul >>= xmlify inh{inh_tree0=List.repeat xmlPara}
			
			 _ | (ol,ts) <- spanlItems (\case KeyDot{} -> True; _ -> False) trees
			   , TreeN (Cell bp ep _) _ :< _ <- Seq.viewl ol ->
				(<| go inh ts) $
				TreeN (Cell bp ep "ol") $
					ol >>= xmlify inh{inh_tree0=List.repeat xmlPara}
			
			 t@(Tree0 toks) :< ts ->
				case inh_tree0 inh of
				 []                   -> xmlify inh_orig t <> go inh ts
				 _ | isTokenElem toks -> xmlify inh_orig t <> go inh ts
				 tree0:inh_tree0 ->
					(case Seq.viewl toks of
					 EmptyL -> id
					 (posTree -> bp) :< _ -> (tree0 bp (xmlify inh_orig t) <|)) $
					go inh{inh_tree0} ts
			
			 t:<ts ->
				xmlify inh_orig t <>
				go inh ts
			
			 _ -> mempty
instance Xmlify TCT where
	xmlify inh tr =
		case tr of
		 TreeN (Cell bp ep KeySection{}) ts ->
			let (attrs,body) = partitionAttributesChildren ts in
			let inh' = inh
				 { inh_tree0  = xmlTitle : List.repeat xmlPara
				 , inh_figure = True
				 } in
			Seq.singleton $
			TreeN (Cell bp ep "section") $
				xmlAttrs (defXmlAttr (Cell ep ep ("id", getAttrId body)) attrs) <>
				xmlify inh' body
		
		 TreeN key@(Cell bp ep (KeyColon kn _)) ts ->
			let (attrs,body) = partitionAttributesChildren ts in
			let inh' = inh { inh_tree0 =
				case kn of
				 "about"     -> xmlTitle : xmlTitle : List.repeat xmlPara
				 "reference" -> xmlTitle : xmlTitle : List.repeat xmlPara
				 "serie"     -> List.repeat xmlName
				 "author"    -> List.repeat xmlName
				 "editor"    -> List.repeat xmlName
				 "org"       -> List.repeat xmlName
				 _           -> []
			 } in
			case () of
			 _ | kn == "about" -> xmlAbout inh' key attrs body
			
			 _ | inh_figure inh && not (kn`List.elem`elems) ->
				Seq.singleton $
				TreeN (Cell bp ep "figure") $
					xmlAttrs (setXmlAttr (Cell ep ep ("type", kn)) attrs) <>
					case toList body of
					 [Tree0{}] -> xmlify inh'{inh_tree0 = List.repeat xmlPara} body
					 _         -> xmlify inh'{inh_tree0 = xmlTitle : List.repeat xmlPara} body
			
			 _ -> Seq.singleton $ xmlKey inh' key attrs body
		
		 TreeN key ts -> Seq.singleton $ xmlKey inh key mempty ts
		
		 Tree0 ts -> xmlify inh ts
instance Xmlify Tokens where
	xmlify inh toks =
		case Seq.viewl toks of
		 TreeN (Cell bp _ep PairParen) paren
		  :< (Seq.viewl -> TreeN (Cell bb eb PairBracket) bracket
		  :< ts) ->
			(<| xmlify inh ts) $
			case bracket of
			 (toList -> [Tree0 (Cell bl el (TokenLink lnk))]) ->
				TreeN (Cell bp eb "eref") $
					xmlAttrs [Cell bl el ("to",lnk)] <>
					xmlify inh paren
			 _ ->
				TreeN (Cell bp eb "rref") $
					xmlAttrs [Cell bb eb ("to",TL.toStrict $ Plain.text def bracket)] <>
					xmlify inh paren
		 t :< ts -> xmlify inh t `unionXml` xmlify inh ts
		 Seq.EmptyL -> mempty
instance Xmlify Token where
	xmlify inh (TreeN (Cell bp ep p) ts) =
		case p of
		 PairBracket | to <- Plain.text def ts
		             , TL.all (\c -> Char.isAlphaNum c || Char.isSymbol c) to ->
			Seq.singleton .
			TreeN (cell "rref") $
				xmlAttrs [cell ("to",TL.toStrict to)]
		 PairStar      -> Seq.singleton . TreeN (cell "b")    $ xmlify inh ts
		 PairSlash     -> Seq.singleton . TreeN (cell "i")    $ xmlify inh ts
		 PairBackquote -> Seq.singleton . TreeN (cell "code") $ xmlify inh ts
		 PairFrenchquote ->
			Seq.singleton .
			TreeN (cell "q") $
			xmlify inh ts
			{-
			case ts of
			 (Seq.viewl -> Tree0 (Cell bl el (TokenPlain l)) :< ls) ->
				case Seq.viewr ls of
				 m :> Tree0 (Cell br er (TokenPlain r)) ->
					xmlify inh $
						Tree0 (Cell bl el (TokenPlain (Text.dropWhile Char.isSpace l)))
						 <|(m|>Tree0 (Cell br er (TokenPlain (Text.dropWhileEnd Char.isSpace r))))
				 _ ->
					xmlify inh $
						Tree0 (Cell bl el (TokenPlain (Text.dropAround Char.isSpace l))) <| ls
			 (Seq.viewr -> rs :> Tree0 (Cell br er (TokenPlain r))) ->
				xmlify inh $
					rs |> Tree0 (Cell br er (TokenPlain (Text.dropAround Char.isSpace r)))
			 _ -> xmlify inh ts
			 -}
		 PairHash ->
			Seq.singleton .
			TreeN (cell "ref") $
				xmlAttrs [cell ("to",TL.toStrict $ Plain.text def ts)]
		 PairElem name attrs ->
			Seq.singleton .
			TreeN (cell $ xmlLocalName name) $
				xmlAttrs (Seq.fromList $ (\(_wh,ElemAttr{..}) ->
					cell (xmlLocalName elemAttr_name,elemAttr_value)) <$> attrs) <>
				xmlify inh ts
		 _ ->
			let (o,c) = pairBorders p ts in
			Seq.singleton (Tree0 $ XmlPhrases $ phrasify $ Cell bp bp o) `unionXml`
			xmlify inh ts `unionXml`
			Seq.singleton (Tree0 $ XmlPhrases $ phrasify $ Cell ep ep c)
		where
		cell :: a -> Cell a
		cell = Cell bp ep
	xmlify inh (Tree0 tok) = do
		case tok of
		 TokenPhrases ps -> xmlify inh $ ps
		 TokenEscape c -> Seq.singleton $ Tree0 $ XmlPhrases $ phrasify c
		 TokenRaw t    -> Seq.singleton $ Tree0 $ XmlText t
		 TokenTag t    -> Seq.singleton $ TreeN (cell "ref") $ xmlAttrs [cell ("to",t)]
		 TokenLink (Cell bp ep lnk) ->
			xmlify (Cell bp ep ()) <>
			Seq.singleton (TreeN (cell "eref") $ xmlAttrs [cell ("to",lnk)])
		where
		cell :: a -> Cell a
		cell = Cell bp ep
		{-
		whites :: Pos -> Pos -> Seq XmlText
		whites (Pos bLine bCol) (Pos eLine eCol) =
			case bLine`compate`eLine of
			 LT -> verts <> 
			 EQ -> horiz bCol eCol
			 GT ->
		-}
instance Xmlify (Cell Phrase) where
	xmlify _inh t = Seq.singleton $ Tree0 $ XmlPhrases $ Seq.singleton t

mimetype :: Text -> Maybe Text
mimetype "hs"          = Just "text/x-haskell"
mimetype "sh"          = Just "text/x-shellscript"
mimetype "shell"       = Just "text/x-shellscript"
mimetype "shellscript" = Just "text/x-shellscript"
mimetype _             = Nothing

xmlPhantom :: XmlName -> Pos -> XMLs -> XML
xmlPhantom n bp = TreeN (Cell bp bp n)
xmlPara :: Pos -> XMLs -> XML
xmlPara = xmlPhantom "para"
xmlTitle :: Pos -> XMLs -> XML
xmlTitle = xmlPhantom "title"
xmlName :: Pos -> XMLs -> XML
xmlName bp (toList -> [Tree0 (XmlText (unCell -> t))]) = Tree0 (XmlAttr $ Cell bp bp ("name", t))
xmlName bp ts = xmlPhantom "name" bp ts

xmlAbout ::
 Inh ->
 Cell Key -> Seq (Cell (XmlName, Text)) ->
 TCTs -> XMLs
xmlAbout inh key attrs body =
	Seq.singleton $
	xmlKey inh key attrs $
	case Seq.viewl (inh_titles inh) of
	 (Seq.viewl -> (posTree -> bt) :< _) :< _ ->
		((<$> inh_titles inh) $ \title ->
			TreeN (Cell bt bt $ KeyColon "title" "") $
				Seq.singleton $ Tree0 title)
		 <> body
	 _ -> body

xmlKey :: Inh -> Cell Key -> Seq (Cell (XmlName, Text)) -> TCTs -> XML
xmlKey inh (Cell bp ep key) attrs ts =
	case key of
	 KeyColon n _wh -> d_key n
	 KeyGreat n _wh -> d_key n
	 KeyEqual n _wh -> d_key n
	 KeyBar   n _wh -> d_key n
	 KeyDot _n   -> TreeN (cell "li") $ xmlify inh ts
	 KeyDash     -> TreeN (cell "li") $ xmlify inh ts
	 KeyDashDash -> Tree0 $ XmlComment $ cell $ TL.toStrict com
		where
		com :: TL.Text
		com =
			trace ("TS: "<>show ts) $
			trace ("RS: "<>show (S.evalState (Plain.rackUpLeft ts) Nothing)) $
			Plain.text def $ S.evalState (Plain.rackUpLeft ts) Nothing
			{-
			TreeSeq.mapAlsoNode
			 (cell1 . unCell)
			 (\_k -> fmap $
				TreeSeq.mapAlsoNode
				 (cell1 . unCell)
				 (\_k' -> cell1 . unCell)) <$> ts
			-}
	 KeyLower n as -> TreeN (cell "artwork") $ xmlify inh ts
	 KeyBrackets ident ->
		let inh' = inh{inh_figure = False} in
		let (attrs',body) = partitionAttributesChildren ts in
		TreeN (cell "reference") $
			xmlAttrs (setXmlAttr (Cell ep ep ("id", ident)) (attrs<>attrs')) <>
			xmlify inh'{inh_tree0 = xmlTitle : xmlTitle : List.repeat xmlPara} body
	 KeyDotSlash p ->
		TreeN (cell "include") $
			xmlAttrs [cell ("href", Text.pack $ FP.replaceExtension p "dtc")] <>
			xmlify inh ts
	where
	cell :: a -> Cell a
	cell = Cell bp ep
	d_key :: Text -> XML
	d_key n =
		TreeN (cell $ xmlLocalName n) $
			xmlAttrs attrs <>
			xmlify inh ts

xmlAttrs :: Seq (Cell (XmlName,Text)) -> XMLs
xmlAttrs = (Tree0 . XmlAttr <$>)

-- | Unify two 'XMLs', merging border 'XmlText's if any.
unionXml :: XMLs -> XMLs -> XMLs
unionXml x y =
	case (Seq.viewr x, Seq.viewl y) of
	 (xs :> x0, y0 :< ys) ->
		case (x0,y0) of
		 (  Tree0 (XmlPhrases tx)
		  , Tree0 (XmlPhrases ty) ) ->
			xs `unionXml`
			Seq.singleton (Tree0 $ XmlPhrases $ tx <> ty) `unionXml`
			ys
		 (  Tree0 (XmlText tx)
		  , Tree0 (XmlText ty) ) ->
			xs `unionXml`
			Seq.singleton (Tree0 $ XmlText $ tx <> ty) `unionXml`
			ys
		 _ -> x <> y
	 (Seq.EmptyR, _) -> y
	 (_, Seq.EmptyL) -> x

spanlBar :: Name -> TCTs -> (TCTs, TCTs)
spanlBar name = first unKeyBar . spanBar
	where
	unKeyBar :: TCTs -> TCTs
	unKeyBar = (=<<) $ \case
		 TreeN (unCell -> KeyBar{}) ts -> ts
		 _ -> mempty
	spanBar =
		Seq.spanl $ \case
		 TreeN (unCell -> KeyBar n _) _ | n == name -> True
		 _ -> False

spanlItems :: (Key -> Bool) -> TCTs -> (TCTs, TCTs)
spanlItems liKey ts =
	let (lis, ts') = spanLIs ts in
	foldl' accumLIs (mempty,ts') lis
	where
	spanLIs :: TCTs -> (TCTs, TCTs)
	spanLIs = Seq.spanl $ \case
		 TreeN (unCell -> liKey -> True) _ -> True
		 Tree0 toks ->
			(`any` toks) $ \case
			 TreeN (unCell -> PairElem "li" _) _ -> True
			 _ -> False
			{-
			case toList $ Seq.dropWhileR (isTokenWhite . unCell) toks of
			 [unCell -> TokenPair (PairElem "li" _) _] -> True
			 _ -> False
			-}
		 _ -> False
	accumLIs :: (TCTs,TCTs) -> TCT -> (TCTs,TCTs)
	accumLIs acc@(oks,kos) t =
		case t of
		 TreeN (unCell -> liKey -> True) _ -> (oks|>t,kos)
		 Tree0 toks ->
			let (ok,ko) =
				(`Seq.spanl` toks) $ \case
				 TreeN (unCell -> PairElem "li" _) _ -> True
				 -- (isTokenWhite -> True) -> True -- TODO: see if this is still useful
				 _ -> False in
			( if null ok then oks else oks|>Tree0 (rmTokenWhite ok)
			, if null ko then kos else Tree0 ko<|kos )
		 _ -> acc
	{-
	rmTokenWhite :: Tokens -> Tokens
	rmTokenWhite =
		Seq.filter $ \case
		 (isTokenWhite -> False) -> True
		 _ -> True
	-}

spanlKeyColon :: Name -> TCTs -> (TCTs, TCTs)
spanlKeyColon name =
	Seq.spanl $ \case
	 TreeN (unCell -> KeyBar   n _) _ -> n == name
	 TreeN (unCell -> KeyGreat n _) _ -> n == name
	 _ -> False

spanlBrackets :: TCTs -> (TCTs, TCTs)
spanlBrackets =
	Seq.spanl $ \case
	 TreeN (unCell -> KeyBrackets{}) _ -> True
	 _ -> False

spanlTokens :: TCTs -> (Seq Tokens, TCTs)
spanlTokens =
	first ((\case
	 Tree0 ts -> ts
	 _ -> undefined) <$>) .
	Seq.spanl (\case
	 Tree0{} -> True
	 _ -> False)

getAttrId :: TCTs -> Text
getAttrId ts =
	case Seq.index ts <$> Seq.findIndexL TreeSeq.isTree0 ts of
	 Just (Tree0 toks) -> TL.toStrict $ Plain.text def toks
	 _ -> ""

setXmlAttr :: Cell (XmlName, Text) -> Seq (Cell (XmlName, Text)) -> Seq (Cell (XmlName, Text))
setXmlAttr a@(unCell -> (k, _v)) as =
	case Seq.findIndexL (\(unCell -> (n,_v)) -> n == k) as of
	 Just idx -> Seq.update idx a as
	 Nothing -> a <| as

defXmlAttr :: Cell (XmlName, Text) -> Seq (Cell (XmlName, Text)) -> Seq (Cell (XmlName, Text))
defXmlAttr a@(unCell -> (k, _v)) as =
	case Seq.findIndexL (\(unCell -> (n,_v)) -> n == k) as of
	 Just _idx -> as
	 Nothing -> a <| as

partitionAttributesChildren :: TCTs -> (Seq (Cell (XmlName, Text)), TCTs)
partitionAttributesChildren ts = (attrs,cs)
	where
	(as,cs) = (`Seq.partition` ts) $ \case
		 TreeN (unCell -> KeyEqual{}) _cs -> True
		 _ -> False
	attrs = attr <$> as
	attr = \case
	 TreeN (Cell bp ep (KeyEqual n _wh)) a ->
		Cell bp ep (xmlLocalName n, v)
		where
		v = TL.toStrict $
			Plain.text def{Plain.state_escape = False} $
			TreeSeq.mapAlsoNode
			 (cell1 . unCell)
			 (\_k -> fmap $
				TreeSeq.mapAlsoNode
				 (cell1 . unCell)
				 (\_k' -> cell1 . unCell)) <$> a
	 _ -> undefined

elems :: Set Text
elems =
 [ "about"
 , "abstract"
 , "address"
 , "alias"
 , "annotation"
 , "area"
 , "artwork"
 , "aside"
 , "audio"
 , "author"
 , "authors"
 , "bcp14"
 , "br"
 , "call"
 , "city"
 , "code"
 , "comment"
 , "comments"
 , "country"
 , "date"
 , "dd"
 , "define"
 , "del"
 , "div"
 , "dl"
 , "document"
 , "dt"
 , "editor"
 , "email"
 , "embed"
 , "eref"
 , "fax"
 , "feed"
 , "feedback"
 , "figure"
 , "filter"
 , "format"
 , "from"
 , "h"
 , "hi"
 , "html5"
 , "i"
 , "index"
 , "iref"
 , "keyword"
 , "li"
 , "link"
 , "name"
 , "note"
 , "ol"
 , "organization"
 , "para"
 , "postamble"
 , "preamble"
 , "q"
 , "ref"
 , "reference"
 , "references"
 , "region"
 , "rref"
 , "sc"
 , "section"
 , "serie"
 , "source"
 , "span"
 , "street"
 , "style"
 , "sub"
 , "sup"
 , "table"
 , "tbody"
 , "td"
 , "tel"
 , "tfoot"
 , "title"
 , "th"
 , "thead"
 , "toc"
 , "tof"
 , "tr"
 , "tt"
 , "u"
 , "ul"
 , "uri"
 , "version"
 , "video"
 , "workgroup"
 , "xml"
 , "zipcode"
 ]