From dc29dc9081156af3b536b19ffd828cdd67ddd84a Mon Sep 17 00:00:00 2001 From: pho Date: Tue, 29 Jan 2008 11:15:41 +0900 Subject: [PATCH] fix design problem darcs-hash:20080129021541-62b54-d8f11d757e14be12678159ede38ae5e60b625651.gz --- Rakka/Resource/PageEntity.hs | 20 ++++++++++---------- Rakka/Wiki/Engine.hs | 10 +++++----- Rakka/Wiki/Interpreter.hs | 2 +- Rakka/Wiki/Interpreter/Base.hs | 4 ++-- Rakka/Wiki/Interpreter/Trackback.hs | 10 +++++++--- 5 files changed, 25 insertions(+), 21 deletions(-) diff --git a/Rakka/Resource/PageEntity.hs b/Rakka/Resource/PageEntity.hs index 208b0b5..d71b53a 100644 --- a/Rakka/Resource/PageEntity.hs +++ b/Rakka/Resource/PageEntity.hs @@ -134,9 +134,9 @@ entityToXHTML env feeds <- arrIO0 (findFeeds (envStorage env)) -< () - pageTitle <- listA (readSubPage env) -< (name, Just page, "PageTitle") - leftSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Left") - rightSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Right") + pageTitle <- listA (readSubPage env) -< (Just name, Just page, "PageTitle") + leftSideBar <- listA (readSubPage env) -< (Just name, Just page, "SideBar/Left") + rightSideBar <- listA (readSubPage env) -< (Just name, Just page, "SideBar/Right") pageBody <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page ( eelem "/" @@ -310,7 +310,7 @@ entityToRSS env readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment - -> a (PageName, Maybe XmlTree, PageName) XmlTree + -> a (Maybe PageName, Maybe XmlTree, PageName) XmlTree readSubPage env = proc (mainPageName, mainPage, subPageName) -> do subPage <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing) @@ -355,9 +355,9 @@ pageListingToXHTML env let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""] scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI "js" }) ""] - pageTitle <- listA (readSubPage env) -< (name, Nothing, "PageTitle") - leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left") - rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right") + pageTitle <- listA (readSubPage env) -< (Just name, Nothing, "PageTitle") + leftSideBar <- listA (readSubPage env) -< (Just name, Nothing, "SideBar/Left") + rightSideBar <- listA (readSubPage env) -< (Just name, Nothing, "SideBar/Right") ( eelem "/" += ( eelem "html" @@ -467,9 +467,9 @@ notFoundToXHTML env let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""] scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI "js" }) ""] - pageTitle <- listA (readSubPage env) -< (name, Nothing, "PageTitle") - leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left") - rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right") + pageTitle <- listA (readSubPage env) -< (Just name, Nothing, "PageTitle") + leftSideBar <- listA (readSubPage env) -< (Just name, Nothing, "SideBar/Left") + rightSideBar <- listA (readSubPage env) -< (Just name, Nothing, "SideBar/Right") ( eelem "/" += ( eelem "html" diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs index 2738696..e3e49ee 100644 --- a/Rakka/Wiki/Engine.hs +++ b/Rakka/Wiki/Engine.hs @@ -137,7 +137,7 @@ makeMainXHTML sto sysConf interpTable wiki <- wikifyPage interpTable -< tree pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree interpreted <- interpretCommands sto sysConf interpTable - -< (pName, Just tree, Just wiki, wiki) + -< (Just pName, Just tree, Just wiki, wiki) formatWikiBlocks -< (baseURI, interpreted) @@ -145,7 +145,7 @@ makeSubXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Storage -> SystemConfig -> InterpTable - -> a (PageName, Maybe XmlTree, XmlTree) XmlTree + -> a (Maybe PageName, Maybe XmlTree, XmlTree) XmlTree makeSubXHTML sto sysConf interpTable = proc (mainPageName, mainPage, subPage) -> do BaseURI baseURI <- getSysConfA sysConf -< () @@ -171,7 +171,7 @@ makePreviewXHTML sto sysConf interpTable -> do BaseURI baseURI <- getSysConfA sysConf -< () wiki <- wikifyBin interpTable -< (pageType, pageBin) interpreted <- interpretCommands sto sysConf interpTable - -< (name, Nothing, Just wiki, wiki) + -< (Just name, Nothing, Just wiki, wiki) formatWikiBlocks -< (baseURI, interpreted) @@ -179,7 +179,7 @@ interpretCommands :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Storage -> SystemConfig -> InterpTable - -> a (PageName, Maybe XmlTree, Maybe WikiPage, WikiPage) WikiPage + -> a (Maybe PageName, Maybe XmlTree, Maybe WikiPage, WikiPage) WikiPage interpretCommands sto sysConf interpTable = proc (name, mainPage, mainWiki, targetWiki) -> let ctx = InterpreterContext { @@ -399,7 +399,7 @@ makePageLinkList sto sysConf interpTable -> do wiki <- wikifyPage interpTable -< tree pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree interpreted <- interpretCommands sto sysConf interpTable - -< (pName, Just tree, Just wiki, wiki) + -< (Just pName, Just tree, Just wiki, wiki) returnA -< concatMap extractFromBlock interpreted where extractFromElem :: Element -> [PageName] diff --git a/Rakka/Wiki/Interpreter.hs b/Rakka/Wiki/Interpreter.hs index 9c40816..32e1a3a 100644 --- a/Rakka/Wiki/Interpreter.hs +++ b/Rakka/Wiki/Interpreter.hs @@ -27,7 +27,7 @@ data Interpreter data InterpreterContext = InterpreterContext { - ctxPageName :: !PageName + ctxPageName :: !(Maybe PageName) , ctxMainPage :: !(Maybe XmlTree) , ctxMainWiki :: !(Maybe WikiPage) , ctxTargetWiki :: !WikiPage diff --git a/Rakka/Wiki/Interpreter/Base.hs b/Rakka/Wiki/Interpreter/Base.hs index bb4c4ad..f461027 100644 --- a/Rakka/Wiki/Interpreter/Base.hs +++ b/Rakka/Wiki/Interpreter/Base.hs @@ -57,7 +57,7 @@ pageNameInterp :: Interpreter pageNameInterp = InlineCommandInterpreter { iciName = "pageName" , iciInterpret - = \ ctx _ -> return $ Text (ctxPageName ctx) + = \ ctx _ -> return $ Text (fromMaybe "" $ ctxPageName ctx) } @@ -132,7 +132,7 @@ editPageInterp iciName = "editPage" , iciInterpret = \ ctx (InlineCommand _ args _) -> - let name = fromMaybe (ctxPageName ctx) (lookup "page" args) + let name = fromMaybe (fromMaybe "" $ ctxPageName ctx) (lookup "page" args) label = fromMaybe "Edit this page" (lookup "label" args) attrs = [ ("type" , "button") , ("value" , label) diff --git a/Rakka/Wiki/Interpreter/Trackback.hs b/Rakka/Wiki/Interpreter/Trackback.hs index 44cf13c..a5b9681 100644 --- a/Rakka/Wiki/Interpreter/Trackback.hs +++ b/Rakka/Wiki/Interpreter/Trackback.hs @@ -20,9 +20,13 @@ trackbackURLInterp = InlineCommandInterpreter { iciName = "trackbackURL" , iciInterpret - = \ ctx _ -> do BaseURI baseURI <- getSysConf (ctxSysConf ctx) - let uri = mkAuxiliaryURI baseURI ["trackback"] (ctxPageName ctx) - return $ ExternalLink uri (Just "Trackback URL") + = \ ctx _ -> case ctxPageName ctx of + Nothing + -> return (Text "No trackbacks for this page.") + Just name + -> do BaseURI baseURI <- getSysConf (ctxSysConf ctx) + let uri = mkAuxiliaryURI baseURI ["trackback"] name + return $ ExternalLink uri (Just "Trackback URL") } -- 2.40.0