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 interpBlock :: BlockElement -> IO BlockElement
71 interpBlock (List list) = interpList list >>= return . List
72 interpBlock (DefinitionList defs) = mapM interpDefinition defs >>= return . DefinitionList
73 interpBlock (Preformatted xs ) = mapM interpInline xs >>= return . Preformatted
74 interpBlock (Paragraph xs ) = mapM interpInline xs >>= return . Paragraph
75 interpBlock others = return others
77 interpList :: ListElement -> IO ListElement
78 interpList list = do items <- mapM interpListItem (listItems list)
79 return $ list { listItems = items }
81 interpListItem :: ListItem -> IO ListItem
82 interpListItem [] = return []
83 interpListItem ((Left nested):xs) = do x <- interpList nested >>= return . Left
84 xs <- interpListItem xs
86 interpListItem ((Right inline):xs) = do x <- interpInline inline >>= return . Right
87 xs <- interpListItem xs
90 interpDefinition :: Definition -> IO Definition
91 interpDefinition def = do term <- mapM interpInline (defTerm def)
92 desc <- mapM interpInline (defDesc def)
93 return $ def { defTerm = term, defDesc = desc }
95 interpInline :: InlineElement -> IO InlineElement
96 interpInline (Italic xs ) = mapM interpInline xs >>= return . Italic
97 interpInline (Bold xs ) = mapM interpInline xs >>= return . Bold
98 interpInline (InlineCmd cmd) = interpInlineCmd cmd
99 interpInline others = return others
101 interpInlineCmd :: InlineCommand -> IO InlineElement
103 = case M.lookup (iCmdName cmd) table of
105 -> fail ("no such interpreter: " ++ iCmdName cmd)
108 -> iciInterpret interp cmd page (envStorage env) (envSysConf env)
113 formatParseError :: ArrowXml a => a ParseError XmlTree
115 = proc err -> (eelem "pre" += txt (show err)) -<< ()
118 attachXHtmlNs :: ArrowXml a => a XmlTree XmlTree
119 attachXHtmlNs = processBottomUp (changeQName attach')
121 attach' :: QName -> QName
124 , namespaceUri = "http://www.w3.org/1999/xhtml"