X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FWiki%2FEngine.hs;h=e3e49ee176c89676cfa12734c7bde40b7fded674;hb=dc29dc9081156af3b536b19ffd828cdd67ddd84a;hp=b475f9c04be3c3db3335f320bd011334a5eac16c;hpb=71f2db55513679098869de2122b5d5989dbc2be2;p=Rakka.git diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs index b475f9c..e3e49ee 100644 --- a/Rakka/Wiki/Engine.hs +++ b/Rakka/Wiki/Engine.hs @@ -2,8 +2,9 @@ module Rakka.Wiki.Engine ( InterpTable , makeMainXHTML , makeSubXHTML - , makeDraft , makePreviewXHTML + , makePageLinkList + , makeDraft ) where @@ -39,9 +40,7 @@ type InterpTable = Map String Interpreter wikifyPage :: (ArrowXml a, ArrowChoice a) => InterpTable -> a XmlTree WikiPage wikifyPage interpTable = proc tree - -> do pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree - pType <- getXPathTreesInDoc "/page/@type/text()" >>> getText >>> arr read -< tree - pFileName <- maybeA (getXPathTreesInDoc "/page/fileName/text()" >>> getText) -< tree + -> do pType <- getXPathTreesInDoc "/page/@type/text()" >>> getText >>> arr read -< tree textData <- maybeA (getXPathTreesInDoc "/page/textData/text()" >>> getText) -< tree base64Data <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree @@ -58,10 +57,12 @@ wikifyPage interpTable -> returnA -< [ Paragraph [Image (Left $ fromJust dataURI) Nothing] ] _ -> if isJust dataURI then - -- foo.zip + -- + -- application/zip + -- returnA -< [ Paragraph [ Anchor [("href", show dataURI)] - [Text (fromMaybe (defaultFileName pType pName) pFileName)] + [Text (show pType)] ] ] else @@ -136,7 +137,7 @@ makeMainXHTML sto sysConf interpTable wiki <- wikifyPage interpTable -< tree pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree interpreted <- interpretCommands sto sysConf interpTable - -< (pName, Just tree, Just wiki, wiki) + -< (Just pName, Just tree, Just wiki, wiki) formatWikiBlocks -< (baseURI, interpreted) @@ -144,7 +145,7 @@ makeSubXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Storage -> SystemConfig -> InterpTable - -> a (PageName, Maybe XmlTree, XmlTree) XmlTree + -> a (Maybe PageName, Maybe XmlTree, XmlTree) XmlTree makeSubXHTML sto sysConf interpTable = proc (mainPageName, mainPage, subPage) -> do BaseURI baseURI <- getSysConfA sysConf -< () @@ -170,7 +171,7 @@ makePreviewXHTML sto sysConf interpTable -> do BaseURI baseURI <- getSysConfA sysConf -< () wiki <- wikifyBin interpTable -< (pageType, pageBin) interpreted <- interpretCommands sto sysConf interpTable - -< (name, Nothing, Just wiki, wiki) + -< (Just name, Nothing, Just wiki, wiki) formatWikiBlocks -< (baseURI, interpreted) @@ -178,7 +179,7 @@ interpretCommands :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Storage -> SystemConfig -> InterpTable - -> a (PageName, Maybe XmlTree, Maybe WikiPage, WikiPage) WikiPage + -> a (Maybe PageName, Maybe XmlTree, Maybe WikiPage, WikiPage) WikiPage interpretCommands sto sysConf interpTable = proc (name, mainPage, mainWiki, targetWiki) -> let ctx = InterpreterContext { @@ -262,11 +263,9 @@ makeDraft interpTable pType <- getXPathTreesInDoc "/page/@type/text()" >>> getText -< tree pLastMod <- getXPathTreesInDoc "/page/@lastModified/text()" >>> getText -< tree pIsLocked <- getXPathTreesInDoc "/page/@isLocked/text()" >>> getText -< tree - pIsBoring <- getXPathTreesInDoc "/page/@isBoring/text()" >>> getText -< tree pIsBinary <- getXPathTreesInDoc "/page/@isBinary/text()" >>> getText -< tree pRevision <- getXPathTreesInDoc "/page/@revision/text()" >>> getText -< tree pLang <- maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< tree - pFileName <- maybeA (getXPathTreesInDoc "/page/@fileName/text()" >>> getText) -< tree pIsTheme <- maybeA (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) -< tree pIsFeed <- maybeA (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) -< tree pSummary <- maybeA (getXPathTreesInDoc "/page/summary/text()" >>> getText) -< tree @@ -276,9 +275,7 @@ makeDraft interpTable arrIO2 (flip setAttribute "@type" ) -< (doc, Just pType) arrIO2 (flip setAttribute "@mdate" ) -< (doc, Just pLastMod) arrIO2 (flip setAttribute "@lang" ) -< (doc, pLang) - arrIO2 (flip setAttribute "rakka:fileName") -< (doc, pFileName) arrIO2 (flip setAttribute "rakka:isLocked") -< (doc, Just pIsLocked) - arrIO2 (flip setAttribute "rakka:isBoring") -< (doc, Just pIsBoring) arrIO2 (flip setAttribute "rakka:isBinary") -< (doc, Just pIsBinary) arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just pRevision) arrIO2 (flip setAttribute "rakka:summary" ) -< (doc, pSummary) @@ -320,6 +317,7 @@ makeDraft interpTable pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree pRedir <- getXPathTreesInDoc "/page/@redirect/text()" >>> getText -< tree + pIsLocked <- getXPathTreesInDoc "/page/@isLocked/text()" >>> getText -< tree pRevision <- getXPathTreesInDoc "/page/@revision/text()" >>> getText -< tree pLastMod <- getXPathTreesInDoc "/page/@lastModified/text()" >>> getText -< tree @@ -327,6 +325,7 @@ makeDraft interpTable arrIO2 (flip setAttribute "@title" ) -< (doc, Just pName) arrIO2 (flip setAttribute "@type" ) -< (doc, Just "application/x-rakka-redirection") arrIO2 (flip setAttribute "@mdate" ) -< (doc, Just pLastMod) + arrIO2 (flip setAttribute "rakka:isLocked") -< (doc, Just pIsLocked) arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just pRevision) -- リダイレクト先ページ名はテキストとして入れる @@ -390,6 +389,48 @@ makeDraft interpTable addInlineCmdText doc (InlineCommand _ _ inlines) = mapM_ (addInlineText doc) inlines +makePageLinkList :: (ArrowXml a, ArrowChoice a, ArrowIO a) => + Storage + -> SystemConfig + -> InterpTable + -> a XmlTree [PageName] +makePageLinkList sto sysConf interpTable + = proc tree + -> do wiki <- wikifyPage interpTable -< tree + pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree + interpreted <- interpretCommands sto sysConf interpTable + -< (Just pName, Just tree, Just wiki, wiki) + returnA -< concatMap extractFromBlock interpreted + where + extractFromElem :: Element -> [PageName] + extractFromElem (Block b) = extractFromBlock b + extractFromElem (Inline i) = extractFromInline i + + extractFromBlock :: BlockElement -> [PageName] + extractFromBlock (List _ items) = concatMap extractFromListItem items + extractFromBlock (DefinitionList defs) = concatMap extractFromDefinition defs + extractFromBlock (Preformatted inlines) = concatMap extractFromInline inlines + extractFromBlock (Paragraph inlines) = concatMap extractFromInline inlines + extractFromBlock (Div _ elems) = concatMap extractFromElem elems + extractFromBlock _ = [] + + extractFromInline :: InlineElement -> [PageName] + extractFromInline (Italic inlines) = concatMap extractFromInline inlines + extractFromInline (Bold inlines) = concatMap extractFromInline inlines + extractFromInline (Span _ inlines) = concatMap extractFromInline inlines + extractFromInline (PageLink (Just name) _ _) = [name] + extractFromInline _ = [] + + extractFromListItem :: ListItem -> [PageName] + extractFromListItem = concatMap extractFromElem + + extractFromDefinition :: Definition -> [PageName] + extractFromDefinition (Definition term desc) + = concatMap extractFromInline term + ++ + concatMap extractFromInline desc + + wikifyParseError :: Arrow a => a ParseError WikiPage wikifyParseError = proc err -> returnA -< [Div [("class", "error")]