{-# LANGUAGE
    Arrows
  , OverloadedStrings
  , TypeOperators
  , UnicodeSyntax
  , ViewPatterns
  #-}
module Rakka.Wiki.Formatter
    ( formatWikiBlocks
    )
    where
import Control.Arrow
import Control.Arrow.ArrowIf
import Control.Arrow.ArrowList
import Control.Arrow.ArrowTree
import Control.Arrow.Unicode
import qualified Data.CaseInsensitive as CS
import Data.Maybe
import Data.Monoid.Unicode
import Data.Text (Text)
import qualified Data.Text as T
import Network.URI hiding (fragment)
import Prelude.Unicode
import Rakka.Page
import Rakka.Wiki
import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.DOM.TypeDefs

formatWikiBlocks :: (ArrowXml a, ArrowChoice a) => a (URI, [BlockElement]) XmlTree
formatWikiBlocks
    = proc (baseURI, blocks)
    -> do block   <- arrL id     -< blocks
          tree    <- formatBlock -< (baseURI, block)
          attachXHtmlNS -< tree


formatElement :: (ArrowXml a, ArrowChoice a) => a (URI, Element) XmlTree
formatElement 
    = proc (baseURI, e)
    -> case e of
         Block  b -> formatBlock  -< (baseURI, b)
         Inline i -> formatInline -< (baseURI, i)

formatBlock ∷ (ArrowXml (⇝), ArrowChoice (⇝)) ⇒ (URI, BlockElement) ⇝ XmlTree
formatBlock 
    = proc (baseURI, block)
    → case block of
         Heading level text
             → formatHeading ⤙ (level, text)

         HorizontalLine
             -> eelem "hr" -< ()

         list@(List _ _)
             -> formatListElement -< (baseURI, list)

         DefinitionList list
             -> formatDefinitionList -< (baseURI, list)

         Preformatted inlines
             -> formatPreformatted -< (baseURI, inlines)
                
         Paragraph inlines
             -> formatParagraph -< (baseURI, inlines)

         Div attrs contents
             -> formatElem "div" -< (baseURI, attrs, contents)

         EmptyBlock
             -> none -< ()

         _   -> arr (error . ("formatBlock: unsupported BlockElement: " ++) . show) -< block
    where
      formatElem :: (ArrowXml a, ArrowChoice a) =>
                    String
                 -> a (URI, [Attribute], [Element]) XmlTree
      formatElem name
          = proc (baseURI, attrs, contents)
          -> ( eelem name
               += ( arrL (fst . snd)
                       >>>
                       attrFromPair
                  )
               += ( (arr fst &&& arrL (snd . snd))
                    >>>
                    formatElement
                  )
             ) -< (baseURI, (attrs, contents))


formatHeading ∷ ArrowXml (⇝) ⇒ (Int, Text) ⇝ XmlTree
formatHeading 
    = proc (level, T.unpack → text)
    -> mkelem ("h" ⊕ show level)
       [ sattr "id" text ]
       [ txt text        ] ⤛ ()


formatListElement :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree
formatListElement 
    = proc (baseURI, list)
    -> let tag = case listType list of
                   Bullet   -> "ul"
                   Numbered -> "ol"
       in
         ( eelem tag
           += ( (constA baseURI &&& constL (listItems list))
                >>>
                formatListItem
              )
         ) -<< ()
      where
        formatListItem :: (ArrowXml a, ArrowChoice a) => a (URI, ListItem) XmlTree
        formatListItem 
            = proc (baseURI, item)
            -> eelem "li"
               += ( (arr fst &&& arrL snd)
                    >>>
                    formatElement
                  ) -< (baseURI, item)


formatDefinitionList :: (ArrowXml a, ArrowChoice a) => a (URI, [Definition]) XmlTree
formatDefinitionList 
    = proc (baseURI, list)
    -> ( eelem "dl"
         += ( (arr fst &&& arrL snd)
              >>>
              formatDefinition
            )
       ) -< (baseURI, list)
    where
      formatDefinition :: (ArrowXml a, ArrowChoice a) => a (URI, Definition) XmlTree
      formatDefinition 
          = proc (baseURI, def)
          -> ( eelem "dt"
               += ( (arr fst &&& arrL (defTerm . snd))
                    >>>
                    formatInline
                  )
               <+>
               eelem "dd"
               += ( (arr fst &&& arrL (defDesc . snd))
                    >>>
                    formatInline
                  )
             ) -< (baseURI, def)


formatPreformatted :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
formatPreformatted
    = eelem "pre"
      += ( (arr fst &&& arrL snd)
           >>>
           formatInline
         )


formatParagraph :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
formatParagraph 
    = eelem "p"
      += ( (arr fst &&& arrL snd)
           >>>
           formatInline
         )

formatInline ∷ (ArrowXml (⇝), ArrowChoice (⇝)) ⇒ (URI, InlineElement) ⇝ XmlTree
formatInline 
    = proc (baseURI, i)
    → case i of
         Text text
             → mkText ⤙ T.unpack text

         Italic contents
             -> formatElem "i" -< (baseURI, [], contents)

         Bold contents
             -> formatElem "b" -< (baseURI, [], contents)

         link@(ObjectLink _ _)
             -> formatObjectLink -< (baseURI, link)

         link@(PageLink _ _ _)
             -> formatPageLink -< (baseURI, link)

         link@(ExternalLink _ _)
             -> formatExternalLink -< link

         LineBreak attrs
             -> formatElem "br" -< (baseURI, attrs, [])

         Span attrs contents
             -> formatElem "span" -< (baseURI, attrs, contents)

         img@(Image _ _)
             -> formatImage -< (baseURI, img)

         Anchor attrs contents
             -> formatElem "a" -< (baseURI, attrs, contents)

         Input attrs
             -> formatElem "input" -< (baseURI, attrs, [])

         EmptyInline
             -> none -< ()

         _   -> arr (error . ("formatInline: unsupported InlineElement: " ++) . show) -< i
    where
      formatElem ∷ (ArrowXml (⇝), ArrowChoice (⇝)) ⇒
                    String
                 → (URI, [Attribute], [InlineElement]) ⇝ XmlTree
      formatElem name
          = proc (baseURI, attrs, contents)
          → ( eelem name
               += ( arrL (fst ∘ snd)
                    ⋙
                    attrFromPair
                  )
               += ( (arr fst &&& arrL (snd . snd))
                    ⋙
                    formatInline
                  )
             ) ⤙ (baseURI, (attrs, contents))

attrFromPair ∷ ArrowXml (⇝) ⇒ Attribute ⇝ XmlTree
attrFromPair = proc (T.unpack ∘ CS.original → name, T.unpack → value)
             → attr name (txt value) ⤛ ()

formatObjectLink ∷ ArrowXml (⇝) ⇒ (URI, InlineElement) ⇝ XmlTree
formatObjectLink 
    = proc (baseURI, ObjectLink page text)
    → let uri   = mkObjectURI baseURI page
          label = fromMaybe ("{" ⊕ page ⊕ "}") text
      in
        mkAnchor ⤙ (uri, label)

formatPageLink ∷ ArrowXml (⇝) ⇒ (URI, InlineElement) ⇝ XmlTree
formatPageLink 
    = proc (baseURI, PageLink page fragment text)
    → let uri    = case (page, fragment) of
                      (Just  x, Just  y) → mkPageFragmentURI baseURI x y
                      (Just  x, Nothing) → mkPageURI baseURI x
                      (Nothing, Just  y) → mkFragmentURI y
                      _                  → (⊥)
          dLabel = fromMaybe (∅) page ⊕ maybe (∅) (T.cons '#') fragment
          label  = fromMaybe dLabel text
      in
        mkAnchor ⤙ (uri, label)

formatImage ∷ ArrowXml (⇝) ⇒ (URI, InlineElement) ⇝ XmlTree
formatImage = proc (baseURI, Image src alt)
            → let uri  = case src of
                           Left  u    → u
                           Right name → mkObjectURI baseURI name
                  href = uriToString id uri ""
              in
                ( eelem "img"
                  += sattr "src" href
                  += ( case alt of
                         Just x  → sattr "alt" (T.unpack x)
                         Nothing → none
                     )
                ) ⤛ ()


formatExternalLink ∷ ArrowXml (⇝) ⇒ InlineElement ⇝ XmlTree
formatExternalLink 
    = proc (ExternalLink uri text)
    → let href  = uriToString id uri ""
          label = fromMaybe (T.pack href) text
      in
        mkAnchor -< (uri, label)

mkAnchor ∷ ArrowXml (⇝) ⇒ (URI, Text) ⇝ XmlTree
mkAnchor = eelem "a"
           += attr "href" (arr (flip (uriToString id) "" ∘ fst) ⋙ mkText)
           += (arr (T.unpack ∘ snd) ⋙ mkText)

attachXHtmlNS ∷ ArrowXml (⇝) ⇒ XmlTree ⇝ XmlTree
attachXHtmlNS = processTopDown (changeQName attach `when` isElem)
    where
      attach ∷ QName → QName
      attach = setNamespaceUri' (newXName "http://www.w3.org/1999/xhtml")