diff --git a/hakyll.cabal b/hakyll.cabal --- a/hakyll.cabal +++ b/hakyll.cabal @@ -1,5 +1,5 @@ Name: hakyll -Version: 4.5.3.0 +Version: 4.5.4.0 Synopsis: A static website compiler library Description: @@ -153,12 +153,12 @@ directory >= 1.0 && < 1.3, filepath >= 1.0 && < 1.4, lrucache >= 1.1.1 && < 1.2, - mtl >= 1 && < 2.2, - network >= 2.4 && < 2.6, + mtl >= 1 && < 2.3, + network >= 2.4 && < 2.7, old-locale >= 1.0 && < 1.1, old-time >= 1.0 && < 1.2, - pandoc >= 1.12.4 && < 1.13, - pandoc-citeproc >= 0.1 && < 0.4, + pandoc >= 1.12.4 && < 1.14, + pandoc-citeproc >= 0.4 && < 0.5, parsec >= 3.0 && < 3.2, process >= 1.0 && < 1.3, random >= 1.0 && < 1.1, @@ -239,12 +239,12 @@ directory >= 1.0 && < 1.3, filepath >= 1.0 && < 1.4, lrucache >= 1.1.1 && < 1.2, - mtl >= 1 && < 2.2, - network >= 2.4 && < 2.6, + mtl >= 1 && < 2.3, + network >= 2.4 && < 2.7, old-locale >= 1.0 && < 1.1, old-time >= 1.0 && < 1.2, - pandoc >= 1.12.4 && < 1.13, - pandoc-citeproc >= 0.1 && < 0.4, + pandoc >= 1.12.4 && < 1.14, + pandoc-citeproc >= 0.4 && < 0.5, parsec >= 3.0 && < 3.2, process >= 1.0 && < 1.3, random >= 1.0 && < 1.1, diff --git a/src/Hakyll/Init.hs b/src/Hakyll/Init.hs --- a/src/Hakyll/Init.hs +++ b/src/Hakyll/Init.hs @@ -5,11 +5,15 @@ -------------------------------------------------------------------------------- +import Control.Arrow (first) import Control.Monad (forM_) -import System.Directory (copyFile) +import Data.Char (isAlphaNum, isNumber) +import Data.List (intercalate) +import Data.Version (Version(..)) +import System.Directory (copyFile, canonicalizePath) import System.Environment (getArgs, getProgName) import System.Exit (exitFailure) -import System.FilePath (()) +import System.FilePath ((), splitDirectories) -------------------------------------------------------------------------------- @@ -26,12 +30,52 @@ files <- getRecursiveContents (const $ return False) srcDir case args of - [dstDir] -> forM_ files $ \file -> do - let dst = dstDir file - src = srcDir file - putStrLn $ "Creating " ++ dst - makeDirectories dst - copyFile src dst + [dstDir] -> do + forM_ files $ \file -> do + let dst = dstDir file + src = srcDir file + putStrLn $ "Creating " ++ dst + makeDirectories dst + copyFile src dst + -- canonicalizePath is safe because the destination + -- directory should exist at this point + canonicalizePath dstDir >>= createCabal _ -> do putStrLn $ "Usage: " ++ progName ++ " " exitFailure + + +createCabal :: FilePath -> IO () +createCabal dstDir = do + putStrLn $ "Creating " ++ name ++ ".cabal" + writeFile (dstDir name ++ ".cabal") $ unlines [ + "name: " ++ name + , "version: 0.1.0.0" + , "build-type: Simple" + , "cabal-version: >= 1.10" + , "" + , "executable site" + , " main-is: site.hs" + , " build-depends: base == 4.*" + , " , hakyll == " ++ version' ++ ".*" + , " ghc-options: -threaded" + , " default-language: Haskell2010" + ] + where + -- Major hakyll version + version' = intercalate "." . take 2 . map show $ versionBranch version + -- last is safe here as the path is canonicalised and "/" is just + -- a very rare but possible corner case + name = case last (splitDirectories dstDir) of + "/" -> fallbackName + x -> repair (fallbackName ++) id x + -- Package name repair code comes from + -- cabal-install.Distribution.Client.Init.Heuristics + repair invalid valid x = case dropWhile (not . isAlphaNum) x of + "" -> repairComponent "" + x' -> let (c, r) = first repairComponent $ break (not . isAlphaNum) x' + in c ++ repairRest r + where repairComponent c | all isNumber c = invalid c + | otherwise = valid c + repairRest = repair id ('-' :) + fallbackName = "site" diff --git a/src/Hakyll/Web/Html.hs b/src/Hakyll/Web/Html.hs --- a/src/Hakyll/Web/Html.hs +++ b/src/Hakyll/Web/Html.hs @@ -36,7 +36,7 @@ -------------------------------------------------------------------------------- -- | Map over all tags in the document withTags :: (TS.Tag String -> TS.Tag String) -> String -> String -withTags f = renderTags' . map f . TS.parseTags +withTags f = renderTags' . map f . parseTags' -------------------------------------------------------------------------------- @@ -77,9 +77,10 @@ -- | Customized TagSoup renderer. The default TagSoup renderer escape CSS -- within style tags, and doesn't properly minimize. renderTags' :: [TS.Tag String] -> String -renderTags' = TS.renderTagsOptions TS.renderOptions +renderTags' = TS.renderTagsOptions TS.RenderOptions { TS.optRawTag = (`elem` ["script", "style"]) . map toLower , TS.optMinimize = (`S.member` minimize) . map toLower + , TS.optEscape = id } where -- A list of elements which must be minimized @@ -87,6 +88,15 @@ [ "area", "br", "col", "embed", "hr", "img", "input", "meta", "link" , "param" ] + + +-------------------------------------------------------------------------------- +-- | Customized TagSoup parser: do not decode any entities. +parseTags' :: String -> [TS.Tag String] +parseTags' = TS.parseTagsOptions (TS.parseOptions :: TS.ParseOptions String) + { TS.optEntityData = \(str, b) -> [TS.TagText $ "&" ++ str ++ [';' | b]] + , TS.optEntityAttrib = \(str, b) -> ("&" ++ str ++ [';' | b], []) + } -------------------------------------------------------------------------------- diff --git a/src/Hakyll/Web/Paginate.hs b/src/Hakyll/Web/Paginate.hs --- a/src/Hakyll/Web/Paginate.hs +++ b/src/Hakyll/Web/Paginate.hs @@ -3,8 +3,8 @@ module Hakyll.Web.Paginate ( PageNumber , Paginate (..) - , buildPaginate , buildPaginateWith + , paginateEvery , paginateRules , paginateContext ) where @@ -12,11 +12,9 @@ -------------------------------------------------------------------------------- import Control.Monad (forM_) -import Data.List (unfoldr) import qualified Data.Map as M import Data.Monoid (mconcat) import qualified Data.Set as S -import Text.Printf (printf) -------------------------------------------------------------------------------- @@ -37,99 +35,93 @@ -------------------------------------------------------------------------------- -- | Data about paginators data Paginate = Paginate - { paginatePages :: M.Map PageNumber [Identifier] - , paginatePlaces :: M.Map Identifier PageNumber + { paginateMap :: M.Map PageNumber [Identifier] , paginateMakeId :: PageNumber -> Identifier , paginateDependency :: Dependency } deriving (Show) -------------------------------------------------------------------------------- -buildPaginate :: MonadMetadata m - => Pattern - -> m Paginate -buildPaginate pattern = do - idents <- getMatches pattern - let pagPages = M.fromList $ zip [1 ..] (map return idents) - pagPlaces = M.fromList $ zip idents [1 ..] - makeId pn = case M.lookup pn pagPages of - Just [id'] -> id' - _ -> error $ - "Hakyll.Web.Paginate.buildPaginate: " ++ - "invalid page number: " ++ show pn - - return $ Paginate pagPages pagPlaces makeId - (PatternDependency pattern (S.fromList idents)) +paginateNumPages :: Paginate -> Int +paginateNumPages = M.size . paginateMap -------------------------------------------------------------------------------- -buildPaginateWith :: MonadMetadata m - => Int - -> (PageNumber -> Identifier) - -> Pattern - -> m Paginate -buildPaginateWith n makeId pattern = do - -- TODO: there is no sensible order for `ids` here, for now it's random; - -- but it should be `resectFirst` order because most recent posts should - -- correspond to 1st paginator page and oldest one to last page - idents <- getMatches pattern - let pages = flip unfoldr idents $ \xs -> - if null xs then Nothing else Just (splitAt n xs) - nPages = length pages - paginatePages' = zip [1..] pages - pagPlaces' = - [(ident, idx) | (idx,ids) <- paginatePages', ident <- ids] ++ - [(makeId i, i) | i <- [1 .. nPages]] +paginateEvery :: Int -> [a] -> [[a]] +paginateEvery n = go + where + go [] = [] + go xs = let (y, ys) = splitAt n xs in y : go ys - return $ Paginate (M.fromList paginatePages') (M.fromList pagPlaces') makeId - (PatternDependency pattern (S.fromList idents)) +-------------------------------------------------------------------------------- +buildPaginateWith + :: MonadMetadata m + => ([Identifier] -> m [[Identifier]]) -- ^ Group items into pages + -> Pattern -- ^ Select items to paginate + -> (PageNumber -> Identifier) -- ^ Identifiers for the pages + -> m Paginate +buildPaginateWith grouper pattern makeId = do + ids <- getMatches pattern + idGroups <- grouper ids + let idsSet = S.fromList ids + return Paginate + { paginateMap = M.fromList (zip [1 ..] idGroups) + , paginateMakeId = makeId + , paginateDependency = PatternDependency pattern idsSet + } + -------------------------------------------------------------------------------- paginateRules :: Paginate -> (PageNumber -> Pattern -> Rules ()) -> Rules () paginateRules paginator rules = - forM_ (M.toList $ paginatePages paginator) $ \(idx, identifiers) -> - create [paginateMakeId paginator idx] $ - rulesExtraDependencies [paginateDependency paginator] $ + forM_ (M.toList $ paginateMap paginator) $ \(idx, identifiers) -> + rulesExtraDependencies [paginateDependency paginator] $ + create [paginateMakeId paginator idx] $ rules idx $ fromList identifiers -------------------------------------------------------------------------------- --- | Takes first, current, last page and produces index of next page -type RelPage = PageNumber -> PageNumber -> PageNumber -> Maybe PageNumber +-- | Get the identifier for a certain page by passing in the page number. +paginatePage :: Paginate -> PageNumber -> Maybe Identifier +paginatePage pag pageNumber + | pageNumber < 1 = Nothing + | pageNumber > (paginateNumPages pag) = Nothing + | otherwise = Just $ paginateMakeId pag pageNumber -------------------------------------------------------------------------------- -paginateField :: Paginate -> String -> RelPage -> Context a -paginateField pag fieldName relPage = field fieldName $ \item -> - let identifier = itemIdentifier item - in case M.lookup identifier (paginatePlaces pag) of - Nothing -> fail $ printf - "Hakyll.Web.Paginate: there is no page %s in paginator map." - (show identifier) - Just pos -> case relPage 1 pos nPages of - Nothing -> fail "Hakyll.Web.Paginate: No page here." - Just pos' -> do - let nextId = paginateMakeId pag pos' - mroute <- getRoute nextId - case mroute of - Nothing -> fail $ printf - "Hakyll.Web.Paginate: unable to get route for %s." - (show nextId) - Just rt -> return $ toUrl rt +-- | A default paginate context which provides the following keys: +-- +-- +paginateContext :: Paginate -> PageNumber -> Context a +paginateContext pag currentPage = mconcat + [ field "firstPageNum" $ \_ -> otherPage 1 >>= num + , field "firstPageUrl" $ \_ -> otherPage 1 >>= url + , field "previousPageNum" $ \_ -> otherPage (currentPage - 1) >>= num + , field "previousPageUrl" $ \_ -> otherPage (currentPage - 1) >>= url + , field "nextPageNum" $ \_ -> otherPage (currentPage + 1) >>= num + , field "nextPageUrl" $ \_ -> otherPage (currentPage + 1) >>= url + , field "lastPageNum" $ \_ -> otherPage lastPage >>= num + , field "lastPageUrl" $ \_ -> otherPage lastPage >>= url + , field "currentPageNum" $ \i -> thisPage i >>= num + , field "currentPageUrl" $ \i -> thisPage i >>= url + , constField "numPages" $ show $ paginateNumPages pag + ] where - nPages = M.size (paginatePages pag) + lastPage = paginateNumPages pag + thisPage i = return (currentPage, itemIdentifier i) + otherPage n + | n == currentPage = fail $ "This is the current page: " ++ show n + | otherwise = case paginatePage pag n of + Nothing -> fail $ "No such page: " ++ show n + Just i -> return (n, i) --------------------------------------------------------------------------------- -paginateContext :: Paginate -> Context a -paginateContext pag = mconcat - [ paginateField pag "firstPage" - (\f c _ -> if c <= f then Nothing else Just f) - , paginateField pag "previousPage" - (\f c _ -> if c <= f then Nothing else Just (c - 1)) - , paginateField pag "nextPage" - (\_ c l -> if c >= l then Nothing else Just (c + 1)) - , paginateField pag "lastPage" - (\_ c l -> if c >= l then Nothing else Just l) - ] + num :: (Int, Identifier) -> Compiler String + num = return . show . fst + + url :: (Int, Identifier) -> Compiler String + url (n, i) = getRoute i >>= \mbR -> case mbR of + Just r -> return $ toUrl r + Nothing -> fail $ "No URL for page: " ++ show n diff --git a/src/Hakyll/Web/Pandoc/Biblio.hs b/src/Hakyll/Web/Pandoc/Biblio.hs --- a/src/Hakyll/Web/Pandoc/Biblio.hs +++ b/src/Hakyll/Web/Pandoc/Biblio.hs @@ -90,7 +90,7 @@ -> Compiler (Item Pandoc) readPandocBiblio ropt csl biblio item = do -- Parse CSL file, if given - style <- unsafeCompiler $ CSL.readCSLFile . toFilePath . itemIdentifier $ csl + style <- unsafeCompiler $ CSL.readCSLFile Nothing . toFilePath . itemIdentifier $ csl -- We need to know the citation keys, add then *before* actually parsing the -- actual page. If we don't do this, pandoc won't even consider them diff --git a/src/Hakyll/Web/Template/List.hs b/src/Hakyll/Web/Template/List.hs --- a/src/Hakyll/Web/Template/List.hs +++ b/src/Hakyll/Web/Template/List.hs @@ -13,6 +13,8 @@ , applyJoinTemplateList , chronological , recentFirst + , sortChronological + , sortRecentFirst ) where @@ -25,6 +27,7 @@ -------------------------------------------------------------------------------- import Hakyll.Core.Compiler +import Hakyll.Core.Identifier import Hakyll.Core.Item import Hakyll.Core.Metadata import Hakyll.Web.Template @@ -65,7 +68,24 @@ sortByM f xs = liftM (map fst . sortBy (comparing snd)) $ mapM (\x -> liftM (x,) (f x)) xs + -------------------------------------------------------------------------------- -- | The reverse of 'chronological' -recentFirst :: (MonadMetadata m, Functor m) => [Item a] -> m [Item a] -recentFirst = fmap reverse . chronological +recentFirst :: MonadMetadata m => [Item a] -> m [Item a] +recentFirst = liftM reverse . chronological + + +-------------------------------------------------------------------------------- +-- | Version of 'chronological' which doesn't need the actual items. +sortChronological + :: MonadMetadata m => [Identifier] -> m [Identifier] +sortChronological ids = + liftM (map itemIdentifier) $ chronological [Item i () | i <- ids] + + +-------------------------------------------------------------------------------- +-- | Version of 'recentFirst' which doesn't need the actual items. +sortRecentFirst + :: MonadMetadata m => [Identifier] -> m [Identifier] +sortRecentFirst ids = + liftM (map itemIdentifier) $ recentFirst [Item i () | i <- ids]