module Rakka.Wiki.Engine
    ( formatPage
    , formatSubPage
    )
    where

import           Control.Arrow
import           Control.Arrow.ArrowIO
import           Data.Encoding
import           Data.Encoding.UTF8
import           Data.Generics
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 BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
          interpTable     <- getInterpTableA env -< ()
          wiki            <- wikifyPage env -< (interpTable, page)
          xs              <- interpretCommandsA env -< (interpTable, (pageName page, (Just wiki, wiki)))
          formatWikiBlocks -< (baseURI, xs)


formatSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
                 Environment
              -> a (PageName, (Maybe Page, Page)) XmlTree
formatSubPage env
    = proc (mainPageName, (mainPage, subPage))
    -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
          interpTable     <- getInterpTableA env -< ()
          mainWiki        <- case mainPage of
                               Just page
                                   -> do wiki <- wikifyPage env -< (interpTable, page)
                                         returnA -< Just wiki
                               Nothing
                                   -> returnA -< Nothing
          subWiki        <- wikifyPage env -< (interpTable, subPage)
          xs             <- interpretCommandsA env -< (interpTable, (mainPageName, (mainWiki, subWiki)))
          formatWikiBlocks -< (baseURI, xs)


wikifyPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
                 Environment
              -> a (InterpTable, Page) WikiPage
wikifyPage env
    = proc (interpTable, page)
    -> case pageType page of
         MIMEType "text" "x-rakka" _
             -> do let source = decodeLazy UTF8 (pageContent page)
                       parser = wikiPage (tableToFunc interpTable)

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

                     Right xs
                         -> returnA -< xs
    where
      tableToFunc :: InterpTable -> String -> Maybe CommandType
      tableToFunc table name
          = fmap commandType (M.lookup name table)


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


interpretCommands :: Environment -> InterpTable -> PageName -> Maybe WikiPage -> WikiPage -> IO WikiPage
interpretCommands _   _     _    _        []         = return []
interpretCommands env table name mainTree targetTree
    = everywhereM' (mkM interpBlockCmd) targetTree
      >>=
      everywhereM' (mkM interpInlineCmd)
    where
      ctx :: InterpreterContext
      ctx = InterpreterContext {
              ctxPageName   = name
            , ctxMainTree   = mainTree
            , ctxTargetTree = targetTree
            , ctxStorage    = envStorage env
            , ctxSysConf    = envSysConf env
            }

      interpBlockCmd :: BlockElement -> IO BlockElement
      interpBlockCmd (BlockCmd cmd) = interpBlockCmd' cmd
      interpBlockCmd others         = return others

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

              Just interp
                  -> bciInterpret interp ctx cmd


      interpInlineCmd :: InlineElement -> IO InlineElement
      interpInlineCmd (InlineCmd cmd) = interpInlineCmd' cmd
      interpInlineCmd 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 ctx cmd


-- Perform monadic transformation in top-down order.
everywhereM' :: Monad m => GenericM m -> GenericM m
everywhereM' f x = f x >>= gmapM (everywhereM' f)


wikifyParseError :: ArrowXml a => a ParseError WikiPage
wikifyParseError 
    = proc err -> returnA -< [Preformatted [Text (show err)]]