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 wiki <- wikifyPage env -< page
33 xs <- interpretCommandsA env -< (pageName page, (Just wiki, wiki))
34 formatWikiBlocks -< (baseURI, xs)
37 formatSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
39 -> a (PageName, (Maybe Page, Page)) XmlTree
41 = proc (mainPageName, (mainPage, subPage))
42 -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
43 mainWiki <- case mainPage of
45 -> do wiki <- wikifyPage env -< page
49 subWiki <- wikifyPage env -< subPage
50 xs <- interpretCommandsA env -< (mainPageName, (mainWiki, subWiki))
51 formatWikiBlocks -< (baseURI, xs)
54 wikifyPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
59 -> case pageType page of
60 MIMEType "text" "x-rakka" _
61 -> do let source = decodeLazy UTF8 (pageContent page)
62 parser = wikiPage tableToFunc
64 case parse parser "" source of
66 -> wikifyParseError -< err
71 tableToFunc :: String -> Maybe CommandType
73 = fmap commandType (M.lookup name (envInterpTable env))
76 interpretCommandsA :: ArrowIO a =>
78 -> a (PageName, (Maybe WikiPage, WikiPage)) WikiPage
79 interpretCommandsA = arrIO3 . interpretCommands
82 interpretCommands :: Environment -> PageName -> Maybe WikiPage -> WikiPage -> IO WikiPage
83 interpretCommands _ _ _ [] = return []
84 interpretCommands env name mainTree targetTree
85 = everywhereM' (mkM interpBlockCmd) targetTree
87 everywhereM' (mkM interpInlineCmd)
89 ctx :: InterpreterContext
90 ctx = InterpreterContext {
92 , ctxMainTree = mainTree
93 , ctxTargetTree = targetTree
94 , ctxStorage = envStorage env
95 , ctxSysConf = envSysConf env
98 interpBlockCmd :: BlockElement -> IO BlockElement
99 interpBlockCmd (BlockCmd cmd) = interpBlockCmd' cmd
100 interpBlockCmd others = return others
102 interpBlockCmd' :: BlockCommand -> IO BlockElement
104 = case M.lookup (bCmdName cmd) (envInterpTable env) of
106 -> fail ("no such interpreter: " ++ bCmdName cmd)
109 -> bciInterpret interp ctx cmd
112 interpInlineCmd :: InlineElement -> IO InlineElement
113 interpInlineCmd (InlineCmd cmd) = interpInlineCmd' cmd
114 interpInlineCmd others = return others
116 interpInlineCmd' :: InlineCommand -> IO InlineElement
118 = case M.lookup (iCmdName cmd) (envInterpTable env) of
120 -> fail ("no such interpreter: " ++ iCmdName cmd)
123 -> iciInterpret interp ctx cmd
126 -- Perform monadic transformation in top-down order.
127 everywhereM' :: Monad m => GenericM m -> GenericM m
128 everywhereM' f x = f x >>= gmapM (everywhereM' f)
131 wikifyParseError :: ArrowXml a => a ParseError WikiPage
133 = proc err -> returnA -< [Div [("class", "error")]
134 [ Preformatted [Text (show err)] ]]