From: pho <pho@cielonegro.org>
Date: Tue, 29 Jan 2008 02:15:41 +0000 (+0900)
Subject: fix design problem
X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=dc29dc9081156af3b536b19ffd828cdd67ddd84a;p=Rakka.git

fix design problem

darcs-hash:20080129021541-62b54-d8f11d757e14be12678159ede38ae5e60b625651.gz
---

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")
       }