1 module Rakka.Wiki.Engine
8 import Control.Arrow.ArrowIO
9 import Control.Arrow.ArrowTree
11 import Data.Encoding.UTF8
13 import qualified Data.Map as M
14 import Network.HTTP.Lucu
15 import Rakka.Environment
17 import Rakka.SystemConfig
19 import Rakka.Wiki.Parser
20 import Rakka.Wiki.Formatter
21 import Rakka.Wiki.Interpreter
22 import Text.ParserCombinators.Parsec
23 import Text.XML.HXT.Arrow.XmlArrow
24 import Text.XML.HXT.DOM.TypeDefs
27 formatPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
32 -> do tree <- case pageType page of
33 MIMEType "text" "x-rakka" _
34 -> do let source = decodeLazy UTF8 (pageContent page)
35 formatWikiPage env -< (pageName page, source)
39 formatSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
41 -> a (PageName, Page) XmlTree
43 = proc (mainPageName, subPage)
44 -> do tree <- case pageType subPage of
45 MIMEType "text" "x-rakka" _
46 -> do let source = decodeLazy UTF8 (pageContent subPage)
47 formatWikiPage env -< (mainPageName, source)
51 formatWikiPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
53 -> a (PageName, String) XmlTree
56 -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
57 interpTable <- getInterpTableA env -< ()
59 let parser = wikiPage (tableToFunc interpTable)
61 case parse parser "" source of
63 -> formatParseError -< err
66 -> do xs <- interpretCommandsA env -< (interpTable, (name, blocks))
67 formatWikiBlocks -< (baseURI, xs)
69 tableToFunc :: InterpTable -> String -> Maybe CommandType
70 tableToFunc table name
71 = fmap commandType (M.lookup name table)
74 interpretCommandsA :: ArrowIO a =>
76 -> a (InterpTable, (PageName, WikiPage)) WikiPage
77 interpretCommandsA = arrIO3 . interpretCommands
80 interpretCommands :: Environment -> InterpTable -> PageName -> WikiPage -> IO WikiPage
81 interpretCommands _ _ _ [] = return []
82 interpretCommands env table name blocks = everywhereM' (mkM interpBlockCmd) blocks
84 everywhereM' (mkM interpInlineCmd)
86 ctx :: InterpreterContext
87 ctx = InterpreterContext {
90 , ctxStorage = envStorage env
91 , ctxSysConf = envSysConf env
94 interpBlockCmd :: BlockElement -> IO BlockElement
95 interpBlockCmd (BlockCmd cmd) = interpBlockCmd' cmd
96 interpBlockCmd others = return others
98 interpBlockCmd' :: BlockCommand -> IO BlockElement
100 = case M.lookup (bCmdName cmd) table of
102 -> fail ("no such interpreter: " ++ bCmdName cmd)
105 -> bciInterpret interp ctx cmd
108 interpInlineCmd :: InlineElement -> IO InlineElement
109 interpInlineCmd (InlineCmd cmd) = interpInlineCmd' cmd
110 interpInlineCmd others = return others
112 interpInlineCmd' :: InlineCommand -> IO InlineElement
114 = case M.lookup (iCmdName cmd) table of
116 -> fail ("no such interpreter: " ++ iCmdName cmd)
119 -> iciInterpret interp ctx cmd
122 -- Perform monadic transformation in top-down order.
123 everywhereM' :: Monad m => GenericM m -> GenericM m
124 everywhereM' f x = f x >>= gmapM (everywhereM' f)
127 formatParseError :: ArrowXml a => a ParseError XmlTree
129 = proc err -> (eelem "pre" += txt (show err)) -<< ()
132 attachXHtmlNs :: ArrowXml a => a XmlTree XmlTree
133 attachXHtmlNs = processBottomUp (changeQName attach')
135 attach' :: QName -> QName
138 , namespaceUri = "http://www.w3.org/1999/xhtml"