improvements related to RSS feed

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

diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs
index 910ef15f318a2f3222443074a84d9de313ee29ec..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
 
@@ -265,7 +266,6 @@ makeDraft interpTable
                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
@@ -275,7 +275,6 @@ 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:isBinary") -< (doc, Just pIsBinary)
                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")]