improvements related to RSS feed

[Rakka.git] / Rakka / Wiki / Engine.hs

diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs
index b475f9c04be3c3db3335f320bd011334a5eac16c..27386961fe4e7416623e6d752679c0579adf56f6 100644 (file)
--- 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
-                       -- <a href="data:application/zip;base64,...">foo.zip</a>
+                       -- <a href="data:application/zip;base64,...">
+                       --   application/zip
+                       -- </a>
                        returnA -< [ Paragraph [ Anchor
                                                 [("href", show dataURI)]
-                                                [Text (fromMaybe (defaultFileName pType pName) pFileName)]
+                                                [Text (show pType)]
                                               ]
                                   ]
                    else
@@ -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
+                             -< (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")]