module Rakka.Wiki.Engine
( InterpTable
- , xmlizePage
, makeMainXHTML
, makeSubXHTML
, makeDraft
makeDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => InterpTable -> a XmlTree Document
makeDraft interpTable
= proc tree ->
- do doc <- arrIO0 newDocument -< ()
+ do redir <- maybeA (getXPathTreesInDoc "/page/@redirect") -< tree
+ case redir of
+ Nothing -> makeEntityDraft -< tree
+ Just _ -> makeRedirectDraft -< tree
+ where
+ makeEntityDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a XmlTree Document
+ makeEntityDraft
+ = proc tree ->
+ do doc <- arrIO0 newDocument -< ()
- pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
- 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
-
- arrIO2 setURI -< (doc, Just $ mkRakkaURI pName)
- arrIO2 (flip setAttribute "@title" ) -< (doc, Just pName)
- 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)
-
- arrIO2 addHiddenText -< (doc, pName)
-
- case pSummary of
- Just s -> arrIO2 addHiddenText -< (doc, s)
- Nothing -> returnA -< ()
-
- -- otherLang はリンク先ページ名を hidden text で入れる。
- otherLangs <- listA (getXPathTreesInDoc "/page/otherLang/link/@page/text()" >>> getText) -< tree
- listA ( (arr fst &&& arrL snd)
- >>>
- arrIO2 addHiddenText
- >>>
- none
- ) -< (doc, otherLangs)
-
- case read pType of
- MIMEType "text" "css" _
- -> arrIO2 (flip setAttribute "rakka:isTheme") -< (doc, pIsTheme)
+ pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
+ 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
+
+ arrIO2 setURI -< (doc, Just $ mkRakkaURI pName)
+ arrIO2 (flip setAttribute "@title" ) -< (doc, Just pName)
+ 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)
+
+ arrIO2 addHiddenText -< (doc, pName)
+
+ case pSummary of
+ Just s -> arrIO2 addHiddenText -< (doc, s)
+ Nothing -> returnA -< ()
+
+ -- otherLang はリンク先ページ名を hidden text で入れる。
+ otherLangs <- listA (getXPathTreesInDoc "/page/otherLang/link/@page/text()" >>> getText) -< tree
+ listA ( (arr fst &&& arrL snd)
+ >>>
+ arrIO2 addHiddenText
+ >>>
+ none
+ ) -< (doc, otherLangs)
+
+ case read pType of
+ MIMEType "text" "css" _
+ -> arrIO2 (flip setAttribute "rakka:isTheme") -< (doc, pIsTheme)
- MIMEType "text" "x-rakka" _
- -- wikify して興味のある部分を addText する。
- -> do arrIO2 (flip setAttribute "rakka:isFeed") -< (doc, pIsFeed)
- wiki <- wikifyPage interpTable -< tree
- arrIO2 (mapM_ . addBlockText) -< (doc, wiki)
+ MIMEType "text" "x-rakka" _
+ -- wikify して興味のある部分を addText する。
+ -> do arrIO2 (flip setAttribute "rakka:isFeed") -< (doc, pIsFeed)
+ wiki <- wikifyPage interpTable -< tree
+ arrIO2 (mapM_ . addBlockText) -< (doc, wiki)
- MIMEType _ _ _
- -> returnA -< ()
+ MIMEType _ _ _
+ -> returnA -< ()
+
+ returnA -< doc
+
+ makeRedirectDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a XmlTree Document
+ makeRedirectDraft
+ = proc tree ->
+ do doc <- arrIO0 newDocument -< ()
+
+ pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
+ pRedir <- getXPathTreesInDoc "/page/@redirect/text()" >>> getText -< tree
+ pRevision <- getXPathTreesInDoc "/page/@revision/text()" >>> getText -< tree
+ pLastMod <- getXPathTreesInDoc "/page/@lastModified/text()" >>> getText -< tree
+
+ arrIO2 setURI -< (doc, Just $ mkRakkaURI pName)
+ 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:revision") -< (doc, Just pRevision)
+
+ -- リダイレクト先ページ名はテキストとして入れる
+ arrIO2 addText -< (doc, pRedir)
+
+ returnA -< doc
- returnA -< doc
- where
addElemText :: Document -> Element -> IO ()
addElemText doc (Block b) = addBlockText doc b
addElemText doc (Inline i) = addInlineText doc i
projects / Rakka.git / blobdiff