+ MIMEType "text" "x-rakka" _
+ -- wikify して興味のある部分を addText する。
+ → do arrIO2 (flip setAttribute "rakka:isFeed") ⤙ (doc, T.pack <$> pIsFeed)
+ wiki ← wikifyPage interpTable ⤙ tree
+ arrIO2 (mapM_ ∘ addBlockText) ⤙ (doc, wiki)
+
+ MIMEType _ _ _
+ → returnA ⤙ ()
+
+ returnA ⤙ doc
+
+ makeRedirectDraft ∷ XmlTree ⇝ Document
+ makeRedirectDraft
+ = proc tree →
+ do doc ← arrIO0 newDocument ⤙ ()
+
+ 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
+
+ arrIO2 setURI -< (doc, Just ∘ mkRakkaURI $ T.pack pName )
+ arrIO2 (flip setAttribute "@title" ) -< (doc, Just $ T.pack pName )
+ arrIO2 (flip setAttribute "@type" ) -< (doc, Just "application/x-rakka-redirection")
+ arrIO2 (flip setAttribute "@mdate" ) -< (doc, Just $ T.pack pLastMod )
+ arrIO2 (flip setAttribute "rakka:isLocked") -< (doc, Just $ T.pack pIsLocked )
+ arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just $ T.pack pRevision )
+
+ -- リダイレクト先ページ名はテキストとして入れる
+ arrIO2 addText ⤙ (doc, T.pack pRedir)
+
+ returnA ⤙ doc
+
+ addElemText :: Document -> Element -> IO ()
+ addElemText doc (Block b) = addBlockText doc b
+ addElemText doc (Inline i) = addInlineText doc i
+
+ addBlockText :: Document -> BlockElement -> IO ()
+ addBlockText doc (Heading _ text) = addText doc text
+ addBlockText _ HorizontalLine = return ()
+ addBlockText doc (List _ items) = mapM_ (addListItemText doc) items
+ addBlockText doc (DefinitionList defs) = mapM_ (addDefinitionText doc) defs
+ addBlockText doc (Preformatted inlines) = mapM_ (addInlineText doc) inlines
+ addBlockText doc (Paragraph inlines) = mapM_ (addInlineText doc) inlines
+ addBlockText doc (Div _ elems) = mapM_ (addElemText doc) elems
+ addBlockText _ EmptyBlock = return ()
+ addBlockText doc (BlockCmd bcmd) = addBlockCmdText doc bcmd
+
+ addInlineText ∷ Document → InlineElement → IO ()
+ addInlineText doc (Text text) = addText doc text
+ addInlineText doc (Italic inlines) = mapM_ (addInlineText doc) inlines
+ addInlineText doc (Bold inlines) = mapM_ (addInlineText doc) inlines
+ addInlineText doc (ObjectLink page Nothing) = addText doc page
+ addInlineText doc (ObjectLink page (Just text)) = addHiddenText doc page
+ *> addText doc text
+ addInlineText doc (PageLink page fragm Nothing) = addText doc (fromMaybe (∅) page ⊕ maybe (∅) (T.cons '#') fragm)
+ addInlineText doc (PageLink page fragm (Just text)) = addHiddenText doc (fromMaybe (∅) page ⊕ maybe (∅) (T.cons '#') fragm)
+ *> addText doc text
+ addInlineText doc (ExternalLink uri Nothing) = addText doc (T.pack $ uriToString id uri "")
+ addInlineText doc (ExternalLink uri (Just text)) = addHiddenText doc (T.pack $ uriToString id uri "")
+ *> addText doc text
+ addInlineText _ (LineBreak _) = return ()
+ addInlineText doc (Span _ inlines) = mapM_ (addInlineText doc) inlines
+ addInlineText doc (Image src alt) = do case src of
+ Left uri -> addHiddenText doc (T.pack $ uriToString id uri "")
+ Right page -> addHiddenText doc page
+ case alt of
+ Just text -> addHiddenText doc text
+ Nothing -> return ()
+ addInlineText doc (Anchor _ inlines) = mapM_ (addInlineText doc) inlines
+ addInlineText _ (Input _) = return ()
+ addInlineText _ EmptyInline = return ()
+ addInlineText doc (InlineCmd icmd) = addInlineCmdText doc icmd
+
+ addListItemText :: Document -> ListItem -> IO ()
+ addListItemText = mapM_ . addElemText
+
+ addDefinitionText :: Document -> Definition -> IO ()
+ addDefinitionText doc (Definition term desc)
+ = do mapM_ (addInlineText doc) term
+ mapM_ (addInlineText doc) desc
+
+ addBlockCmdText :: Document -> BlockCommand -> IO ()
+ addBlockCmdText doc (BlockCommand _ _ blocks) = mapM_ (addBlockText doc) blocks
+
+ addInlineCmdText :: Document -> InlineCommand -> IO ()
+ addInlineCmdText doc (InlineCommand _ _ inlines) = mapM_ (addInlineText doc) inlines
+
+
+makePageLinkList ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
+ ⇒ Storage
+ → SystemConfig
+ → InterpTable
+ → 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 (T.pack pName), Just tree, Just wiki, wiki)
+ returnA ⤙ concatMap extractFromBlock interpreted