{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hdoc.DTC.Write.XML where

import Control.Monad (forM_)
import Data.Bool
import Data.Foldable (Foldable(..))
import Data.Function (($), (.))
import Data.Functor ((<$>))
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Sequence (Seq)
import Data.TreeSeq.Strict (Tree(..))
import Text.Blaze ((!))
import Text.Blaze.Utils
import Text.Blaze.XML (XML)
import qualified Data.Function as Fun
import qualified Data.Text.Lazy as TL
import qualified Text.Blaze as B
import qualified Text.Blaze.DTC as XML
import qualified Text.Blaze.DTC.Attributes as XA
import qualified Text.Blaze.Internal as B

import Data.Locale
import Hdoc.DTC.Analyze.Index (plainifyWords)
import Hdoc.DTC.Document as DTC

writeXML :: Locales ls => LocaleIn ls -> Document -> XML
writeXML _loc Document{..} = do
	XML.xmlModel "./schema/dtc.rnc"
	{-
	let lang = Text.takeWhile Char.isAlphaNum $ textLocales Map.! loc
	XML.xmlStylesheet   $ "./xsl/document.html5."<>lang<>".xsl"
	XML.html5Stylesheet $ "./xsl/document.html5."<>lang<>".xsl"
	XML.atomStylesheet  $ "./xsl/document.atom."<>lang<>".xsl"
	-}
	XML.document $ do
		xmlify head
		xmlify body

-- * Class 'Xmlify'
class Xmlify a where
	xmlify :: a -> XML

instance Xmlify TL.Text where
	xmlify = B.toMarkup
instance Xmlify Head where
	xmlify Head{..} =
		xmlify head_about
instance Xmlify (Tree BodyNode) where
	xmlify (Tree n ts) =
		case n of
		 BodyBlock b -> xmlify b
		 BodySection Section{..} ->
			xmlCommonAttrs section_attrs $
			XML.section $ do
				xmlify section_title
				forM_ section_aliases xmlify
				xmlify ts
instance Xmlify Block where
	xmlify = \case
	 BlockPara para -> xmlify para
	 BlockBreak{..} ->
		xmlCommonAttrs attrs $
		XML.break
	 BlockToC{..} ->
		xmlCommonAttrs attrs $
		XML.toc
		 !?? mayAttr XA.depth depth
	 BlockToF{..} ->
		xmlCommonAttrs attrs $
		XML.tof $
			XML.ul $
				forM_ types $
					XML.li . xmlify
	 BlockIndex{..} ->
		xmlCommonAttrs attrs $
		XML.index $ do
			XML.ul $
				forM_ terms $ \aliases ->
					XML.li $
						xmlify $
						TL.unlines $
						plainifyWords <$> aliases
	 BlockAside{..} ->
		xmlCommonAttrs attrs $
		XML.aside $ do
			xmlify blocks
	 BlockFigure{..} ->
		xmlCommonAttrs attrs $
		XML.figure
		 ! XA.type_ (attrify type_) $ do
			xmlify mayTitle
			xmlify paras
	 BlockReferences{..} ->
		xmlCommonAttrs attrs $
		XML.references $ xmlify refs
instance Xmlify Para where
	xmlify = \case
	 ParaItem{..}  -> xmlify item
	 ParaItems{..} -> xmlCommonAttrs attrs $ XML.para $ xmlify items
instance Xmlify ParaItem where
	xmlify = \case
	 ParaPlain p -> XML.p $ xmlify p
	 ParaComment c ->
		XML.comment $ TL.toStrict c
	 ParaArtwork{..} ->
		XML.artwork
		 ! XA.type_ (attrify type_) $ do
			xmlify text
	 ParaQuote{..} ->
		XML.quote
		 ! XA.type_ (attrify type_) $ do
			xmlify paras
	 ParaOL items -> XML.ol $ forM_ items xmlify
	 ParaUL items -> XML.ul $ forM_ items $ XML.li . xmlify
	 ParaJudgment j -> xmlify j
instance Xmlify Judgment where
	xmlify = \case
	 Judgment{..} ->
		XML.judgment
		 ! XA.judges (attrify judgment_judgesId)
		 ! XA.grades (attrify judgment_gradesId) $
			xmlify judgment_question
			-- TODO: xmlify judgment_choices
instance Xmlify ListItem where
	xmlify ListItem{..} =
		XML.li ! XA.name (attrify name) $ xmlify paras
instance Xmlify (Tree PlainNode) where
	xmlify (Tree n ts) =
		case n of
		 PlainText t   -> xmlify t
		 PlainBreak    -> XML.br
		 PlainGroup    -> xmlify ts
		 PlainB        -> XML.b    $ xmlify ts
		 PlainCode     -> XML.code $ xmlify ts
		 PlainDel      -> XML.del  $ xmlify ts
		 PlainI        -> XML.i    $ xmlify ts
		 PlainNote{..} -> XML.note $ xmlify note_paras
		 PlainQ        -> XML.q    $ xmlify ts
		 PlainSpan{..} -> xmlCommonAttrs attrs $ XML.span $ xmlify ts
		 PlainSC       -> XML.sc   $ xmlify ts
		 PlainSub      -> XML.sub  $ xmlify ts
		 PlainSup      -> XML.sup  $ xmlify ts
		 PlainU        -> XML.u    $ xmlify ts
		 PlainEref to  -> XML.eref ! XA.to (attrify to) $ xmlify ts
		 PlainIref{..} -> XML.iref ! XA.term (attrify $ plainifyWords iref_term) $ xmlify ts
		 PlainTag{..}  -> XML.tag  $ xmlify ts
		 PlainRref{..} -> XML.rref ! XA.to (attrify rref_to) $ xmlify ts

instance Xmlify About where
	xmlify About{..} = do
		XML.about
		 !?? mayAttr XA.url about_url
		 $ do
			xmlify about_titles
			xmlify about_authors
			xmlify about_editor
			xmlify about_date
			forM_  about_tags $ XML.tag . xmlify
			xmlify about_links
			xmlify about_description
instance Xmlify Include where
	xmlify Include{..} =
		XML.include True
		 ! XA.href (attrify href)
instance Xmlify Date where
	xmlify Date{..} =
		XML.date
		 !   XA.year (attrify year)
		 !?? mayAttr XA.month month
		 !?? mayAttr XA.day day
instance Xmlify Link where
	xmlify Link{..} =
		XML.link
		 !?? mayAttr XA.name name
		 !?? mayAttr XA.rel  rel
		 !?? mayAttr XA.href href
		 $ xmlify plain
instance Xmlify Entity where
	xmlify Entity{..} =
		XML.entity
		 !?? mayAttr XA.name    entity_name
		 !?? mayAttr XA.street  entity_street
		 !?? mayAttr XA.zipcode entity_zipcode
		 !?? mayAttr XA.city    entity_city
		 !?? mayAttr XA.region  entity_region
		 !?? mayAttr XA.country entity_country
		 !?? mayAttr XA.email   entity_email
		 !?? mayAttr XA.tel     entity_tel
		 !?? mayAttr XA.fax     entity_fax
instance Xmlify Title where
	xmlify (Title t) = XML.title $ xmlify t
instance Xmlify Alias where
	xmlify Alias{..} = XML.alias $ xmlify title
instance Xmlify Reference where
	xmlify Reference{..} = XML.reference mempty -- TODO: to be coded

instance Xmlify a => Xmlify (Maybe a) where
	xmlify = foldMap xmlify
instance Xmlify a => Xmlify [a] where
	xmlify = foldMap xmlify
instance Xmlify a => Xmlify (Seq a) where
	xmlify = foldMap xmlify

xmlId :: Ident -> B.Attribute
xmlId (Ident i) = XA.id $ attrify i

xmlCommonAttrs :: CommonAttrs -> XML -> XML
xmlCommonAttrs CommonAttrs{id=ident, ..} =
	(case ident of
	 Nothing -> Fun.id
	 Just (Ident i) ->
		B.AddCustomAttribute "id" $
		B.String $ TL.unpack i) .
	case classes of
	 [] -> Fun.id
	 _ ->
		B.AddCustomAttribute "class" $
		B.String $ TL.unpack $ TL.unwords classes