1 module Rakka.Wiki.Engine
8 import Control.Arrow.ArrowIO
10 import Data.Encoding.UTF8
12 import qualified Data.Map as M
13 import Network.HTTP.Lucu
14 import Rakka.Environment
16 import Rakka.SystemConfig
18 import Rakka.Wiki.Parser
19 import Rakka.Wiki.Formatter
20 import Rakka.Wiki.Interpreter
21 import Text.ParserCombinators.Parsec
22 import Text.XML.HXT.Arrow.XmlArrow
23 import Text.XML.HXT.DOM.TypeDefs
26 formatPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
31 -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
32 interpTable <- getInterpTableA env -< ()
33 wiki <- wikifyPage env -< (interpTable, page)
34 xs <- interpretCommandsA env -< (interpTable, (pageName page, (Just wiki, wiki)))
35 formatWikiBlocks -< (baseURI, xs)
38 formatSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
40 -> a (PageName, (Maybe Page, Page)) XmlTree
42 = proc (mainPageName, (mainPage, subPage))
43 -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
44 interpTable <- getInterpTableA env -< ()
45 mainWiki <- case mainPage of
47 -> do wiki <- wikifyPage env -< (interpTable, page)
51 subWiki <- wikifyPage env -< (interpTable, subPage)
52 xs <- interpretCommandsA env -< (interpTable, (mainPageName, (mainWiki, subWiki)))
53 formatWikiBlocks -< (baseURI, xs)
56 wikifyPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
58 -> a (InterpTable, Page) WikiPage
60 = proc (interpTable, page)
61 -> case pageType page of
62 MIMEType "text" "x-rakka" _
63 -> do let source = decodeLazy UTF8 (pageContent page)
64 parser = wikiPage (tableToFunc interpTable)
66 case parse parser "" source of
68 -> wikifyParseError -< err
73 tableToFunc :: InterpTable -> String -> Maybe CommandType
74 tableToFunc table name
75 = fmap commandType (M.lookup name table)
78 interpretCommandsA :: ArrowIO a =>
80 -> a (InterpTable, (PageName, (Maybe WikiPage, WikiPage))) WikiPage
81 interpretCommandsA = arrIO4 . interpretCommands
84 interpretCommands :: Environment -> InterpTable -> PageName -> Maybe WikiPage -> WikiPage -> IO WikiPage
85 interpretCommands _ _ _ _ [] = return []
86 interpretCommands env table name mainTree targetTree
87 = everywhereM' (mkM interpBlockCmd) targetTree
89 everywhereM' (mkM interpInlineCmd)
91 ctx :: InterpreterContext
92 ctx = InterpreterContext {
94 , ctxMainTree = mainTree
95 , ctxTargetTree = targetTree
96 , ctxStorage = envStorage env
97 , ctxSysConf = envSysConf env
100 interpBlockCmd :: BlockElement -> IO BlockElement
101 interpBlockCmd (BlockCmd cmd) = interpBlockCmd' cmd
102 interpBlockCmd others = return others
104 interpBlockCmd' :: BlockCommand -> IO BlockElement
106 = case M.lookup (bCmdName cmd) table of
108 -> fail ("no such interpreter: " ++ bCmdName cmd)
111 -> bciInterpret interp ctx cmd
114 interpInlineCmd :: InlineElement -> IO InlineElement
115 interpInlineCmd (InlineCmd cmd) = interpInlineCmd' cmd
116 interpInlineCmd others = return others
118 interpInlineCmd' :: InlineCommand -> IO InlineElement
120 = case M.lookup (iCmdName cmd) table of
122 -> fail ("no such interpreter: " ++ iCmdName cmd)
125 -> iciInterpret interp ctx cmd
128 -- Perform monadic transformation in top-down order.
129 everywhereM' :: Monad m => GenericM m -> GenericM m
130 everywhereM' f x = f x >>= gmapM (everywhereM' f)
133 wikifyParseError :: ArrowXml a => a ParseError WikiPage
135 = proc err -> returnA -< [Preformatted [Text (show err)]]