{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Textphile.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 Textphile.DTC.Analyze.Index (plainifyWords)
import Textphile.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
		forM_ document_head xmlify
		xmlify document_body

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

instance Xmlify TL.Text where
	xmlify = B.toMarkup
instance Xmlify Head where
	xmlify Head{..} =
		mempty
		-- TODO: xmlify head_section
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_about
				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_ index $ \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
		 PlainAt{..}   -> (if at_back then XML.at_back else XML.at)
		                   ! XA.to (attrify at_ident) $ xmlify ts
		 PlainTag{..}  -> (if tag_back then XML.tag_back else XML.at)
		                   ! XA.to (attrify tag_ident) $ xmlify ts
		 PlainRef{..}  -> XML.ref ! XA.to (attrify ref_ident) $ xmlify ts
		 PlainPageRef{..} -> XML.page_ref
		                      ! XA.to (attrify pageRef_path)
		                      !?? mayAttr XA.at (attrify <$> pageRef_at) $
		                      xmlify ts

instance Xmlify About where
	xmlify About{..} = do
		XML.about $ do
			xmlify about_titles
			xmlify about_aliases
			forM_  about_authors xmlify
			forM_  about_dates   xmlify
			forM_  about_tags $ XML.tag . xmlify
			forM_  about_links xmlify
			xmlify about_description
			xmlify about_judgments
instance Xmlify Include where
	xmlify Include{..} =
		XML.include True
		 ! XA.href (attrify include_href)
instance Xmlify Date where
	xmlify Date{..} =
		XML.date
		 !   XA.year (attrify date_year)
		 !?? mayAttr XA.rel   date_rel
		 !?? mayAttr XA.role  date_role
		 !?? mayAttr XA.month date_month
		 !?? mayAttr XA.day   date_day
instance Xmlify Link where
	xmlify Link{..} =
		XML.link
		 !?? mayAttr XA.rel   link_rel
		 !?? mayAttr XA.role  link_role
		 !?? mayAttr XA.href  link_url
		 -- !?? mayAttr XA.type_ link_type
		 $ xmlify link_plain
instance Xmlify Entity where
	xmlify Entity{..} =
		XML.entity
		 !?? mayAttr XA.rel     entity_rel
		 !?? mayAttr XA.role    entity_role
		 !?? 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
		 $ xmlify entity_org
instance Xmlify Title where
	xmlify (Title t) = XML.title $ xmlify t
instance Xmlify Alias where
	xmlify Alias{..} =
		xmlCommonAttrs alias_attrs $
		XML.alias $
			xmlify alias_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{..} =
	(case attrs_id of
	 Nothing -> Fun.id
	 Just (Ident i) ->
		B.AddCustomAttribute "id" $
		B.String $ TL.unpack i) .
	case attrs_classes of
	 [] -> Fun.id
	 _ ->
		B.AddCustomAttribute "class" $
		B.String $ TL.unpack $ TL.unwords attrs_classes