{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Hdoc.DTC.Sym where

import Control.Applicative (Applicative(..), (<$>), (<$))
import Control.Arrow (second)
import Control.Monad (void)
import Data.Bool (Bool(..))
import Data.Default.Class (Default(..))
import Data.Foldable (concat)
import Data.Monoid (Monoid(..))
import Data.Function (($), (.), flip)
import Data.Maybe (Maybe(..))
import Data.Semigroup (Semigroup(..))
import Data.TreeSeq.Strict (Tree(..), tree0)
import Symantic.RNC hiding (element, attribute)
import Text.Blaze.DTC (xmlns_dtc)
import qualified Data.HashMap.Strict as HM
import qualified Data.Text.Lazy as TL
import qualified Symantic.RNC as RNC
import qualified Symantic.XML as XML

import Hdoc.RNC as RNC
import Hdoc.XML
import qualified Hdoc.DTC.Analyze.Index as Index
import qualified Hdoc.DTC.Document as DTC
import qualified Hdoc.TCT.Cell as TCT
import qualified Hdoc.XML as XML

element :: RNC.Sym_RNC repr => XML.NCName -> repr a -> repr a
element = RNC.element . XML.QName xmlns_dtc
attribute :: RNC.Sym_RNC repr => XML.NCName -> repr a -> repr a
attribute = RNC.attribute . XML.QName ""

-- Class 'Sym_DTC'
-- | Use a symantic (tagless final) class to encode
-- both the parsing and the schema of DTC,
-- when repr is respectively instanciated
-- on 'DTC.Parser', 'RNC.NS' or 'RNC.Writer'.
class (Sym_RNC repr, Sym_RNC_Extra repr) => Sym_DTC repr where
	positionXML      :: repr XML.Pos
	locationTCT      :: repr TCT.Location
	document         :: repr DTC.Document
	
	head             :: repr DTC.Head
	body             :: repr DTC.Body
	section          :: repr DTC.Section
	about            :: repr DTC.About
	include          :: repr DTC.Include
	
	block            :: repr DTC.Block
	blockBreak       :: repr DTC.Block
	blockToC         :: repr DTC.Block
	blockToF         :: repr DTC.Block
	blockIndex       :: repr DTC.Block
	blockAside       :: repr DTC.Block
	blockFigure      :: repr DTC.Block
	blockReferences  :: repr DTC.Block
	blockJudges      :: repr DTC.Block
	blockGrades      :: repr DTC.Block
	reference        :: repr DTC.Reference
	
	para             :: repr DTC.Para
	paraItem         :: repr DTC.ParaItem
	paraItems        :: repr DTC.Para
	
	plain            :: repr DTC.Plain
	plainNode        :: repr (Tree DTC.PlainNode)
	
	commonAttrs      :: repr DTC.CommonAttrs
	ident            :: repr Ident
	title            :: repr DTC.Title
	name             :: repr DTC.Name
	url              :: repr URL
	path             :: repr DTC.FilePath
	to               :: repr Ident
	id               :: repr Ident
	class_           :: repr [TL.Text]
	rel              :: repr DTC.Name
	role             :: repr DTC.Name
	
	author           :: repr DTC.Entity
	date             :: repr DTC.Date
	entity           :: repr DTC.Entity
	link             :: repr DTC.Link
	serie            :: repr DTC.Serie
	alias            :: repr DTC.Alias
	judgment         :: repr DTC.Judgment
	choice_          :: repr DTC.Choice
	opinion          :: repr DTC.Opinion
	judges           :: repr DTC.Judges
	judge            :: repr DTC.Judge
	grade            :: repr DTC.Grade
	
	document = rule "document" $
		DTC.Document
		 <$> optional head
		 <*> body
	head = rule "head" $
		element "head" $
		DTC.Head
		 <$> section
		 <*> body
	body = rule "body" $
		manySeq $
			choice
			 [ element "section" $ Tree . DTC.BodySection <$> section <*> body
			 , tree0 . DTC.BodyBlock <$> block
			 ]
	section = rule "section" $
		runPermutation $
		(\section_posXML section_locTCT section_attrs abouts ->
			DTC.Section{section_about=mconcat abouts, ..})
		 <$$> positionXML
		 <||> locationTCT
		 <||> commonAttrs
		 <|*> about
	about = rule "about" $
		element "about" $
		runPermutation $
		DTC.About
		 <$*> title
		 <|*> alias
		 <|*> author
		 <|*> date
		 <|*> element "tag" text
		 <|*> link
		 <|*> serie
		 <|*> element "description" para
		 <|*> judgment
	title = rule "title" $ DTC.Title <$> element "title" plain
	name  = rule "name"  $ DTC.Name <$> text
	url   = rule "url"   $ URL <$> text
	path  = rule "path"  $ TL.unpack <$> text
	ident = rule "ident" $ Ident <$> text
	to    = rule "to"    $ attribute "to" ident
	commonAttrs =
		rule "commonAttrs" $
		runPermutation $
		DTC.CommonAttrs
		 <$?> (def, Just <$> id)
		 <|?> (def, class_)
	id      = rule "id"    $ attribute "id" ident
	class_  = rule "class" $ attribute "class" $ TL.words <$> text
	rel     = rule "rel"   $ attribute "rel" name
	role    = rule "role"  $ attribute "role" name
	
	date = rule "date" $
		element "date" $
		runPermutation $
		DTC.Date
		 <$?> (def, rel)
		 <|?> (def, role)
		 <||> attribute "year" int
		 <|?> (def, Just <$> attribute "month" nat1)
		 <|?> (def, Just <$> attribute "day"   nat1)
	include =
		rule "include"  $
		element "include" $
		runPermutation $
		DTC.Include
		 <$?> (def, attribute "href" path)
	block = rule "block" $
		choice
		 [ DTC.BlockPara <$> para
		 , blockBreak
		 , blockToC
		 , blockToF
		 , blockIndex
		 , blockAside
		 , blockFigure
		 , blockReferences
		 , blockJudges
		 , blockGrades
		 {-
		 , anyElem $ \n@XmlName{..} ->
				case xmlNameSpace of
				 "" -> figure n
		 -}
		 ]
	blockBreak = rule "break" $
		element "break" $
		DTC.BlockBreak
		 <$> commonAttrs
	blockToC =
		rule "blockToC" $
		element "toc" $
		DTC.BlockToC
		 <$> positionXML
		 <*> commonAttrs
		 <*> optional (attribute "depth" nat)
	blockToF =
		rule "blockToF" $
		element "tof" $
		DTC.BlockToF
		 <$> positionXML
		 <*> commonAttrs
		 <*> option [] (
			element "ul" $
				many $
					element "li" $
						element "para" text)
	blockIndex =
		rule "blockIndex" $
		element "index" $
		DTC.BlockIndex
		 <$> positionXML
		 <*> commonAttrs
		 <*> option [] (
			element "ul" $
				many $
					element "li" $
						element "para" $
							indexWords
		 )
		where
		indexWords =
			(concat <$>) $
			many $
				(Index.wordify <$>) . TL.lines <$> text
		{-
		indexAt =
		indexTag =
		-}
	blockAside =
		rule "blockAside" $
		element "aside" $
		DTC.BlockAside
		 <$> positionXML
		 <*> commonAttrs
		 <*> many block
	blockFigure =
		rule "blockFigure" $
		element "figure" $
		DTC.BlockFigure
		 <$> positionXML
		 <*> attribute "type" text
		 <*> commonAttrs
		 <*> optional title
		 <*> many para
	blockReferences =
		rule "blockReferences" $
		element "references" $
		DTC.BlockReferences
		 <$> positionXML
		 <*> commonAttrs
		 <*> many reference
	blockJudges = rule "blockJudges" $ DTC.BlockJudges <$> judges
	blockGrades =
		rule "blockGrades" $
		element "grades" $
		DTC.BlockGrades
		 <$> positionXML
		 <*> commonAttrs
		 <*> some grade
	grade =
		rule "grade" $
		element "grade" $
		DTC.Grade
		 <$> positionXML
		 <*> attribute "name" name
		 <*> attribute "color" text
		 <*> option False (True <$ attribute "default" text)
		 <*> optional title
	
	para = rule "para" $
		paraItems <|>             -- within  a <para>
		DTC.ParaItem <$> paraItem -- without a <para>
	paraItem =
		rule "paraItem" $
		choice
		 [ element "ol"      $ DTC.ParaOL <$> many (element "li" $ DTC.ListItem <$> attribute "name" name <*> many para)
		 , element "ul"      $ DTC.ParaUL <$> many (element "li" $ many para)
		 , element "artwork" $ DTC.ParaArtwork <$> attribute "type" text <*> text
		 , element "quote"   $ DTC.ParaQuote   <$> attribute "type" text <*> many para
		 , DTC.ParaPlain <$> someSeq plainNode
		 , DTC.ParaComment <$> comment
		 , DTC.ParaJudgment <$> judgment
		 ]
	paraItems =
		rule "paraItems" $
		element "para" $
			DTC.ParaItems
			 <$> positionXML
			 <*> commonAttrs
			 <*> many paraItem
	plain = rule "plain" $ manySeq plainNode
	plainNode =
		rule "plainNode" $
		choice
		 [ tree0 . DTC.PlainText <$> text
		 , element "br"   $ tree0   DTC.PlainBreak <$ empty
		 , element "b"    $ Tree    DTC.PlainB     <$> plain
		 , element "code" $ Tree    DTC.PlainCode  <$> plain
		 , element "del"  $ Tree    DTC.PlainDel   <$> plain
		 , element "i"    $ Tree    DTC.PlainI     <$> plain
		 , element "q"    $ Tree    DTC.PlainQ     <$> plain
		 , element "sc"   $ Tree    DTC.PlainSC    <$> plain
		 , element "span" $ Tree .  DTC.PlainSpan  <$> commonAttrs <*> plain
		 , element "sub"  $ Tree    DTC.PlainSub   <$> plain
		 , element "sup"  $ Tree    DTC.PlainSup   <$> plain
		 , element "u"    $ Tree    DTC.PlainU     <$> plain
		 , element "note" $ tree0 . DTC.PlainNote  <$> many para
		 , element "iref" $ Tree .  DTC.PlainIref . Index.wordify <$> attribute "to" text <*> plain
		 , element "eref" $ Tree .  DTC.PlainEref <$> attribute "to" url <*> plain
		 , element "tag"      $ tree0 <$> (DTC.PlainTag <$> locationTCT <*> positionXML <*> to <*> pure False)
		 , element "tag-back" $ tree0 <$> (DTC.PlainTag <$> locationTCT <*> positionXML <*> to <*> pure True )
		 , element "at"       $ tree0 <$> (DTC.PlainAt  <$> locationTCT <*> positionXML <*> to <*> pure False)
		 , element "at-back"  $ tree0 <$> (DTC.PlainAt  <$> locationTCT <*> positionXML <*> to <*> pure True )
		 , element "ref" $
			Tree
			 <$> (DTC.PlainRef
				 <$> locationTCT
				 <*> positionXML
				 <*> to
			 ) <*> plain
		 , element "page-ref" $
			Tree
			 <$> (DTC.PlainPageRef
				 <$> locationTCT
				 <*> positionXML
				 <*> attribute "to" text
				 <*> optional (attribute "at" ident)
			 ) <*> plain
		 ]
	{-
	header =
		rule "header" $
		anyElem $ \n ->
			DTC.Header (XML.nameLocal n)
			 <$> plain
	-}
	author = rule "author" $ element "author" entity
	entity = rule "entity" $
		runPermutation $
		DTC.Entity
		 <$?> (def, rel)
		 <|?> (def, role)
		 <|?> (def, attribute "name"    text)
		 <|?> (def, attribute "street"  text)
		 <|?> (def, attribute "zipcode" text)
		 <|?> (def, attribute "city"    text)
		 <|?> (def, attribute "region"  text)
		 <|?> (def, attribute "country" text)
		 <|?> (def, attribute "email"   text)
		 <|?> (def, attribute "tel"     text)
		 <|?> (def, attribute "fax"     text)
		 <|?> (def, Just <$> attribute "url" url)
		 <|*> element "org" entity
	serie = rule "serie" $
		element "serie" $
		runPermutation $
		DTC.Serie
		 <$?> (def, attribute "name" name)
		 <|?> (def, attribute "id" text)
	link = rule "link" $
		element "link" $
		runPermutation $
		DTC.Link
		 <$?> (def, rel)
		 <|?> (def, role)
		 <|?> (def, attribute "url" url)
		 <|?> (def, someSeq plainNode)
	alias = rule "alias" $
		element "alias" $
		DTC.Alias
		 <$> commonAttrs
		 <*> title
	reference = rule "reference" $
		element "reference" $
		DTC.Reference
		 <$> positionXML
		 <*> locationTCT
		 <*> id
		 <*> about
	
	judgment =
		rule "judgment" $
		element "judgment" $
		attrs
		 <*> many choice_
		where
		attrs =
			runPermutation $
			DTC.Judgment def -- def def
			 <$$> positionXML
			 <||> locationTCT
			 <||> attribute "judges" ident
			 <||> attribute "grades" ident
			 <|?> (def, Just <$> attribute "importance" rationalPositive)
			 <|?> (def, Just <$> attribute "hide" bool)
			 -- <|?> (def, Just <$> attribute "importance" (pure 0))
			 <|?> (def, Just <$> title)
	choice_ =
		rule "choice" $
		element "choice" $
		DTC.Choice
		 <$> locationTCT
		 <*> positionXML
		 <*> optional title
		 <*> many opinion
	opinion =
		rule "opinion" $
		element "opinion" $
		(runPermutation $ DTC.Opinion
		 <$$> locationTCT
		 <||> positionXML
		 <|?> (def, attribute "judge" name)
		 <|?> (def, attribute "grade" name)
		 <|?> (def, Just <$> attribute "default" name)
		 <|?> (def, Just <$> attribute "importance" rationalPositive))
		 -- <|?> (def, Just <$> attribute "importance" (pure 0)))
		 <*> optional title
	judges =
		rule "judges" $
		element "judges" $
		DTC.Judges
		 <$> locationTCT
		 <*> positionXML
		 <*> commonAttrs
		 <*> judgesByName
		where
		judgesByName =
			HM.fromListWith (flip (<>)) .
			((\j@DTC.Judge{..} -> (judge_name, pure j)) <$>)
			 <$> some judge
	judge =
		rule "judge" $
		element "judge" $
		DTC.Judge
		 <$> locationTCT
		 <*> positionXML
		 <*> attribute "name" name
		 <*> optional title
		 <*> defaultGrades
		where
		defaultGrades =
			HM.fromListWith (flip (<>)) .
			(second pure <$>)
			 <$> many defaultGrade
		defaultGrade =
			rule "default" $
			element "default" $
			(,)
			 <$> attribute "grades" ident
			 <*> attribute "grade" (DTC.Name <$> text)

instance Sym_DTC RNC.NS where
	positionXML = mempty
	locationTCT = mempty
instance Sym_DTC RNC.Writer where
	positionXML = RNC.writeText ""
	locationTCT = RNC.writeText ""

-- | RNC schema for DTC
schema :: forall repr. Sym_DTC repr => [repr ()]
schema =
 [ void $ RNC.namespace Nothing xmlns_dtc
  
 , void $ document
 , void $ about
 , void $ author
 , void $ date
 , void $ entity
 , void $ link
 , void $ serie
 , void $ alias
 , void $ judgment
 , void $ choice_
 , void $ opinion
 , void $ judges
 , void $ judge
 , void $ grade
  
 , void $ head
 , void $ body
 , void $ section
 , void $ include
  
 , void $ block
 , void $ blockToC
 , void $ blockToF
 , void $ blockIndex
 , void $ blockFigure
 , void $ blockReferences
 , void $ reference
  
 , void $ para
 , void $ paraItem
 , void $ paraItems
  
 , void $ plain
 , void $ plainNode
  
 , void $ commonAttrs
 , void $ ident
 , void $ title
 , void $ name
 , void $ url
 , void $ path
 , void $ to
 , void $ id
 , void $ class_
 , void $ rel
 ]