module Rakka.Wiki.Engine
    ( formatPage
    )
    where

import           Control.Arrow
import           Control.Arrow.ArrowIO
import           Control.Arrow.ArrowTree
import           Data.Encoding
import           Data.Encoding.UTF8
import qualified Data.Map as M
import           Network.HTTP.Lucu
import           Rakka.Environment
import           Rakka.Page
import           Rakka.SystemConfig
import           Rakka.Wiki
import           Rakka.Wiki.Parser
import           Rakka.Wiki.Formatter
import           Rakka.Wiki.Interpreter
import           Text.ParserCombinators.Parsec
import           Text.XML.HXT.Arrow.XmlArrow
import           Text.XML.HXT.DOM.TypeDefs


formatPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
              Environment
           -> a Page XmlTree
formatPage env
    = proc page
    -> do tree <- case pageType page of
                    MIMEType "text" "x-rakka" _
                        -> do let source = decodeLazy UTF8 (pageContent page)
                              formatWikiPage env -< (Just page, source)
          attachXHtmlNs -< tree


formatWikiPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
                  Environment
               -> a (Maybe Page, String) XmlTree
formatWikiPage env
    = proc (page, source)
    -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
          interpTable     <- getInterpTableA env -< ()

          let parser = wikiPage (tableToFunc interpTable)

          case parse parser "" source of
            Left  err
                -> formatParseError -< err

            Right blocks
                -> do xs <- interpretCommandsA env -< (interpTable, (page, blocks))
                      formatWikiBlocks -< (baseURI, xs)
    where
      tableToFunc :: InterpTable -> String -> Maybe CommandType
      tableToFunc table name
          = fmap commandType (M.lookup name table)


interpretCommandsA :: ArrowIO a =>
                      Environment
                   -> a (InterpTable, (Maybe Page, WikiPage)) WikiPage
interpretCommandsA = arrIO3 . interpretCommands


interpretCommands :: Environment -> InterpTable -> Maybe Page -> WikiPage -> IO WikiPage
interpretCommands _   _     _    []     = return []
interpretCommands env table page blocks = mapM interpBlock blocks
    where
      interpBlock :: BlockElement -> IO BlockElement
      interpBlock (List list)           = interpList list >>= return . List
      interpBlock (DefinitionList defs) = mapM interpDefinition defs >>= return . DefinitionList
      interpBlock (Preformatted xs)     = mapM interpInline xs >>= return . Preformatted
      interpBlock (Paragraph xs)        = mapM interpInline xs >>= return . Paragraph
      interpBlock (Div attrs xs)        = mapM interpBlock xs >>= return . Div attrs
      interpBlock (BlockCmd cmd)        = interpBlockCmd cmd
      interpBlock others                = return others

      interpList :: ListElement -> IO ListElement
      interpList list = do items <- mapM interpListItem (listItems list)
                           return $ list { listItems = items }

      interpListItem :: ListItem -> IO ListItem
      interpListItem []                  = return []
      interpListItem ((Left  nested):xs) = do x  <- interpList nested >>= return . Left
                                              xs <- interpListItem xs
                                              return (x:xs)
      interpListItem ((Right inline):xs) = do x  <- interpInline inline >>= return . Right
                                              xs <- interpListItem xs
                                              return (x:xs)

      interpDefinition :: Definition -> IO Definition
      interpDefinition def = do term <- mapM interpInline (defTerm def)
                                desc <- mapM interpInline (defDesc def)
                                return $ def { defTerm = term, defDesc = desc }

      interpBlockCmd :: BlockCommand -> IO BlockElement
      interpBlockCmd cmd
          = case M.lookup (bCmdName cmd) table of
              Nothing
                  -> fail ("no such interpreter: " ++ bCmdName cmd)

              Just interp
                  -> bciInterpret interp cmd page (envStorage env) (envSysConf env)
                     >>=
                     interpBlock

      interpInline :: InlineElement -> IO InlineElement
      interpInline (Italic xs)     = mapM interpInline xs >>= return . Italic
      interpInline (Bold xs )      = mapM interpInline xs >>= return . Bold
      interpInline (Span attrs xs) = mapM interpInline xs >>= return . Span attrs
      interpInline (InlineCmd cmd) = interpInlineCmd cmd
      interpInline others          = return others

      interpInlineCmd :: InlineCommand -> IO InlineElement
      interpInlineCmd cmd
          = case M.lookup (iCmdName cmd) table of
              Nothing
                  -> fail ("no such interpreter: " ++ iCmdName cmd)

              Just interp
                  -> iciInterpret interp cmd page (envStorage env) (envSysConf env)
                     >>=
                     interpInline


formatParseError :: ArrowXml a => a ParseError XmlTree
formatParseError 
    = proc err -> (eelem "pre" += txt (show err)) -<< ()


attachXHtmlNs :: ArrowXml a => a XmlTree XmlTree
attachXHtmlNs = processBottomUp (changeQName attach')
    where
      attach' :: QName -> QName
      attach' qn = qn {
                     namePrefix   = "xhtml"
                   , namespaceUri = "http://www.w3.org/1999/xhtml"
                   }