X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FWiki%2FEngine.hs;h=27386961fe4e7416623e6d752679c0579adf56f6;hb=f57c5c5ae6c95e68b11400718e7ce5de4ea1317a;hp=21bdad1a11a27ac2895cc6745d735aefef277f38;hpb=bc8616eec0bcac3102860c76f93ebfd0da24c2d6;p=Rakka.git

diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs
index 21bdad1..2738696 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
 
@@ -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)
@@ -318,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
 
@@ -325,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)
 
                -- リダイレクト先ページ名はテキストとして入れる
@@ -388,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")]