module Rakka.Wiki.Engine
( formatPage
+ , formatSubPage
)
where
import Control.Arrow
import Control.Arrow.ArrowIO
-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
-> 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)
+ -> do BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
+ wiki <- wikifyPage env -< page
+ xs <- interpretCommandsA env -< (pageName page, (Just (page, 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) -< ()
+ mainWiki <- case mainPage of
+ Just page
+ -> do wiki <- wikifyPage env -< page
+ returnA -< Just (page, wiki)
+ Nothing
+ -> returnA -< Nothing
+ subWiki <- wikifyPage env -< subPage
+ xs <- interpretCommandsA env -< (mainPageName, (mainWiki, subWiki))
+ formatWikiBlocks -< (baseURI, xs)
+
+
+wikifyPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
+ Environment
+ -> a Page WikiPage
+wikifyPage env
+ = proc page
+ -> case pageType page of
+ MIMEType "text" "x-rakka" _
+ -> do let source = decodeLazy UTF8 (pageContent page)
+ parser = wikiPage tableToFunc
+
+ 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)
+ tableToFunc :: String -> Maybe CommandType
+ tableToFunc name
+ = fmap commandType (M.lookup name (envInterpTable env))
interpretCommandsA :: ArrowIO a =>
Environment
- -> a (InterpTable, (Maybe Page, WikiPage)) WikiPage
+ -> a (PageName, (Maybe (Page, WikiPage), WikiPage)) WikiPage
interpretCommandsA = arrIO3 . interpretCommands
-interpretCommands :: Environment -> InterpTable -> Maybe Page -> WikiPage -> IO WikiPage
-interpretCommands _ _ _ [] = return []
-interpretCommands env table page blocks = mapM interpBlock blocks
+interpretCommands :: Environment -> PageName -> Maybe (Page, WikiPage) -> WikiPage -> IO WikiPage
+interpretCommands _ _ _ [] = return []
+interpretCommands env name mainPageAndTree targetTree
+ = everywhereM' (mkM interpBlockCmd) targetTree
+ >>=
+ everywhereM' (mkM interpInlineCmd)
where
ctx :: InterpreterContext
ctx = InterpreterContext {
- ctxPage = page
- , ctxTree = blocks
- , ctxStorage = envStorage env
- , ctxSysConf = envSysConf env
- }
-
- 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
+ ctxPageName = name
+ , ctxMainPage = fmap fst mainPageAndTree
+ , ctxMainTree = fmap snd mainPageAndTree
+ , 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) (envInterpTable env) of
Nothing
-> fail ("no such interpreter: " ++ bCmdName cmd)
Just interp
-> bciInterpret interp ctx cmd
- >>=
- 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
+
+
+ interpInlineCmd :: InlineElement -> IO InlineElement
+ interpInlineCmd (InlineCmd cmd) = interpInlineCmd' cmd
+ interpInlineCmd others = return others
+
+ interpInlineCmd' :: InlineCommand -> IO InlineElement
+ interpInlineCmd' cmd
+ = case M.lookup (iCmdName cmd) (envInterpTable env) of
Nothing
-> fail ("no such interpreter: " ++ iCmdName cmd)
Just interp
-> iciInterpret interp ctx cmd
- >>=
- interpInline
-formatParseError :: ArrowXml a => a ParseError XmlTree
-formatParseError
- = proc err -> (eelem "pre" += txt (show err)) -<< ()
+-- Perform monadic transformation in top-down order.
+everywhereM' :: Monad m => GenericM m -> GenericM m
+everywhereM' f x = f x >>= gmapM (everywhereM' f)
-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 -< [Div [("class", "error")]
+ [ Preformatted [Text (show err)] ]]
projects / Rakka.git / blobdiff