+type InterpTable = Map String Interpreter
+
+
+formatEntirePage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
+ Storage
+ -> SystemConfig
+ -> InterpTable
+ -> a Page XmlTree
+formatEntirePage sto sysConf interpTable
+ = proc page
+ -> do SiteName siteName <- getSysConfA sysConf -< ()
+ BaseURI baseURI <- getSysConfA sysConf -< ()
+ StyleSheet cssName <- getSysConfA sysConf -< ()
+
+ Just pageTitle <- getPageA sto -< ("PageTitle" , Nothing)
+ Just leftSideBar <- getPageA sto -< ("SideBar/Left" , Nothing)
+ Just rightSideBar <- getPageA sto -< ("SideBar/Right", Nothing)
+
+ tree <- ( eelem "/"
+ += ( eelem "page"
+ += sattr "site" siteName
+ += sattr "name" (pageName page)
+ += sattr "type" (show $ pageType page)
+ += ( case pageLanguage page of
+ Just x -> sattr "lang" x
+ _ -> none
+ )
+ += ( case pageFileName page of
+ Just x -> sattr "fileName" x
+ _ -> none
+ )
+ += ( case pageType page of
+ MIMEType "text" "css" _
+ -> sattr "isTheme" (yesOrNo $ pageIsTheme page)
+ _ -> none
+ )
+ += ( case pageType page of
+ MIMEType "text" "x-rakka" _
+ -> sattr "isFeed" (yesOrNo $ pageIsFeed page)
+ _ -> none
+ )
+ += sattr "isLocked" (yesOrNo $ pageIsLocked page)
+ += sattr "isBoring" (yesOrNo $ pageIsBoring page)
+ += sattr "isBinary" (yesOrNo $ pageIsBinary page)
+ += sattr "revision" (show $ pageRevision page)
+ += sattr "lastModified" (formatW3CDateTime $ pageLastMod page)
+
+ += ( eelem "styleSheets"
+ += ( eelem "styleSheet"
+ += sattr "src" (uriToString id (mkObjectURI baseURI cssName) "")
+ )
+ )
+
+ += ( eelem "scripts"
+ += ( eelem "script"
+ += sattr "src" (uriToString id (baseURI { uriPath = "/js" }) "")
+ )
+ )
+
+ += ( case pageSummary page of
+ Nothing -> none
+ Just s -> eelem "summary" += txt s
+ )
+
+ += ( if M.null (pageOtherLang page) then
+ none
+ else
+ selem "otherLang"
+ [ eelem "link"
+ += sattr "lang" lang
+ += sattr "page" page
+ | (lang, page) <- M.toList (pageOtherLang page) ]
+ )
+ += ( eelem "pageTitle"
+ += ( (constA (pageName page) &&& constA (Just page) &&& constA pageTitle)
+ >>>
+ formatSubPage sto sysConf interpTable
+ )
+ )
+ += ( eelem "sideBar"
+ += ( eelem "left"
+ += ( (constA (pageName page) &&& constA (Just page) &&& constA leftSideBar)
+ >>>
+ formatSubPage sto sysConf interpTable
+ )
+ )
+ += ( eelem "right"
+ += ( (constA (pageName page) &&& constA (Just page) &&& constA rightSideBar)
+ >>>
+ formatSubPage sto sysConf interpTable
+ )
+ )
+ )
+ += ( eelem "body"
+ += (constA page >>> formatMainPage sto sysConf interpTable)
+ )
+ >>>
+ uniqueNamespacesFromDeclAndQNames
+ )
+ ) -<< ()
+ returnA -< tree
+
+
+formatUnexistentPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
+ Storage
+ -> SystemConfig
+ -> InterpTable
+ -> a PageName XmlTree
+formatUnexistentPage sto sysConf interpTable
+ = proc name
+ -> do SiteName siteName <- getSysConfA sysConf -< ()
+ BaseURI baseURI <- getSysConfA sysConf -< ()
+ StyleSheet cssName <- getSysConfA sysConf -< ()
+
+ Just pageTitle <- getPageA sto -< ("PageTitle" , Nothing)
+ Just leftSideBar <- getPageA sto -< ("SideBar/Left" , Nothing)
+ Just rightSideBar <- getPageA sto -< ("SideBar/Right", Nothing)
+
+ tree <- ( eelem "/"
+ += ( eelem "pageNotFound"
+ += sattr "site" siteName
+ += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "")
+ += sattr "name" name
+
+ += ( eelem "pageTitle"
+ += ( (constA name &&& constA Nothing &&& constA pageTitle)
+ >>>
+ formatSubPage sto sysConf interpTable
+ )
+ )
+ += ( eelem "sideBar"
+ += ( eelem "left"
+ += ( (constA name &&& constA Nothing &&& constA leftSideBar)
+ >>>
+ formatSubPage sto sysConf interpTable
+ )
+ )
+ += ( eelem "right"
+ += ( (constA name &&& constA Nothing &&& constA rightSideBar)
+ >>>
+ formatSubPage sto sysConf interpTable
+ )
+ )
+ )
+ >>>
+ uniqueNamespacesFromDeclAndQNames
+ )
+ ) -<< ()
+ returnA -< tree
+
+
+formatMainPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
+ Storage
+ -> SystemConfig
+ -> InterpTable
+ -> a Page XmlTree
+formatMainPage sto sysConf interpTable