- 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 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 }
-
- interpInline :: InlineElement -> IO InlineElement
- interpInline (Italic xs ) = mapM interpInline xs >>= return . Italic
- interpInline (Bold xs ) = mapM interpInline xs >>= return . Bold
- interpInline (InlineCmd cmd) = interpInlineCmd cmd
- interpInline others = return others
-
- interpInlineCmd :: InlineCommand -> IO InlineElement
- interpInlineCmd cmd
- = case M.lookup (iCmdName cmd) table of
+ binToURI :: MIMEType -> Lazy.ByteString -> URI
+ binToURI m b
+ = nullURI {
+ uriScheme = "data:"
+ , uriPath = show m ++ ";base64," ++ (L8.unpack $ encodeBase64LBS b)
+ }
+
+
+cmdTypeOf :: InterpTable -> String -> Maybe CommandType
+cmdTypeOf interpTable name
+ = fmap commandType (M.lookup name interpTable)
+
+
+makeMainXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
+ Storage
+ -> SystemConfig
+ -> InterpTable
+ -> a XmlTree XmlTree
+makeMainXHTML sto sysConf interpTable
+ = proc tree
+ -> do BaseURI baseURI <- getSysConfA sysConf -< ()
+ wiki <- wikifyPage interpTable -< tree
+ pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
+ interpreted <- interpretCommands sto sysConf interpTable
+ -< (Just pName, Just tree, Just wiki, wiki)
+ formatWikiBlocks -< (baseURI, interpreted)
+
+
+makeSubXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
+ Storage
+ -> SystemConfig
+ -> InterpTable
+ -> a (Maybe PageName, Maybe XmlTree, XmlTree) XmlTree
+makeSubXHTML sto sysConf interpTable
+ = proc (mainPageName, mainPage, subPage)
+ -> do BaseURI baseURI <- getSysConfA sysConf -< ()
+ mainWiki <- case mainPage of
+ Just page
+ -> do wiki <- wikifyPage interpTable -< page
+ returnA -< Just (page, wiki)
+ Nothing
+ -> returnA -< Nothing
+ subWiki <- wikifyPage interpTable -< subPage
+ interpreted <- interpretCommands sto sysConf interpTable
+ -< (mainPageName, fmap fst mainWiki, fmap snd mainWiki, subWiki)
+ formatWikiBlocks -< (baseURI, interpreted)
+
+
+makePreviewXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
+ Storage
+ -> SystemConfig
+ -> InterpTable
+ -> a (PageName, MIMEType, Lazy.ByteString) XmlTree
+makePreviewXHTML sto sysConf interpTable
+ = proc (name, pageType, pageBin)
+ -> do BaseURI baseURI <- getSysConfA sysConf -< ()
+ wiki <- wikifyBin interpTable -< (pageType, pageBin)
+ interpreted <- interpretCommands sto sysConf interpTable
+ -< (Just name, Nothing, Just wiki, wiki)
+ formatWikiBlocks -< (baseURI, interpreted)
+
+
+interpretCommands :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
+ Storage
+ -> SystemConfig
+ -> InterpTable
+ -> a (Maybe PageName, Maybe XmlTree, Maybe WikiPage, WikiPage) WikiPage
+interpretCommands sto sysConf interpTable
+ = proc (name, mainPage, mainWiki, targetWiki)
+ -> let ctx = InterpreterContext {
+ ctxPageName = name
+ , ctxMainPage = mainPage
+ , ctxMainWiki = mainWiki
+ , ctxTargetWiki = targetWiki
+ , ctxStorage = sto
+ , ctxSysConf = sysConf
+ }
+ in
+ arrIO2 (mapM . interpBlock) -< (ctx, targetWiki)
+ where
+ interpElem :: InterpreterContext -> Element -> IO Element
+ interpElem ctx (Block b) = interpBlock ctx b >>= return . Block
+ interpElem ctx (Inline i) = interpInline ctx i >>= return . Inline
+
+ interpBlock :: InterpreterContext -> BlockElement -> IO BlockElement
+ interpBlock ctx (List lType lItems) = mapM (interpListItem ctx) lItems >>= return . List lType
+ interpBlock ctx (DefinitionList defs) = mapM (interpDefinition ctx) defs >>= return . DefinitionList
+ interpBlock ctx (Preformatted inlines) = mapM (interpInline ctx) inlines >>= return . Preformatted
+ interpBlock ctx (Paragraph inlines) = mapM (interpInline ctx) inlines >>= return . Paragraph
+ interpBlock ctx (Div attrs elems) = mapM (interpElem ctx) elems >>= return . Div attrs
+ interpBlock ctx (BlockCmd bcmd) = interpBlockCommand ctx bcmd
+ interpBlock _ x = return x
+
+ interpInline :: InterpreterContext -> InlineElement -> IO InlineElement
+ interpInline ctx (Italic inlines) = mapM (interpInline ctx) inlines >>= return . Italic
+ interpInline ctx (Bold inlines) = mapM (interpInline ctx) inlines >>= return . Bold
+ interpInline ctx (Span attrs inlines) = mapM (interpInline ctx) inlines >>= return . Span attrs
+ interpInline ctx (Anchor attrs inlines) = mapM (interpInline ctx) inlines >>= return . Anchor attrs
+ interpInline ctx (InlineCmd icmd) = interpInlineCommand ctx icmd
+ interpInline _ x = return x
+
+ interpListItem :: InterpreterContext -> ListItem -> IO ListItem
+ interpListItem = mapM . interpElem
+
+ interpDefinition :: InterpreterContext -> Definition -> IO Definition
+ interpDefinition ctx (Definition term desc)
+ = do term' <- mapM (interpInline ctx) term
+ desc' <- mapM (interpInline ctx) desc
+ return (Definition term' desc')
+
+ interpBlockCommand :: InterpreterContext -> BlockCommand -> IO BlockElement
+ interpBlockCommand ctx cmd
+ = case M.lookup (bCmdName cmd) interpTable of
+ Nothing
+ -> fail ("no such interpreter: " ++ bCmdName cmd)
+
+ Just interp
+ -> bciInterpret interp ctx cmd
+ >>=
+ interpBlock ctx
+
+ interpInlineCommand :: InterpreterContext -> InlineCommand -> IO InlineElement
+ interpInlineCommand ctx cmd
+ = case M.lookup (iCmdName cmd) interpTable of