{-# 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 (Foldable(..))
import Data.Function (($), (.), id)
import Data.Functor ((<$>), (<$))
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (Seq, ViewL(..), ViewR(..), (<|))
import Data.Set (Set)
import Data.TreeSeq.Strict (Tree(..))
import Data.Tuple (uncurry)
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.Lazy as TL
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.TCT.Debug
import Language.XML

xmlDocument :: Roots -> XMLs
xmlDocument trees =
	-- (`S.evalState` def) $
	case Seq.viewl trees of
	 Tree (unCell -> NodeHeader HeaderSection{}) vs :< ts ->
		case spanlNodeToken vs of
		 (titles@(Seq.viewl -> (unTree -> cell_begin -> bp) :< _), vs') ->
			let vs'' =
				case Seq.findIndexL
				 (\case
				 Tree (unCell -> NodeHeader (HeaderColon "about" _)) _ -> True
				 _ -> False) vs' of
				 Nothing -> Tree (Cell bp bp $ NodeHeader $ HeaderColon "about" "") mempty <| vs'
				 Just{} -> vs' in
			xmlify def
			 { inh_titles = titles
			 , inh_figure = True
			 , inh_para   = 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_para   :: [Cell () -> XMLs -> XML]
 ,   inh_titles :: Roots
 }
instance Default Inh where
	def = Inh
	 { inh_figure = False
	 , inh_para   = []
	 , inh_titles = mempty
	 }

{-
newtype Merge a = Merge a
 deriving (Functor)
instance Semigroup (Merge Roots) where
	(<>) = unionTokens
instance Monad (Merge Roots) where
	return = Merge
	Merge m >>= f =
		foldMap nn
-}

-- * Class 'Xmlify'
class Xmlify a where
	xmlify :: Inh -> a -> XMLs
instance Xmlify Roots where
	xmlify inh roots =
		case Seq.viewl roots of
		 EmptyL -> mempty
		 l@(Tree cel@(Cell bp _ep nod) ts) :< rs ->
			case nod of
			 NodeHeader (HeaderBar n _wh)
			  | (span, rest) <- spanlHeaderBar n roots ->
				let (attrs,body) = partitionAttrs span in
				(<| xmlify inh rest) $
				element "artwork" $
					xmlAttrs (attrs `defaultAttr` Cell bp bp ("type", fromMaybe "text/plain" $ mimetype n)) <>
					xmlify inh{inh_para=[]} body
			----------------------
			 NodeHeader (HeaderGreat n _wh)
			  | (span, rest) <- spanlHeaderGreat n roots ->
				let (attrs,body) = partitionAttrs span in
				(<| xmlify inh rest) $
				element "artwork" $
					xmlAttrs (attrs `defaultAttr` Cell bp bp ("type", fromMaybe "text/plain" $ mimetype n)) <>
					xmlify inh{inh_para=[]} (debug0 "body" body)
			----------------------
			 NodeHeader (HeaderColon n _wh)
			  | (span, rest) <- spanlHeaderColon n rs
			  , not $ null span ->
				xmlify inh $ Tree cel (ts<>span) <| rest
			----------------------
			 NodeHeader HeaderBrackets{}
			  | (span,rest) <- spanlBrackets roots
			  , not (null span) ->
				(<| xmlify inh rest) $
				element "references" $
					xmlify inh span
			----------------------
			 NodeText x
			  | Tree (cy@(unCell -> NodeText y)) ys :< rs' <- Seq.viewl rs ->
				xmlify inh $ Tree (NodeText <$> (x <$ cel) <> (y <$ cy)) (ts <> ys) <| rs'
			----------------------
			 NodePair PairParen
			  | Tree (Cell bb eb (NodePair PairBracket)) bracket :< rs' <- Seq.viewl rs ->
				(<| xmlify inh rs') $
				case bracket of
				 (toList -> [unTree -> Cell bl el (NodeToken (TokenLink lnk))]) ->
					element "eref" $
						xmlAttrs [Cell bl el ("to",lnk)] <>
						xmlify inh ts
				 _ ->
					element "rref" $
						xmlAttrs [Cell bb eb ("to",Plain.plainDocument bracket)] <>
						xmlify inh ts
			----------------------
			 _ | (span, rest) <- spanlItems (==HeaderDash) roots
			   , not $ null span ->
				(<| xmlify inh rest) $
				element "ul" $
					span >>= xmlify inh{inh_para=List.repeat xmlPara}
			----------------------
			 _ | (span,rest) <- spanlItems (\case HeaderDot{} -> True; _ -> False) roots
			   , not $ null span ->
				(<| xmlify inh rest) $
				element "ol" $
					span >>= xmlify inh{inh_para=List.repeat xmlPara}
			----------------------
			 _ ->
				xmlify inh l <>
				xmlify inh rs
			where
			element :: XmlName -> XMLs -> XML
			element n = tree (XmlElem n <$ cel)
		{-
		 t@(Tree (NodePair (PairElem))) :< ts ->
			case inh_para inh of
			 []                   -> xmlify inh t <> go inh ts
			 _ | isTokenElem toks -> xmlify inh t <> go inh ts
			 tree0:inh_para ->
				(case Seq.viewl toks of
				 EmptyL -> id
				 (unTree -> cell_begin -> bp) :< _ -> (tree0 bp (xmlify inh t) <|)) $
				go inh{inh_para} ts
		-}
instance Xmlify Root where
	xmlify inh (Tree cel@(Cell bp ep nod) ts) =
		case nod of
		 NodeGroup -> xmlify inh ts
		----------------------
		 NodePara ->
			case inh_para inh of
			 [] -> xmlify inh ts
			 para:inh_para ->
				Seq.singleton $
				para (() <$ cel) $
				xmlify inh{inh_para} ts
		----------------------
		 NodeHeader hdr ->
			case hdr of
			 HeaderSection{} ->
				let (attrs,body) = partitionAttrs ts in
				let inh' = inh
					 { inh_para  = xmlTitle : List.repeat xmlPara
					 , inh_figure = True
					 } in
				Seq.singleton $
				element "section" $
					xmlAttrs (attrs `defaultAttr` Cell ep ep ("id",getAttrId body)) <>
					xmlify inh' body
			 HeaderColon kn _wh ->
				let (attrs,body) = partitionAttrs ts in
				let inh' = inh { inh_para =
					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' cel {-attrs-} body
				 _ | inh_figure inh && not (kn`List.elem`elems) ->
					Seq.singleton $
					element "figure" $
						xmlAttrs (setAttr (Cell ep ep ("type",kn)) attrs) <>
						case toList body of
						 [Tree0{}] -> xmlify inh'{inh_para = List.repeat xmlPara} body
						 _         -> xmlify inh'{inh_para = xmlTitle : List.repeat xmlPara} body
				 _ ->
					Seq.singleton $
					element (xmlLocalName kn) $
						xmlAttrs attrs <>
						xmlify inh' ts
			 HeaderGreat n _wh -> Seq.singleton $ element (xmlLocalName n) $ xmlify inh ts
			 HeaderEqual n _wh -> Seq.singleton $ element (xmlLocalName n) $ xmlify inh ts
			 HeaderBar   n _wh -> Seq.singleton $ element (xmlLocalName n) $ xmlify inh ts
			 HeaderDot _n   -> Seq.singleton $ element "li" $ xmlify inh ts
			 HeaderDash     -> Seq.singleton $ element "li" $ xmlify inh ts
			 HeaderDashDash -> Seq.singleton $ Tree0 $ cell $ XmlComment $
					-- debug1_ ("TS", ts) $
					-- debug1_ ("RS", (S.evalState (Plain.rackUpLeft ts) Nothing)) $
					Plain.plainDocument ts
					-- Plain.text def $ S.evalState (Plain.rackUpLeft ts) Nothing
					{-
					TreeSeq.mapAlsoNode
					 (cell1 . unCell)
					 (\_k -> fmap $
						TreeSeq.mapAlsoNode
						 (cell1 . unCell)
						 (\_k' -> cell1 . unCell)) <$> ts
					-}
			 HeaderBrackets ident ->
				let inh' = inh{inh_figure = False} in
				let (attrs,body) = partitionAttrs ts in
				Seq.singleton $
				element "reference" $
					xmlAttrs (setAttr (Cell ep ep ("id",ident)) attrs) <>
					xmlify inh'{inh_para = xmlTitle : xmlTitle : List.repeat xmlPara} body
			 HeaderDotSlash p ->
				Seq.singleton $
				element "include" $
					xmlAttrs [cell ("href",TL.pack $ FP.replaceExtension p "dtc")] <>
					xmlify inh ts
		----------------------
		 NodePair pair ->
			case pair of
			 PairBracket | to <- Plain.plainDocument ts
			             , TL.all (\c -> Char.isAlphaNum c || Char.isSymbol c) to ->
				Seq.singleton $
				element "rref" $
					xmlAttrs [cell ("to",to)]
			 PairStar      -> Seq.singleton $ element "b"    $ xmlify inh ts
			 PairSlash     -> Seq.singleton $ element "i"    $ xmlify inh ts
			 PairBackquote -> Seq.singleton $ element "code" $ xmlify inh ts
			 PairFrenchquote ->
				Seq.singleton $
				element "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 $
				element "ref" $
					xmlAttrs [cell ("to",Plain.plainDocument ts)]
			 PairElem name attrs ->
				Seq.singleton $
				element (xmlLocalName name) $
					xmlAttrs (Seq.fromList $ (\(_wh,ElemAttr{..}) ->
						cell (xmlLocalName elemAttr_name,elemAttr_value)) <$> attrs) <>
					xmlify inh ts
			 _ ->
				let (open, close) = pairBorders pair ts in
				Seq.singleton (Tree0 $ Cell bp bp $ XmlText open) `unionXml`
				xmlify inh ts `unionXml`
				Seq.singleton (Tree0 $ Cell ep ep $ XmlText close)
		----------------------
		 NodeText t -> Seq.singleton $ Tree0 $ cell $ XmlText t
		----------------------
		 NodeToken tok ->
			case tok of
			 TokenEscape c -> Seq.singleton $ Tree0 $ cell $ XmlText $ TL.singleton c
			 TokenText t   -> Seq.singleton $ Tree0 $ cell $ XmlText t
			 TokenTag t    -> Seq.singleton $ element "ref"  $ xmlAttrs [cell ("to",t)]
			 TokenLink lnk -> Seq.singleton $ element "eref" $ xmlAttrs [cell ("to",lnk)]
		----------------------
		 NodeLower n as ->
			Seq.singleton $
			element "artwork" $
				xmlify inh ts
		where
		cell :: a -> Cell a
		cell = Cell bp ep
		element :: XmlName -> XMLs -> XML
		element n = tree (cell $ XmlElem n)

-- | TODO: add more mimetypes
mimetype :: TL.Text -> Maybe TL.Text
mimetype "txt"         = Just "text/plain"
mimetype "plain"       = Just "text/plain"
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

xmlPara :: Cell a -> XMLs -> XML
xmlPara c = tree (XmlElem "para" <$ c)

xmlTitle :: Cell a -> XMLs -> XML
xmlTitle c = tree (XmlElem "title" <$ c)

xmlName :: Cell a -> XMLs -> XML
-- xmlName bp (toList -> [unTree -> unCell -> XmlText t]) = Tree0 $ Cell bp bp $ XmlAttr "name" t
xmlName c = tree (XmlElem "name" <$ c)

xmlAbout ::
 Inh ->
 Cell Node ->
 -- Seq (Cell (XmlName, Text)) ->
 Roots -> XMLs
xmlAbout inh nod body =
	xmlify inh $ Tree nod $
	case Seq.viewl (inh_titles inh) of
	 (unTree -> cell_begin -> bt) :< _ ->
		((<$> inh_titles inh) $ \title ->
			Tree (Cell bt bt $ NodeHeader $ HeaderColon "title" "") $
				Seq.singleton $ title)
		 <> body
	 _ -> body

xmlAttrs :: Seq (Cell (XmlName,TL.Text)) -> XMLs
xmlAttrs = (Tree0 . (uncurry 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 (Cell bx ex (XmlText tx))
		  , Tree0 (Cell by ey (XmlText ty)) ) ->
			xs `unionXml`
			Seq.singleton (Tree0 $ (XmlText <$>) $ Cell bx ex tx <> Cell by ey ty) `unionXml`
			ys
		 _ -> x <> y
	 (Seq.EmptyR, _) -> y
	 (_, Seq.EmptyL) -> x

unionsXml :: Foldable f => f XMLs -> XMLs
unionsXml = foldl' unionXml mempty

partitionAttrs :: Roots -> (Seq (Cell (XmlName, TL.Text)), Roots)
partitionAttrs ts = (attrs,cs)
	where
	(as,cs) = (`Seq.partition` ts) $ \case
		 Tree (unCell -> NodeHeader (HeaderEqual (TL.null -> False) _wh)) _cs -> True
		 _ -> False
	attrs = attr <$> as
	attr = \case
	 Tree (Cell bp ep (NodeHeader (HeaderEqual n _wh))) a ->
		Cell bp ep (xmlLocalName n, v)
		where
		v = Plain.text (Plain.setStart a def{Plain.state_escape = False}) a
	 _ -> undefined

spanlHeaderBar :: Name -> Roots -> (Roots, Roots)
spanlHeaderBar name = first unHeaderBar . debug0 "spanBar" . spanBar
 -- FIXME: use unTree
	where
	unHeaderBar :: Roots -> Roots
	unHeaderBar = (=<<) $ \case
		 Tree (unCell -> NodeHeader HeaderBar{}) ts -> ts
		 ts -> return ts
	spanBar =
		Seq.spanl $ \case
		 Tree (unCell -> NodeHeader (HeaderBar n _)) _ | n == name -> True
		 Tree (unCell -> NodeHeader (HeaderGreat n _)) _ | n == name -> True
		 _ -> False

spanlHeaderGreat :: Name -> Roots -> (Roots, Roots)
spanlHeaderGreat name = first unHeaderGreat . debug0 "spanGreat" . spanGreat
 -- FIXME: use unTree
	where
	unHeaderGreat :: Roots -> Roots
	unHeaderGreat = (=<<) $ \case
		 Tree (unCell -> NodeHeader HeaderGreat{}) ts -> ts
		 ts -> return ts
	spanGreat =
		Seq.spanl $ \case
		 Tree (unCell -> NodeHeader (HeaderGreat n _)) _ | n == name -> True
		 _ -> False

spanlItems :: (Header -> Bool) -> Roots -> (Roots, Roots)
spanlItems liHeader =
	Seq.spanl $ \(unTree -> unCell -> nod) ->
		case nod of
		 NodeHeader (HeaderColon "li" _wh) -> True
		 NodeHeader hdr -> liHeader hdr
		 NodePair (PairElem "li" _as) -> True
		 _ -> False

spanlHeaderColon :: Name -> Roots -> (Roots, Roots)
spanlHeaderColon name =
	Seq.spanl $ \case
	 Tree (unCell -> NodeHeader (HeaderBar   n _)) _ -> n == name
	 Tree (unCell -> NodeHeader (HeaderGreat n _)) _ -> n == name
	 _ -> False

spanlBrackets :: Roots -> (Roots, Roots)
spanlBrackets =
	Seq.spanl $ \case
	 Tree (unCell -> NodeHeader HeaderBrackets{}) _ -> True
	 _ -> False

spanlNodeToken :: Roots -> (Roots, Roots)
spanlNodeToken =
	Seq.spanl (\case
	 Tree (unCell -> NodeToken{}) _ -> True
	 _ -> False)

getAttrId :: Roots -> TL.Text
getAttrId ts =
	case Seq.viewl ts of
	 EmptyL -> ""
	 t :< _ -> Plain.plainDocument $ Seq.singleton t

setAttr ::
 Cell (XmlName, TL.Text) ->
 Seq (Cell (XmlName, TL.Text)) ->
 Seq (Cell (XmlName, TL.Text))
setAttr 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

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

elems :: Set TL.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"
 ]