1 -------------------------------------------------------------------------------- 2 {-# LANGUAGE OverloadedStrings #-} 3 {-# LANGUAGE QuasiQuotes #-} 4 {-# LANGUAGE FlexibleContexts #-} 5 {-# LANGUAGE TupleSections #-} 6 module Main where 7 import HBlog.Lib 8 import Data.List 9 import Hakyll hiding (Redirect(..)) 10 import System.FilePath 11 import Text.Blaze.Html (toHtml, toValue, (!)) 12 import Text.Blaze.Html.Renderer.String (renderHtml) 13 import qualified Text.Blaze.Html5 as H 14 import qualified Text.Blaze.Html5.Attributes as A 15 import Text.Pandoc (writePlain, def, nullMeta, PandocError(..), runPure) 16 import Text.Pandoc.Definition (Pandoc(..), Inline(..), Block(..)) 17 import Text.Pandoc.Walk (walk, query) 18 import Network.URI (unEscapeString) 19 import Hakyll.Core.Identifier (toFilePath) 20 import Data.Time.Clock (UTCTime) 21 import System.Process (readProcessWithExitCode) 22 import System.Exit (ExitCode(..)) 23 import Data.Time.Format (TimeLocale, formatTime, parseTimeM, defaultTimeLocale) 24 import Control.Monad (liftM, msum, forM_) 25 import Data.Ord (comparing) 26 import Text.Read (readMaybe) 27 import Data.Maybe (isJust, isNothing, fromJust) 28 import qualified Control.Applicative as CA (Alternative (..)) 29 import qualified Data.Text as T 30 import qualified Data.Char as Char 31 32 33 -- Types used for our redirect generation 34 type RedirectCategory = String 35 type RedirectPattern = String 36 data Redirect = Redirect 37 { redirIdent :: Identifier 38 , redirCategory :: RedirectCategory 39 , redirPath :: FilePath 40 , redirPattern :: RedirectPattern 41 } 42 43 -------------------------------------------------------------------------------- 44 baseURL :: String 45 baseURL = "http://rlpowell.digitalkingdom.org/" 46 47 main :: IO () 48 main = hakyll $ do 49 -- ************ 50 -- Build up various chunks of data we'll need later 51 -- ************ 52 allTags <- buildTagsWith myGetTags "posts/**" (fromCapture "tags/*.html") 53 54 allCategories <- buildTagsWith myGetCategory "posts/**" (fromCapture "categories/*.html") 55 56 ids <- getMatches "posts/**" 57 58 titles <- fmap mconcat $ mapM getTitlePair ids 59 60 gitTimes <- fmap mconcat $ preprocess $ mapM getGitTimes ids 61 62 -- ************ 63 -- Build the actual destination files 64 -- ************ 65 match "images/*" $ do 66 route idRoute 67 compile copyFileCompiler 68 69 match "css/*" $ do 70 route idRoute 71 compile compressCssCompiler 72 73 match "posts/**" $ do 74 route $ (gsubRoute "posts/" (const "")) `composeRoutes` setExtension "html" 75 compile $ do 76 pandocCompilerWithTransform hblogPandocReaderOptions hblogPandocWriterOptions (titleFixer titles) 77 >>= loadAndApplyTemplate "templates/post.html" (postCtx allTags allCategories gitTimes) 78 >>= loadAndApplyTemplate "templates/default.html" (postCtx allTags allCategories gitTimes) 79 >>= relativizeUrls 80 81 -- FIXME: Do we want a list of categories anywhere? Probably; we'd 82 -- talked about having a "default" site that takes extra work to get 83 -- to, that would use something like this 84 -- 85 -- create ["categories.html"] $ do 86 -- route idRoute 87 -- compile $ do 88 -- posts <- (myRecentFirst gitTimes) =<< loadAll "categories/*" 89 -- let archiveCtx = 90 -- listField "posts" (postCtx allTags allCategories gitTimes) (return posts) `mappend` 91 -- constField "title" "Archives" `mappend` 92 -- (postCtx allTags allCategories gitTimes) 93 -- 94 -- makeItem "" 95 -- >>= loadAndApplyTemplate "templates/archive.html" archiveCtx 96 -- >>= loadAndApplyTemplate "templates/default.html" archiveCtx 97 -- >>= relativizeUrls 98 -- 99 -- 100 create ["archive.html"] $ do 101 route idRoute 102 compile $ do 103 posts <- (myRecentFirst gitTimes) =<< loadAll "posts/**" 104 let archiveCtx = 105 listField "posts" (postCtx allTags allCategories gitTimes) (return posts) `mappend` 106 constField "title" "Archives" `mappend` 107 (postCtx allTags allCategories gitTimes) 108 109 makeItem "" 110 >>= loadAndApplyTemplate "templates/archive.html" archiveCtx 111 >>= loadAndApplyTemplate "templates/default.html" archiveCtx 112 >>= relativizeUrls 113 114 115 -- match "index.html" $ do 116 -- route idRoute 117 -- compile $ do 118 -- posts <- (myRecentFirst gitTimes) =<< loadAll "posts/**" 119 -- let indexCtx = mconcat [ 120 -- listField "posts" (postCtx allTags allCategories gitTimes) (return posts) 121 -- , constField "title" "Home" 122 -- , (postCtx allTags allCategories gitTimes) 123 -- ] 124 -- 125 -- getResourceBody 126 -- >>= applyAsTemplate indexCtx 127 -- >>= loadAndApplyTemplate "templates/default.html" indexCtx 128 -- >>= relativizeUrls 129 130 match "templates/*" $ compile templateCompiler 131 132 redirects <- fmap mconcat $ mapM getRedirects ids 133 134 -- Build redirect rule files; partially copied from tagsRules in 135 -- Hakyll/Web/Tags.hs 136 forM_ (tagsMap allCategories) $ \(categ, _) -> 137 create [fromFilePath $ "redirects/" ++ categ] $ do 138 route idRoute 139 compile $ do 140 -- The second argument of listField is the thing we can 141 -- render inside the for loop; i.e. if we define a field 142 -- named "redirect" as the second argument, then 143 -- $redirect$ will work in the for loop in the template. 144 let redirectCtx = listField "redirects" insideRedirectCtx $ 145 sequence $ map makeItem $ filter (\redirect -> (redirCategory redirect) == categ) redirects 146 147 makeItem "" 148 >>= applyAsTemplate redirectCtx 149 >>= loadAndApplyTemplate "templates/redirects" redirectCtx 150 >>= relativizeUrls 151 152 -- Post categories 153 tagsRules allCategories $ \category pattern -> do 154 let title = "Posts in category " ++ category 155 156 -- FIXME: Copied from posts, need to refactor 157 route idRoute 158 compile $ do 159 posts <- (myRecentFirst gitTimes) =<< loadAll pattern 160 let ctx = constField "title" title `mappend` 161 listField "posts" (postCtx allTags allCategories gitTimes) (return posts) `mappend` 162 (postCtx allTags allCategories gitTimes) 163 makeItem "" 164 >>= loadAndApplyTemplate "templates/post-list.html" ctx 165 >>= loadAndApplyTemplate "templates/default.html" ctx 166 >>= relativizeUrls 167 168 -- Post tags 169 tagsRules allTags $ \tag pattern -> do 170 let title = "Posts tagged " ++ tag 171 172 -- FIXME: Copied from posts, need to refactor 173 route idRoute 174 compile $ do 175 posts <- (myRecentFirst gitTimes) =<< loadAll pattern 176 let ctx = constField "title" title `mappend` 177 listField "posts" (postCtx allTags allCategories gitTimes) (return posts) `mappend` 178 (postCtx allTags allCategories gitTimes) 179 makeItem "" 180 >>= loadAndApplyTemplate "templates/post-list.html" ctx 181 >>= loadAndApplyTemplate "templates/default.html" ctx 182 >>= relativizeUrls 183 184 -- -- Create RSS feed as well 185 -- version "rss" $ do 186 -- route $ setExtension "xml" 187 -- compile $ loadAllSnapshots pattern "content" 188 -- >>= fmap (take 10) . (myRecentFirst gitTimes) 189 -- >>= renderRss (feedConfiguration title) feedCtx 190 191 192 -------------------------------------------------------------------------------- 193 194 -- Pulls the title metadata out for an item 195 getTitlePair :: MonadMetadata m => Identifier -> m [(String, FilePath)] 196 getTitlePair identifier = do 197 metadata <- getMetadataField identifier "title" 198 if isJust metadata then 199 return $ [(fromJust metadata, toFilePath $ identifier)] 200 else 201 return [] 202 203 dropPosts :: FilePath -> [FilePath] 204 dropPosts fp = drop 1 $ dropWhile (/= "posts") $ splitDirectories fp 205 206 -- Pulls the redirect metadata out for an item; pair is 207 -- (Category, Redirect) 208 getRedirects :: MonadMetadata m => Identifier -> m [Redirect] 209 getRedirects identifier = do 210 categ <- myGetCategory identifier 211 let path = joinPath $ dropPosts $ toFilePath identifier 212 redirect <- getMetadataField identifier "redirect" 213 if isJust redirect then 214 return $ [Redirect identifier (head categ) path (fromJust redirect)] 215 else 216 return [] 217 218 -- Get the first directory name after posts/ , call that the category 219 myGetCategory :: MonadMetadata m => Identifier -> m [String] 220 myGetCategory x = return $ take 1 $ dropPosts $ toFilePath x 221 222 titleCase :: String -> String 223 titleCase (hed:tale) = Char.toUpper hed : map Char.toLower tale 224 titleCase [] = [] 225 226 -- | Render the category in a link; mostly copied from https://github.com/jaspervdj/hakyll/blob/ea7d97498275a23fbda06e168904ee261f29594e/src/Hakyll/Web/Tags.hs 227 -- | 228 -- | Gets the category from the current item. 229 -- | The argument is the name of the field to generate. 230 myCategoryField :: String -> Bool -> Bool -> Context a 231 myCategoryField key linkify toTitleCase = field key $ \item -> do 232 tagBits <- myGetCategory $ itemIdentifier item 233 let tag = mconcat tagBits 234 if tag == "" then 235 if toTitleCase then 236 return $ "Meta" 237 else 238 return $ "meta" 239 else 240 if linkify then 241 return $ renderHtml $ myCatLink tag 242 else 243 if toTitleCase then 244 return $ titleCase tag 245 else 246 return $ tag 247 248 -- | Render the category as a link to its section (i.e. emits 249 -- "/computing", for example). 250 myCatLink :: String -> H.Html 251 myCatLink cat = H.a ! A.href (toValue $ toUrl ("/" ++ cat)) $ toHtml cat 252 253 -- | Render one tag link ; copied from https://github.com/jaspervdj/hakyll/blob/ea7d97498275a23fbda06e168904ee261f29594e/src/Hakyll/Web/Tags.hs 254 simpleRenderLink :: String -> (Maybe FilePath) -> Maybe H.Html 255 simpleRenderLink _ Nothing = Nothing 256 simpleRenderLink tag (Just filePath) = 257 Just $ H.a ! A.href (toValue $ toUrl filePath) $ toHtml tag 258 259 -- | Obtain tags from a page in the default way: parse them from the @tags@ 260 -- metadata field. 261 -- 262 --does stuff with categories and : and stuff; maybe explain in 263 --DESIGN-CODE 264 -- 265 -- FIXME: exmaple 266 myGetTags :: MonadMetadata m => Identifier -> m [String] 267 myGetTags identifier = do 268 tags <- getTags identifier 269 let maintags = map (intercalate "+") $ drop 1 $ subsequences $ sort tags 270 cat <- myGetCategory identifier 271 return $ maintags ++ cat ++ (map (\x -> (head cat) ++ ":" ++ x) maintags) 272 273 getHeaders :: Block -> [(String, String)] 274 getHeaders (Header _ (slug, _, _) xs) = 275 [(str, slug)] 276 where 277 str = case runPure $ writePlain def $ Pandoc nullMeta $ [Plain xs] of 278 Left (PandocSomeError err) -> "hblog getHeaders: unknown error: " ++ err 279 Left _ -> "hblog getHeaders: unknown error!" 280 Right item' -> T.unpack item' 281 getHeaders _ = [] 282 283 titleFixer :: [(String, FilePath)] -> Pandoc -> Pandoc 284 titleFixer titles doc = 285 let headers = query getHeaders doc in 286 walk (titleFixerInternal titles headers) doc 287 288 fixPath :: FilePath -> FilePath 289 fixPath path = 290 if takeExtension path == ".md" then 291 "/" </> replaceExtension path ".html" 292 else 293 "/" </> path 294 295 titleFixerInternal :: [(String, FilePath)] -> [(String, String)] -> Inline -> Inline 296 -- titleFixerInternal titles link@(Link _ _ (url, _)) | trace ("url: " ++ (show url) ++ ", titles: " ++ (show titles)) False = undefined 297 titleFixerInternal titles headers link@(Link x text (rawURL, z)) = 298 let fixedURL = unEscapeString rawURL 299 maybePath = lookup fixedURL titles 300 maybeHeader = lookup fixedURL headers 301 fixedText = 302 if length text == 0 then 303 [Str fixedURL] 304 else 305 text 306 in 307 if isJust maybePath then 308 let newURL = "/" </> replaceExtension (fromJust maybePath) ".html" in 309 Link x fixedText (newURL, z) 310 else 311 if isJust maybeHeader then 312 Link x fixedText ("#" ++ (fromJust maybeHeader), z) 313 else 314 link 315 titleFixerInternal _ _ x = x 316 317 --------------------------- Date Handling ------------------------------ 318 319 data GitTimes = GitTimes { gtid :: Identifier, gtlatest :: UTCTime, gtinitial :: UTCTime } deriving (Ord, Eq, Show) 320 321 -- Pull the most and least recent git times for a file out of git 322 -- using the git command line tool 323 getGitTimes :: Identifier -> IO [GitTimes] 324 getGitTimes identifier = do 325 let path = toFilePath identifier 326 let gitRepoPath = "posts/" 327 -- Strip off the "posts/" part 328 let gitFilePath = joinPath $ dropPosts path 329 330 (exit1, stdout1, stderr1) <- readProcessWithExitCode "git" ["-C", gitRepoPath, "log", "--diff-filter=A", "--follow", "--format=%ai", "-n", "1", "--", gitFilePath] "" 331 if exit1 /= ExitSuccess then 332 do fail $ "getGitTimes: Couldn't get the date of the first commit for " ++ path ++ ", error: " ++ stderr1 333 else 334 return () 335 336 if stdout1 == "" then 337 do fail $ "getGitTimes: The last commit date for " ++ path ++ " was blank, which means it needs to be checked in.\n\n\nA run of munge_files.sh should clear this right up.\n\n" 338 else 339 return () 340 341 let origtimeMaybe = readMaybe stdout1 :: Maybe UTCTime 342 -- let origtime = read (trace ("std: " ++ stdout1 ++ ", " ++ stderr1) stdout1) :: ZonedTime 343 if isNothing origtimeMaybe then 344 do fail $ "getGitTimes: couldn't parse " ++ stdout1 ++ " as a date, which was supposed to be the orig date for " ++ path ++ ". This error message might help: " ++ stderr1 345 else 346 return () 347 348 (exit2, stdout2, stderr2) <- readProcessWithExitCode "git" ["-C", gitRepoPath, "log", "--format=%ai", "-n", "1", gitFilePath] "" 349 if exit2 /= ExitSuccess then 350 do fail $ "getGitTimes: Couldn't get the date of the latest/last commit for " ++ path 351 else 352 return () 353 let curtimeMaybe = readMaybe stdout2 :: Maybe UTCTime 354 -- let curtime = read (trace ("std: " ++ stdout2 ++ ", " ++ stderr2) stdout2) :: ZonedTime 355 if isNothing curtimeMaybe then 356 do fail $ "getGitTimes: couldn't parse " ++ stdout2 ++ " as a date, which was supposed to be the orig date for " ++ path ++ ". This error message might help: " ++ stderr2 357 else 358 return () 359 360 return [GitTimes identifier (fromJust curtimeMaybe) (fromJust origtimeMaybe)] 361 362 -- Returns a function that turns an identifier into a string 363 -- representing a time pullud out of GitTimes 364 gitTimeToField :: [GitTimes] -> (GitTimes -> UTCTime) -> (Item String -> Compiler String) 365 gitTimeToField times typeF = \ident -> return $ formatTime defaultTimeLocale "%B %e, %Y" $ getGitTimeUTC (itemIdentifier ident) times typeF 366 367 -- Pull a file's time out of the list 368 getGitTimeUTC :: Identifier -> [GitTimes] -> (GitTimes -> UTCTime) -> UTCTime 369 getGitTimeUTC ident times typeF = 370 let timeList = filter (\x -> ident == (gtid x)) times in 371 if length timeList /= 1 then 372 -- It's not obvious to me how this could occur even in theory; I'd expect it to error out during getGitTimes 373 error $ "getGitTimeUTC: Couldn't find the time for " ++ (show ident) ++ " in GitTimes list " ++ (show times) 374 else 375 typeF $ head timeList 376 377 -- Returns a function that sorts a list of items using getGitTimeUTC 378 myRecentFirst :: MonadMetadata m =>[GitTimes] -> [Item a] -> m [Item a] 379 myRecentFirst gtimes = recentFirstWith $ (\x -> getGitTimeUTC x gtimes gtlatest) 380 381 -- Check for header metadata with the given names, and fail if 382 -- found. In particular, the only date field we allow is orig_date; 383 -- the rest come from git 384 failIfMetadatas :: Show a => [String] -> Context a 385 failIfMetadatas mds = field "check_bad_fields" $ \ident -> do 386 imd <- getMetadata $ itemIdentifier ident 387 return $ mconcat $ map (checkMD ident imd) mds 388 where 389 checkMD ident imd md = do 390 let mmdf = lookupString md imd in 391 if isJust mmdf then 392 error $ "While generating post context, we found you using the field \"" ++ md ++ "\", which we don't support, in file " ++ (show $ itemIdentifier ident) 393 else 394 "" 395 396 -- This only exists because dateFieldWithFallback needs a monadic 397 -- UTCTime generator 398 getGitTimeUTCCompiler :: [GitTimes] -> (GitTimes -> UTCTime) -> Identifier -> Compiler UTCTime 399 getGitTimeUTCCompiler gtimes typeF ident = return $ getGitTimeUTC ident gtimes typeF 400 401 -- Most of this is from makeLink in renderTagCloud in hakyll-4.9.0.0/src/Hakyll/Web/Tags.hs 402 makeNumberedTagLink :: Double -> Double -> String -> String -> Int -> Int -> Int -> String 403 makeNumberedTagLink minSize maxSize tag url count min' max' = 404 -- Show the relative size of one 'count' in percent 405 let diff = 1 + fromIntegral max' - fromIntegral min' 406 relative = (fromIntegral count - fromIntegral min') / diff 407 size = floor $ minSize + relative * (maxSize - minSize) :: Int 408 in renderHtml $ 409 H.a ! A.style (toValue $ "font-size: " ++ show size ++ "%") 410 ! A.href (toValue url) 411 $ toHtml $ tag ++ " (" ++ (show count) ++ ") " 412 413 -- What we're trying to do is produce a field that *doesn't* match 414 -- key in the case where the metadata "header" is not set to "no" or 415 -- "false"; matching it and returning false or whatever 416 -- (makeHeaderField above) isn't working, so any call to "field" is 417 -- guaranteed to not work 418 makeHeaderField :: String -> Context a 419 makeHeaderField key = Context $ \k _ i -> do 420 if key == k then do 421 value <- getMetadataField (itemIdentifier i) "header" 422 if isJust value then 423 if elem (fromJust value) [ "no", "No", "false", "False" ] then 424 -- Compiler is an instance of Alternative from 425 -- Control.Applicative ; see Hakyll/Core/Compiler/Internal.hs 426 CA.empty 427 else 428 return $ StringField $ fromJust value 429 else 430 return $ StringField "yes makeheader" 431 else 432 CA.empty 433 434 -- Construct our $ replacement stuff 435 postCtx :: Tags -> Tags -> [GitTimes] -> Context String 436 postCtx allTags allCategories gtimes = mconcat 437 [ tagCloudFieldWith "tagCloud" makeNumberedTagLink (intercalate " ") 80 200 allTags 438 -- We don't actually want to expose the categories normally 439 -- , tagCloudField "categories" 120 200 categories 440 441 -- Give a way to link absolutely back to the main site 442 , constField "homeURL" baseURL 443 444 -- We always use the last_mod_date from git; if you want to 445 -- override that, make a new git commit and use --date 446 , field "last_mod_date" (gitTimeToField gtimes gtlatest) 447 -- In fact, we explicitely fail if you try to use it from header 448 -- metadata 449 , failIfMetadatas ["last_mod_date", "date", "published"] 450 -- For orig_date, though, if you specify it in the metadata we 451 -- take that, whether it parses or not, otherwise we use git 452 , dateFieldWithFallback defaultTimeLocale ((flip getMetadataField) "orig_date") (getGitTimeUTCCompiler gtimes gtinitial) "orig_date" "%B %e, %Y" 453 , constField "gitTimes" $ show gtimes 454 -- This one is weird: the allTags we pass are *not* the tags it 455 -- renders; it gets the tags from the file with getTags, the 456 -- tags we pass are how it knows what the (textual) tags on the 457 -- item point at. 458 , tagsField "tags" allTags 459 -- , field "category" $ (fmap . fmap) (myCatLink . mconcat) $ myGetCategory . itemIdentifier 460 , myCategoryField "category" True False 461 , myCategoryField "categoryText" False False 462 , myCategoryField "categoryTextCap" False True 463 -- Below is the contents of defaultContext, except for 464 -- titleField; titleField is a default in case metadata has no 465 -- title, and we want to error out in that case. 466 , bodyField "body" 467 , metadataField 468 , urlField "url" 469 , pathField "path" 470 471 -- An artificial field that only exists if "header: no" is not 472 -- set. 473 , makeHeaderField "makeheader" 474 475 , missingField 476 ] 477 478 -- Construct our $ replacement stuff for the special case of the 479 -- redirects file 480 insideRedirectCtx :: Context Redirect 481 insideRedirectCtx = mconcat 482 [ field "path" $ return . redirPath . itemBody 483 , field "category" $ return . redirCategory . itemBody 484 , field "redirect" $ return . redirPattern . itemBody 485 , constField "homeURL" baseURL 486 , missingField 487 ] 488 --------------------------- Extra Date Handling ------------------------------ 489 -- "With" versions of stuff from 490 -- hakyll-4.9.0.0/src/Hakyll/Web/Template/List.hs (chronological / 491 -- recentFirst) and 492 -- hakyll-4.9.0.0/src/Hakyll/Web/Template/Context.hs (getItemUTC, 493 -- dateField) 494 495 -------------------------------------------------------------------------------- 496 -- | Defines a date field by parsing the given string, if it exists; 497 -- if not, uses the UTCTime given instead. 498 -- 499 -- The use case here was "use the metadata field if it exists, 500 -- otherwise get UTCTime values from git". 501 dateFieldWithFallback :: TimeLocale -- ^ Output time locale 502 -> (Identifier -> Compiler (Maybe String)) -- ^ Function that returns a string to turn into a date; 503 -- if Just, then we use this value, even if it doesn't parse as a date 504 -> (Identifier -> Compiler UTCTime) -- ^ Function that returns a date to use if the string is a Nothing 505 -> String -- ^ Destination key 506 -> String -- ^ Format to use on the date 507 -> Context a -- ^ Resulting context 508 dateFieldWithFallback locale getDateString getDateUTC key format = field key $ \i -> do 509 let ident = itemIdentifier i 510 maybeDateString <- getDateString ident 511 dateUTC <- getDateUTC ident 512 if isJust maybeDateString then 513 do 514 time <- stringToUTC (fromJust maybeDateString) defaultTimeLocale ident 515 return $ formatTime locale format time 516 else 517 do return $ formatTime locale format dateUTC 518 519 520 -------------------------------------------------------------------------------- 521 -- | Does the actual parsing for dateFieldWithFallback; in 522 -- hakyll-4.9.0.0/src/Hakyll/Web/Template/Context.hs this was called 523 -- getItemUTC, but I moved the actual Item part outwards. 524 stringToUTC :: MonadMetadata m 525 => String -- ^ The string to try to parse as a date 526 -> TimeLocale -- ^ Output time locale 527 -> Identifier -- ^ Used to generate an error message 528 -> m UTCTime -- ^ Parsed UTCTime 529 stringToUTC dateString locale ident = do 530 let tryFmt fmt = parseTime' fmt dateString 531 532 maybe empty' return $ msum [tryFmt fmt | fmt <- formats] 533 where 534 empty' = fail $ "Hakyll.Web.Template.Context.getItemUTC: " ++ 535 "could not parse time for " ++ show ident 536 parseTime' = parseTimeM True locale 537 formats = 538 [ "%a, %d %b %Y %H:%M:%S %Z" 539 , "%Y-%m-%dT%H:%M:%S%Z" 540 , "%Y-%m-%d %H:%M:%S%Z" 541 , "%Y-%m-%d" 542 , "%B %e, %Y %l:%M %p" 543 , "%B %e, %Y" 544 , "%b %d, %Y" 545 ] 546 547 -------------------------------------------------------------------------------- 548 -- | Sort pages chronologically, using whatever function you pass to 549 -- generate the dates. 550 chronologicalWith :: MonadMetadata m 551 => (Identifier -> UTCTime) -- ^ Function that returns the date value for an identifier 552 -> [Item a] -- ^ The items to sort 553 -> m [Item a] 554 chronologicalWith getDate = 555 sortByM $ (\x -> return $ getDate $ itemIdentifier x) 556 where 557 sortByM :: (Monad m, Ord k) => (a -> m k) -> [a] -> m [a] 558 sortByM f xs = liftM (map fst . sortBy (comparing snd)) $ 559 mapM (\x -> liftM (x,) (f x)) xs 560 561 562 -------------------------------------------------------------------------------- 563 -- | The reverse of 'chronological' 564 recentFirstWith :: MonadMetadata m 565 => (Identifier -> UTCTime) -- ^ Function that returns the date value for an identifier 566 -> [Item a] -- ^ The items to sort 567 -> m [Item a] 568 recentFirstWith getDate items = fmap reverse $ chronologicalWith getDate items 569 570 571