import Control.Arrow.ArrowTree
import Data.Encoding
import Data.Encoding.UTF8
+import qualified Data.Map as M
import Network.HTTP.Lucu
import Rakka.Environment
import Rakka.Page
import Rakka.SystemConfig
+import Rakka.Wiki
import Rakka.Wiki.Parser
import Rakka.Wiki.Formatter
+import Rakka.Wiki.Interpreter
import Text.ParserCombinators.Parsec
import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.DOM.TypeDefs
= proc page
-> do tree <- case pageType page of
MIMEType "text" "x-rakka" _
- -> formatWikiPage env -< page
+ -> do let source = decodeLazy UTF8 (pageContent page)
+ formatWikiPage env -< (Just page, source)
attachXHtmlNs -< tree
formatWikiPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
Environment
- -> a Page XmlTree
+ -> a (Maybe Page, String) XmlTree
formatWikiPage env
- = proc page
- -> do let source = decodeLazy UTF8 (pageContent page)
- case parse wikiPage "" source of
+ = proc (page, source)
+ -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
+ interpTable <- getInterpTableA env -< ()
+
+ let parser = wikiPage (tableToFunc interpTable)
+
+ case parse parser "" source of
Left err
-> formatParseError -< err
- Right elems
- -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
- formatWikiElements -< (baseURI, elems)
+ Right blocks
+ -> do xs <- interpretCommandsA env -< (interpTable, (page, blocks))
+ formatWikiBlocks -< (baseURI, xs)
+ where
+ tableToFunc :: InterpTable -> String -> Maybe CommandType
+ tableToFunc table name
+ = fmap commandType (M.lookup name table)
+
+
+interpretCommandsA :: ArrowIO a =>
+ Environment
+ -> a (InterpTable, (Maybe Page, WikiPage)) WikiPage
+interpretCommandsA = arrIO3 . interpretCommands
+
+
+interpretCommands :: Environment -> InterpTable -> Maybe Page -> WikiPage -> IO WikiPage
+interpretCommands _ _ _ [] = return []
+interpretCommands env table page blocks = mapM interpBlock blocks
+ where
+ ctx :: InterpreterContext
+ ctx = InterpreterContext {
+ ctxPage = page
+ , ctxTree = blocks
+ , ctxStorage = envStorage env
+ , ctxSysConf = envSysConf env
+ }
+
+ interpBlock :: BlockElement -> IO BlockElement
+ interpBlock (List list) = interpList list >>= return . List
+ interpBlock (DefinitionList defs) = mapM interpDefinition defs >>= return . DefinitionList
+ interpBlock (Preformatted xs) = mapM interpInline xs >>= return . Preformatted
+ interpBlock (Paragraph xs) = mapM interpInline xs >>= return . Paragraph
+ interpBlock (Div attrs xs) = mapM interpBlock xs >>= return . Div attrs
+ interpBlock (BlockCmd cmd) = interpBlockCmd cmd
+ interpBlock others = return others
+
+ interpList :: ListElement -> IO ListElement
+ interpList list = do items <- mapM interpListItem (listItems list)
+ return $ list { listItems = items }
+
+ interpListItem :: ListItem -> IO ListItem
+ interpListItem [] = return []
+ interpListItem ((Left nested):xs) = do x <- interpList nested >>= return . Left
+ xs <- interpListItem xs
+ return (x:xs)
+ interpListItem ((Right inline):xs) = do x <- interpInline inline >>= return . Right
+ xs <- interpListItem xs
+ return (x:xs)
+
+ interpDefinition :: Definition -> IO Definition
+ interpDefinition def = do term <- mapM interpInline (defTerm def)
+ desc <- mapM interpInline (defDesc def)
+ return $ def { defTerm = term, defDesc = desc }
+
+ interpBlockCmd :: BlockCommand -> IO BlockElement
+ interpBlockCmd cmd
+ = case M.lookup (bCmdName cmd) table of
+ Nothing
+ -> fail ("no such interpreter: " ++ bCmdName cmd)
+
+ Just interp
+ -> bciInterpret interp ctx cmd
+ >>=
+ interpBlock
+
+ interpInline :: InlineElement -> IO InlineElement
+ interpInline (Italic xs) = mapM interpInline xs >>= return . Italic
+ interpInline (Bold xs ) = mapM interpInline xs >>= return . Bold
+ interpInline (Span attrs xs) = mapM interpInline xs >>= return . Span attrs
+ interpInline (InlineCmd cmd) = interpInlineCmd cmd
+ interpInline others = return others
+
+ interpInlineCmd :: InlineCommand -> IO InlineElement
+ interpInlineCmd cmd
+ = case M.lookup (iCmdName cmd) table of
+ Nothing
+ -> fail ("no such interpreter: " ++ iCmdName cmd)
+
+ Just interp
+ -> iciInterpret interp ctx cmd
+ >>=
+ interpInline
formatParseError :: ArrowXml a => a ParseError XmlTree