1 module Rakka.Wiki.Engine
7 import Control.Arrow.ArrowIO
8 import Control.Arrow.ArrowTree
10 import Data.Encoding.UTF8
11 import qualified Data.Map as M
12 import Network.HTTP.Lucu
13 import Rakka.Environment
15 import Rakka.SystemConfig
17 import Rakka.Wiki.Parser
18 import Rakka.Wiki.Formatter
19 import Rakka.Wiki.Interpreter
20 import Text.ParserCombinators.Parsec
21 import Text.XML.HXT.Arrow.XmlArrow
22 import Text.XML.HXT.DOM.TypeDefs
25 formatPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
30 -> do tree <- case pageType page of
31 MIMEType "text" "x-rakka" _
32 -> do let source = decodeLazy UTF8 (pageContent page)
33 formatWikiPage env -< (Just page, source)
37 formatWikiPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
39 -> a (Maybe Page, String) XmlTree
42 -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
43 interpTable <- getInterpTableA env -< ()
45 let parser = wikiPage (tableToFunc interpTable)
47 case parse parser "" source of
49 -> formatParseError -< err
52 -> do xs <- interpretCommandsA env -< (interpTable, (page, blocks))
53 formatWikiBlocks -< (baseURI, xs)
55 tableToFunc :: InterpTable -> String -> Maybe CommandType
56 tableToFunc table name
57 = fmap commandType (M.lookup name table)
60 interpretCommandsA :: ArrowIO a =>
62 -> a (InterpTable, (Maybe Page, WikiPage)) WikiPage
63 interpretCommandsA = arrIO3 . interpretCommands
66 interpretCommands :: Environment -> InterpTable -> Maybe Page -> WikiPage -> IO WikiPage
67 interpretCommands _ _ _ [] = return []
68 interpretCommands env table page blocks = mapM interpBlock blocks
70 ctx :: InterpreterContext
71 ctx = InterpreterContext {
74 , ctxStorage = envStorage env
75 , ctxSysConf = envSysConf env
78 interpBlock :: BlockElement -> IO BlockElement
79 interpBlock (List list) = interpList list >>= return . List
80 interpBlock (DefinitionList defs) = mapM interpDefinition defs >>= return . DefinitionList
81 interpBlock (Preformatted xs) = mapM interpInline xs >>= return . Preformatted
82 interpBlock (Paragraph xs) = mapM interpInline xs >>= return . Paragraph
83 interpBlock (Div attrs xs) = mapM interpBlock xs >>= return . Div attrs
84 interpBlock (BlockCmd cmd) = interpBlockCmd cmd
85 interpBlock others = return others
87 interpList :: ListElement -> IO ListElement
88 interpList list = do items <- mapM interpListItem (listItems list)
89 return $ list { listItems = items }
91 interpListItem :: ListItem -> IO ListItem
92 interpListItem [] = return []
93 interpListItem ((Left nested):xs) = do x <- interpList nested >>= return . Left
94 xs <- interpListItem xs
96 interpListItem ((Right inline):xs) = do x <- interpInline inline >>= return . Right
97 xs <- interpListItem xs
100 interpDefinition :: Definition -> IO Definition
101 interpDefinition def = do term <- mapM interpInline (defTerm def)
102 desc <- mapM interpInline (defDesc def)
103 return $ def { defTerm = term, defDesc = desc }
105 interpBlockCmd :: BlockCommand -> IO BlockElement
107 = case M.lookup (bCmdName cmd) table of
109 -> fail ("no such interpreter: " ++ bCmdName cmd)
112 -> bciInterpret interp ctx cmd
116 interpInline :: InlineElement -> IO InlineElement
117 interpInline (Italic xs) = mapM interpInline xs >>= return . Italic
118 interpInline (Bold xs ) = mapM interpInline xs >>= return . Bold
119 interpInline (Span attrs xs) = mapM interpInline xs >>= return . Span attrs
120 interpInline (InlineCmd cmd) = interpInlineCmd cmd
121 interpInline others = return others
123 interpInlineCmd :: InlineCommand -> IO InlineElement
125 = case M.lookup (iCmdName cmd) table of
127 -> fail ("no such interpreter: " ++ iCmdName cmd)
130 -> iciInterpret interp ctx cmd
135 formatParseError :: ArrowXml a => a ParseError XmlTree
137 = proc err -> (eelem "pre" += txt (show err)) -<< ()
140 attachXHtmlNs :: ArrowXml a => a XmlTree XmlTree
141 attachXHtmlNs = processBottomUp (changeQName attach')
143 attach' :: QName -> QName
146 , namespaceUri = "http://www.w3.org/1999/xhtml"