module Rakka.Wiki.Engine
( formatPage
+ , formatSubPage
)
where
import Control.Arrow.ArrowTree
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
= proc page
-> do tree <- case pageType page of
MIMEType "text" "x-rakka" _
- -> formatWikiPage env -< page
+ -> do let source = decodeLazy UTF8 (pageContent page)
+ formatWikiPage env -< (Just page, source)
+ attachXHtmlNs -< tree
+
+
+formatSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
+ Environment
+ -> a (Page, Page) XmlTree
+formatSubPage env
+ = proc (mainPage, subPage)
+ -> do tree <- case pageType subPage of
+ MIMEType "text" "x-rakka" _
+ -> do let source = decodeLazy UTF8 (pageContent subPage)
+ formatWikiPage env -< (Just mainPage, source)
attachXHtmlNs -< tree
formatWikiPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
Environment
- -> a Page XmlTree
+ -> a (Maybe Page, String) XmlTree
formatWikiPage env
- = proc page
- -> do let source = decodeLazy UTF8 (pageContent page)
- case parse wikiPage "" source of
+ = 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 BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
- formatWikiBlocks -< (baseURI, 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 = everywhereM' (mkM interpBlockCmd) blocks
+ >>=
+ everywhereM' (mkM interpInlineCmd)
+ where
+ ctx :: InterpreterContext
+ ctx = InterpreterContext {
+ ctxPage = page
+ , ctxTree = blocks
+ , 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)
formatParseError :: ArrowXml a => a ParseError XmlTree