import Control.Arrow
import Control.Arrow.ArrowIO
-import Control.Arrow.ArrowTree
import Data.Encoding
import Data.Encoding.UTF8
import Data.Generics
-> 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 -< (pageName page, source)
- attachXHtmlNs -< tree
+ -> 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, Page) XmlTree
+ -> a (PageName, (Maybe Page, Page)) XmlTree
formatSubPage env
- = proc (mainPageName, subPage)
- -> do tree <- case pageType subPage of
- MIMEType "text" "x-rakka" _
- -> do let source = decodeLazy UTF8 (pageContent subPage)
- formatWikiPage env -< (mainPageName, source)
- attachXHtmlNs -< tree
-
-
-formatWikiPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
- Environment
- -> a (PageName, String) XmlTree
-formatWikiPage env
- = proc (name, source)
+ = proc (mainPageName, (mainPage, subPage))
-> 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, (name, blocks))
- formatWikiBlocks -< (baseURI, xs)
+ 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
interpretCommandsA :: ArrowIO a =>
Environment
- -> a (InterpTable, (PageName, WikiPage)) WikiPage
-interpretCommandsA = arrIO3 . interpretCommands
+ -> a (InterpTable, (PageName, (Maybe WikiPage, WikiPage))) WikiPage
+interpretCommandsA = arrIO4 . interpretCommands
-interpretCommands :: Environment -> InterpTable -> PageName -> WikiPage -> IO WikiPage
-interpretCommands _ _ _ [] = return []
-interpretCommands env table name blocks = everywhereM' (mkM interpBlockCmd) blocks
- >>=
- everywhereM' (mkM interpInlineCmd)
+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
- , ctxTree = blocks
- , ctxStorage = envStorage env
- , ctxSysConf = envSysConf env
+ ctxPageName = name
+ , ctxMainTree = mainTree
+ , ctxTargetTree = targetTree
+ , ctxStorage = envStorage env
+ , ctxSysConf = envSysConf env
}
interpBlockCmd :: BlockElement -> IO BlockElement
everywhereM' f x = f x >>= gmapM (everywhereM' f)
-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"
- }
+wikifyParseError :: ArrowXml a => a ParseError WikiPage
+wikifyParseError
+ = proc err -> returnA -< [Preformatted [Text (show err)]]