summaryrefslogtreecommitdiff
path: root/src/Hakyll
diff options
context:
space:
mode:
Diffstat (limited to 'src/Hakyll')
-rw-r--r--src/Hakyll/Commands.hs37
-rw-r--r--src/Hakyll/Core/Compiler/Internal.hs3
-rw-r--r--src/Hakyll/Core/Configuration.hs6
-rw-r--r--src/Hakyll/Core/Dependencies.hs6
-rw-r--r--src/Hakyll/Core/Metadata.hs14
-rw-r--r--src/Hakyll/Core/Provider/Internal.hs7
-rw-r--r--src/Hakyll/Core/Provider/Metadata.hs37
-rw-r--r--src/Hakyll/Core/Rules/Default.hs24
-rw-r--r--src/Hakyll/Core/Runtime.hs5
-rw-r--r--src/Hakyll/Core/UnixFilter.hs19
-rw-r--r--src/Hakyll/Init.hs60
-rw-r--r--src/Hakyll/Main.hs22
-rw-r--r--src/Hakyll/Preview/Server.hs7
-rw-r--r--src/Hakyll/Web/Html.hs1
-rw-r--r--src/Hakyll/Web/Paginate.hs147
-rw-r--r--src/Hakyll/Web/Pandoc.hs1
-rw-r--r--src/Hakyll/Web/Tags.hs8
-rw-r--r--src/Hakyll/Web/Template/List.hs24
18 files changed, 229 insertions, 199 deletions
diff --git a/src/Hakyll/Commands.hs b/src/Hakyll/Commands.hs
index 7951f4e..8db889c 100644
--- a/src/Hakyll/Commands.hs
+++ b/src/Hakyll/Commands.hs
@@ -9,13 +9,15 @@ module Hakyll.Commands
, rebuild
, server
, deploy
- , watch
+ , watch
) where
--------------------------------------------------------------------------------
import System.Exit (exitWith, ExitCode)
+import System.IO.Error (catchIOError)
import Control.Applicative
+import Control.Monad (void)
import Control.Concurrent
--------------------------------------------------------------------------------
@@ -67,7 +69,7 @@ preview :: Configuration -> Verbosity -> Rules a -> Int -> IO ()
#ifdef PREVIEW_SERVER
preview conf verbosity rules port = do
deprecatedMessage
- watch conf verbosity port True rules
+ watch conf verbosity "0.0.0.0" port True rules
where
deprecatedMessage = mapM_ putStrLn [ "The preview command has been deprecated."
, "Use the watch command for recompilation and serving."
@@ -80,22 +82,27 @@ preview _ _ _ _ = previewServerDisabled
--------------------------------------------------------------------------------
-- | Watch and recompile for changes
-watch :: Configuration -> Verbosity -> Int -> Bool -> Rules a -> IO ()
+watch :: Configuration -> Verbosity -> String -> Int -> Bool -> Rules a -> IO ()
#ifdef WATCH_SERVER
-watch conf verbosity port runServer rules = do
- watchUpdates conf update
- _ <- forkIO (server')
- loop
+watch conf verbosity host port runServer rules = do
+#ifndef mingw32_HOST_OS
+ _ <- forkIO $ watchUpdates conf update
+#else
+ -- Force windows users to compile with -threaded flag, as otherwise
+ -- thread is blocked indefinitely.
+ catchIOError (void $ forkOS $ watchUpdates conf update) $ do
+ fail $ "Hakyll.Commands.watch: Could not start update watching " ++
+ "thread. Did you compile with -threaded flag?"
+#endif
+ server'
where
update = do
(_, ruleSet) <- run conf verbosity rules
return $ rulesPattern ruleSet
-
loop = threadDelay 100000 >> loop
-
- server' = if runServer then server conf port else return ()
+ server' = if runServer then server conf host port else loop
#else
-watch _ _ _ _ _ = watchServerDisabled
+watch _ _ _ _ _ _ = watchServerDisabled
#endif
--------------------------------------------------------------------------------
@@ -106,15 +113,15 @@ rebuild conf verbosity rules =
--------------------------------------------------------------------------------
-- | Start a server
-server :: Configuration -> Int -> IO ()
+server :: Configuration -> String -> Int -> IO ()
#ifdef PREVIEW_SERVER
-server conf port = do
+server conf host port = do
let destination = destinationDirectory conf
- staticServer destination preServeHook port
+ staticServer destination preServeHook host port
where
preServeHook _ = return ()
#else
-server _ _ = previewServerDisabled
+server _ _ _ = previewServerDisabled
#endif
diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs
index 259cd35..8424d69 100644
--- a/src/Hakyll/Core/Compiler/Internal.hs
+++ b/src/Hakyll/Core/Compiler/Internal.hs
@@ -248,5 +248,6 @@ compilerGetMatches :: Pattern -> Compiler [Identifier]
compilerGetMatches pattern = do
universe <- compilerUniverse <$> compilerAsk
let matching = filterMatches pattern $ S.toList universe
- compilerTellDependencies [PatternDependency pattern matching]
+ set' = S.fromList matching
+ compilerTellDependencies [PatternDependency pattern set']
return matching
diff --git a/src/Hakyll/Core/Configuration.hs b/src/Hakyll/Core/Configuration.hs
index f9927de..52b23ec 100644
--- a/src/Hakyll/Core/Configuration.hs
+++ b/src/Hakyll/Core/Configuration.hs
@@ -69,6 +69,11 @@ data Configuration = Configuration
, -- | Use an in-memory cache for items. This is faster but uses more
-- memory.
inMemoryCache :: Bool
+ , -- | Override default host for preview server. Default is "127.0.0.1",
+ -- which binds only on the loopback address.
+ -- One can also override the host as a command line argument:
+ -- ./site preview -h "0.0.0.0"
+ previewHost :: String
, -- | Override default port for preview server. Default is 8000.
-- One can also override the port as a command line argument:
-- ./site preview -p 1234
@@ -91,6 +96,7 @@ defaultConfiguration = Configuration
, deployCommand = "echo 'No deploy command specified' && exit 1"
, deploySite = system . deployCommand
, inMemoryCache = True
+ , previewHost = "127.0.0.1"
, previewPort = 8000
}
where
diff --git a/src/Hakyll/Core/Dependencies.hs b/src/Hakyll/Core/Dependencies.hs
index 7597e61..ebb6fd0 100644
--- a/src/Hakyll/Core/Dependencies.hs
+++ b/src/Hakyll/Core/Dependencies.hs
@@ -32,7 +32,7 @@ import Hakyll.Core.Identifier.Pattern
--------------------------------------------------------------------------------
data Dependency
- = PatternDependency Pattern [Identifier]
+ = PatternDependency Pattern (Set Identifier)
| IdentifierDependency Identifier
deriving (Show, Typeable)
@@ -91,7 +91,7 @@ dependenciesFor id' = do
return $ concatMap dependenciesFor' $ fromMaybe [] $ M.lookup id' facts
where
dependenciesFor' (IdentifierDependency i) = [i]
- dependenciesFor' (PatternDependency _ is) = is
+ dependenciesFor' (PatternDependency _ is) = S.toList is
--------------------------------------------------------------------------------
@@ -116,7 +116,7 @@ checkChangedPatterns = do
go _ ds (IdentifierDependency i) = return $ IdentifierDependency i : ds
go id' ds (PatternDependency p ls) = do
universe <- ask
- let ls' = filterMatches p universe
+ let ls' = S.fromList $ filterMatches p universe
if ls == ls'
then return $ PatternDependency p ls : ds
else do
diff --git a/src/Hakyll/Core/Metadata.hs b/src/Hakyll/Core/Metadata.hs
index a123c18..3ce854f 100644
--- a/src/Hakyll/Core/Metadata.hs
+++ b/src/Hakyll/Core/Metadata.hs
@@ -5,7 +5,6 @@ module Hakyll.Core.Metadata
, getMetadataField
, getMetadataField'
, makePatternDependency
- , metadataFiles
) where
@@ -13,7 +12,7 @@ module Hakyll.Core.Metadata
import Control.Monad (forM)
import Data.Map (Map)
import qualified Data.Map as M
-import System.FilePath.Posix ((</>), takeDirectory)
+import qualified Data.Set as S
--------------------------------------------------------------------------------
@@ -62,13 +61,4 @@ getMetadataField' identifier key = do
makePatternDependency :: MonadMetadata m => Pattern -> m Dependency
makePatternDependency pattern = do
matches' <- getMatches pattern
- return $ PatternDependency pattern matches'
-
---------------------------------------------------------------------------------
--- | Returns a list of all directory-wise metadata files, subdir first, global last
-metadataFiles :: Identifier -> [Identifier]
-metadataFiles identifier = local : go (takeDirectory $ toFilePath identifier) where
- go "." = [fromFilePath "metadata"]
- go dir = fromFilePath (dir </> "metadata") : go (takeDirectory dir)
- local = fromFilePath $ toFilePath identifier ++ ".metadata"
-
+ return $ PatternDependency pattern (S.fromList matches')
diff --git a/src/Hakyll/Core/Provider/Internal.hs b/src/Hakyll/Core/Provider/Internal.hs
index fdf1342..34400fd 100644
--- a/src/Hakyll/Core/Provider/Internal.hs
+++ b/src/Hakyll/Core/Provider/Internal.hs
@@ -31,8 +31,7 @@ import Data.Maybe (fromMaybe)
import Data.Monoid (mempty)
import Data.Set (Set)
import qualified Data.Set as S
-import Data.Time (Day (..), UTCTime (..),
- secondsToDiffTime)
+import Data.Time (Day (..), UTCTime (..))
import Data.Typeable (Typeable)
import System.Directory (getModificationTime)
import System.FilePath (addExtension, (</>))
@@ -62,11 +61,11 @@ newtype BinaryTime = BinaryTime {unBinaryTime :: UTCTime}
--------------------------------------------------------------------------------
instance Binary BinaryTime where
put (BinaryTime (UTCTime (ModifiedJulianDay d) dt)) =
- put d >> put (floor dt :: Integer)
+ put d >> put (toRational dt)
get = fmap BinaryTime $ UTCTime
<$> (ModifiedJulianDay <$> get)
- <*> (secondsToDiffTime <$> get)
+ <*> (fromRational <$> get)
--------------------------------------------------------------------------------
diff --git a/src/Hakyll/Core/Provider/Metadata.hs b/src/Hakyll/Core/Provider/Metadata.hs
index 889291f..7e4d7ed 100644
--- a/src/Hakyll/Core/Provider/Metadata.hs
+++ b/src/Hakyll/Core/Provider/Metadata.hs
@@ -20,8 +20,6 @@ import System.IO as IO
import Text.Parsec ((<?>))
import qualified Text.Parsec as P
import Text.Parsec.String (Parser)
-import System.FilePath.Posix
-import Control.Monad (liftM)
--------------------------------------------------------------------------------
@@ -30,7 +28,7 @@ import Hakyll.Core.Metadata
import Hakyll.Core.Provider.Internal
import Hakyll.Core.Util.Parser
import Hakyll.Core.Util.String
-import Hakyll.Core.Identifier.Pattern
+
--------------------------------------------------------------------------------
loadMetadata :: Provider -> Identifier -> IO (Metadata, Maybe String)
@@ -44,9 +42,7 @@ loadMetadata p identifier = do
Nothing -> return M.empty
Just mi' -> loadMetadataFile $ resourceFilePath p mi'
- gmd <- loadGlobalMetadata p identifier
-
- return (M.unions [md, gmd], body)
+ return (M.union md emd, body)
where
normal = setVersion Nothing identifier
fp = resourceFilePath p identifier
@@ -137,32 +133,3 @@ page = do
metadata' <- P.option [] metadataBlock
body <- P.many P.anyChar
return (metadata', body)
-
-
---------------------------------------------------------------------------------
--- | Load directory-wise metadata
-loadGlobalMetadata :: Provider -> Identifier -> IO Metadata
-loadGlobalMetadata p fp = liftM M.fromList $ loadgm fp where
- loadgm :: Identifier -> IO [(String, String)]
- loadgm = liftM concat . mapM loadOne . reverse . filter (resourceExists p) . metadataFiles
- loadOne mfp =
- let path = resourceFilePath p mfp
- dir = takeDirectory $ toFilePath mfp
- -- TODO: It might be better to print warning and continue
- in either (error.show) (findMetadata dir) . P.parse namedMetadata path <$> readFile path
- findMetadata dir =
- concatMap snd . filter (flip matches fp . fromGlob . normalise . combine dir . fst)
-
-namedMetadata :: Parser [(String, [(String, String)])]
-namedMetadata = liftA2 (:) (namedMetadataBlock False) $ P.many $ namedMetadataBlock True
-
-namedMetadataBlock :: Bool -> Parser (String, [(String, String)])
-namedMetadataBlock isNamed = do
- name <- if isNamed
- then P.many1 (P.char '-') *> P.many inlineSpace *> P.manyTill P.anyChar newline
- else pure "**"
- metadata' <- metadata
- P.skipMany P.space
- return (name, metadata')
-
-
diff --git a/src/Hakyll/Core/Rules/Default.hs b/src/Hakyll/Core/Rules/Default.hs
deleted file mode 100644
index fee78c5..0000000
--- a/src/Hakyll/Core/Rules/Default.hs
+++ /dev/null
@@ -1,24 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-module Hakyll.Core.Rules.Default
- ( internalRules
- , addMetadataDependencies
- )
-where
-import Hakyll.Core.Rules
-import Hakyll.Core.Compiler
-import Hakyll.Core.Compiler.Internal (compilerTellDependencies)
-import Hakyll.Core.Metadata (getMatches, metadataFiles)
-import Hakyll.Core.Identifier.Pattern(fromList)
-
-internalRules :: Rules ()
-internalRules = do
- match "metadata" $ compile $ makeItem ()
- match "**/metadata" $ compile $ makeItem ()
- match "**.metadata" $ compile $ makeItem ()
-
---------------------------------------------------------------------------------
-addMetadataDependencies :: Compiler ()
-addMetadataDependencies =
- compilerTellDependencies . map IdentifierDependency =<< getMatches . fromList =<< fmap metadataFiles getUnderlying
-
-
diff --git a/src/Hakyll/Core/Runtime.hs b/src/Hakyll/Core/Runtime.hs
index 12285ad..824d11b 100644
--- a/src/Hakyll/Core/Runtime.hs
+++ b/src/Hakyll/Core/Runtime.hs
@@ -35,7 +35,6 @@ import qualified Hakyll.Core.Logger as Logger
import Hakyll.Core.Provider
import Hakyll.Core.Routes
import Hakyll.Core.Rules.Internal
-import Hakyll.Core.Rules.Default
import Hakyll.Core.Store (Store)
import qualified Hakyll.Core.Store as Store
import Hakyll.Core.Util.File
@@ -54,7 +53,7 @@ run config verbosity rules = do
provider <- newProvider store (shouldIgnoreFile config) $
providerDirectory config
Logger.message logger "Running rules..."
- ruleSet <- runRules (rules >> internalRules) provider
+ ruleSet <- runRules rules provider
-- Get old facts
mOldFacts <- Store.get store factsKey
@@ -187,7 +186,7 @@ chase trail id'
config <- runtimeConfiguration <$> ask
Logger.debug logger $ "Processing " ++ show id'
- let compiler = addMetadataDependencies >> todo M.! id'
+ let compiler = todo M.! id'
read' = CompilerRead
{ compilerConfig = config
, compilerUnderlying = id'
diff --git a/src/Hakyll/Core/UnixFilter.hs b/src/Hakyll/Core/UnixFilter.hs
index 34b2ecb..edc8eac 100644
--- a/src/Hakyll/Core/UnixFilter.hs
+++ b/src/Hakyll/Core/UnixFilter.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
--------------------------------------------------------------------------------
-- | A Compiler that supports unix filters.
module Hakyll.Core.UnixFilter
@@ -20,7 +22,6 @@ import System.IO (Handle, hClose, hFlush, hGetContents,
hPutStr, hSetEncoding, localeEncoding)
import System.Process
-
--------------------------------------------------------------------------------
import Hakyll.Core.Compiler
@@ -105,8 +106,22 @@ unixFilterIO :: Monoid o
-> i
-> IO (o, String, ExitCode)
unixFilterIO writer reader programName args input = do
+ -- The problem on Windows is that `proc` is unable to execute
+ -- batch stubs (eg. anything created using 'gem install ...') even if its in
+ -- `$PATH`. A solution to this issue is to execute the batch file explicitly
+ -- using `cmd /c batchfile` but there is no rational way to know where said
+ -- batchfile is on the system. Hence, we detect windows using the
+ -- CPP and instead of using `proc` to create the process, use `shell`
+ -- which will be able to execute everything `proc` can
+ -- as well as batch files.
+#ifdef mingw32_HOST_OS
+ let pr = shell $ unwords (programName : args)
+#else
+ let pr = proc programName args
+#endif
+
(Just inh, Just outh, Just errh, pid) <-
- createProcess (proc programName args)
+ createProcess pr
{ std_in = CreatePipe
, std_out = CreatePipe
, std_err = CreatePipe
diff --git a/src/Hakyll/Init.hs b/src/Hakyll/Init.hs
index d50c6f6..51ba14b 100644
--- a/src/Hakyll/Init.hs
+++ b/src/Hakyll/Init.hs
@@ -5,11 +5,15 @@ module Main
--------------------------------------------------------------------------------
+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 @@ main = do
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 ++ " <directory>"
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/Main.hs b/src/Hakyll/Main.hs
index 86516cb..e0c8d4e 100644
--- a/src/Hakyll/Main.hs
+++ b/src/Hakyll/Main.hs
@@ -48,8 +48,8 @@ hakyllWith conf rules = do
Help _ -> showHelp
Preview _ p -> Commands.preview conf verbosity' rules p
Rebuild _ -> Commands.rebuild conf verbosity' rules >>= exitWith
- Server _ _ -> Commands.server conf (port args')
- Watch _ p s -> Commands.watch conf verbosity' p (not s) rules
+ Server _ _ _ -> Commands.server conf (host args') (port args')
+ Watch _ _ p s -> Commands.watch conf verbosity' (host args') p (not s) rules
--------------------------------------------------------------------------------
@@ -67,8 +67,8 @@ data HakyllArgs
| Help {verbose :: Bool}
| Preview {verbose :: Bool, port :: Int}
| Rebuild {verbose :: Bool}
- | Server {verbose :: Bool, port :: Int}
- | Watch {verbose :: Bool, port :: Int, no_server :: Bool }
+ | Server {verbose :: Bool, host :: String, port :: Int}
+ | Watch {verbose :: Bool, host :: String, port :: Int, no_server :: Bool }
deriving (Data, Typeable, Show)
@@ -84,13 +84,14 @@ hakyllArgs conf = modes
, (Preview (verboseFlag def) (portFlag defaultPort)) &=
help "[Deprecated] Please use the watch command"
, (Rebuild $ verboseFlag def) &= help "Clean and build again"
- , (Server (verboseFlag def) (portFlag defaultPort)) &=
+ , (Server (verboseFlag def) (hostFlag defaultHost) (portFlag defaultPort)) &=
help "Start a preview server"
- , (Watch (verboseFlag def) (portFlag defaultPort) (noServerFlag False) &=
+ , (Watch (verboseFlag def) (hostFlag defaultHost) (portFlag defaultPort) (noServerFlag False) &=
help "Autocompile on changes and start a preview server. You can watch and recompile without running a server with --no-server.")
] &= help "Hakyll static site compiler" &= program progName
- where defaultPort = Config.previewPort conf
-
+ where
+ defaultHost = Config.previewHost conf
+ defaultPort = Config.previewPort conf
--------------------------------------------------------------------------------
verboseFlag :: Data a => a -> a
@@ -104,6 +105,11 @@ noServerFlag x = x &= help "Disable the built-in web server"
{-# INLINE noServerFlag #-}
--------------------------------------------------------------------------------
+hostFlag :: Data a => a -> a
+hostFlag x = x &= help "Host to bind on"
+{-# INLINE hostFlag #-}
+
+--------------------------------------------------------------------------------
portFlag :: Data a => a -> a
portFlag x = x &= help "Port to listen on"
{-# INLINE portFlag #-}
diff --git a/src/Hakyll/Preview/Server.hs b/src/Hakyll/Preview/Server.hs
index 14cf377..ef1c3c5 100644
--- a/src/Hakyll/Preview/Server.hs
+++ b/src/Hakyll/Preview/Server.hs
@@ -8,6 +8,7 @@ module Hakyll.Preview.Server
--------------------------------------------------------------------------------
import Control.Monad.Trans (liftIO)
+import qualified Data.ByteString.Char8 as B
import qualified Snap.Core as Snap
import qualified Snap.Http.Server as Snap
import qualified Snap.Util.FileServe as Snap
@@ -31,13 +32,15 @@ static directory preServe =
-- | Main method, runs a static server in the given directory
staticServer :: FilePath -- ^ Directory to serve
-> (FilePath -> IO ()) -- ^ Pre-serve hook
+ -> String -- ^ Host to bind on
-> Int -- ^ Port to listen on
-> IO () -- ^ Blocks forever
-staticServer directory preServe port =
+staticServer directory preServe host port =
Snap.httpServe config $ static directory preServe
where
-- Snap server config
- config = Snap.setPort port
+ config = Snap.setBind (B.pack host)
+ $ Snap.setPort port
$ Snap.setAccessLog Snap.ConfigNoLog
$ Snap.setErrorLog Snap.ConfigNoLog
$ Snap.emptyConfig
diff --git a/src/Hakyll/Web/Html.hs b/src/Hakyll/Web/Html.hs
index ba62eb8..1abd742 100644
--- a/src/Hakyll/Web/Html.hs
+++ b/src/Hakyll/Web/Html.hs
@@ -125,6 +125,7 @@ toSiteRoot = emptyException . joinPath . map parent
emptyException x = x
relevant "." = False
relevant "/" = False
+ relevant "./" = False
relevant _ = True
diff --git a/src/Hakyll/Web/Paginate.hs b/src/Hakyll/Web/Paginate.hs
index eafd3a9..cd35a2d 100644
--- 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,10 +12,9 @@ module Hakyll.Web.Paginate
--------------------------------------------------------------------------------
import Control.Monad (forM_)
-import Data.List (unfoldr)
import qualified Data.Map as M
import Data.Monoid (mconcat)
-import Text.Printf (printf)
+import qualified Data.Set as S
--------------------------------------------------------------------------------
@@ -36,99 +35,93 @@ type PageNumber = Int
--------------------------------------------------------------------------------
-- | 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 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]]
-
- return $ Paginate (M.fromList paginatePages') (M.fromList pagPlaces') makeId
- (PatternDependency pattern idents)
+paginateEvery :: Int -> [a] -> [[a]]
+paginateEvery n = go
+ where
+ go [] = []
+ go xs = let (y, ys) = splitAt n xs in y : go ys
--------------------------------------------------------------------------------
-paginateRules :: Paginate -> (PageNumber -> Pattern -> Rules ()) -> Rules ()
-paginateRules paginator rules =
- forM_ (M.toList $ paginatePages paginator) $ \(idx, identifiers) ->
- create [paginateMakeId paginator idx] $
- rulesExtraDependencies [paginateDependency paginator] $
- rules idx $ fromList identifiers
+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
+ }
--------------------------------------------------------------------------------
--- | Takes first, current, last page and produces index of next page
-type RelPage = PageNumber -> PageNumber -> PageNumber -> Maybe PageNumber
+paginateRules :: Paginate -> (PageNumber -> Pattern -> Rules ()) -> Rules ()
+paginateRules paginator rules =
+ forM_ (M.toList $ paginateMap paginator) $ \(idx, identifiers) ->
+ rulesExtraDependencies [paginateDependency paginator] $
+ create [paginateMakeId paginator idx] $
+ rules idx $ fromList identifiers
--------------------------------------------------------------------------------
-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
- where
- nPages = M.size (paginatePages pag)
+-- | 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
--------------------------------------------------------------------------------
-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)
+-- | 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
+ 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)
+
+ 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.hs b/src/Hakyll/Web/Pandoc.hs
index 1615167..78df1df 100644
--- a/src/Hakyll/Web/Pandoc.hs
+++ b/src/Hakyll/Web/Pandoc.hs
@@ -53,6 +53,7 @@ readPandocWith ropt item = fmap (reader ropt (itemFileType item)) item
LaTeX -> readLaTeX ro
LiterateHaskell t' -> reader (addExt ro Ext_literate_haskell) t'
Markdown -> readMarkdown ro
+ OrgMode -> readOrg ro
Rst -> readRST ro
Textile -> readTextile ro
_ -> error $
diff --git a/src/Hakyll/Web/Tags.hs b/src/Hakyll/Web/Tags.hs
index 0fa182c..0887856 100644
--- a/src/Hakyll/Web/Tags.hs
+++ b/src/Hakyll/Web/Tags.hs
@@ -71,6 +71,7 @@ import qualified Data.Map as M
import Data.Maybe (catMaybes, fromMaybe)
import Data.Monoid (mconcat)
import Data.Ord (comparing)
+import qualified Data.Set as S
import System.FilePath (takeBaseName, takeDirectory)
import Text.Blaze.Html (toHtml, toValue, (!))
import Text.Blaze.Html.Renderer.String (renderHtml)
@@ -124,7 +125,8 @@ buildTagsWith :: MonadMetadata m
buildTagsWith f pattern makeId = do
ids <- getMatches pattern
tagMap <- foldM addTags M.empty ids
- return $ Tags (M.toList tagMap) makeId (PatternDependency pattern ids)
+ let set' = S.fromList ids
+ return $ Tags (M.toList tagMap) makeId (PatternDependency pattern set')
where
-- Create a tag map for one page
addTags tagMap id' = do
@@ -148,8 +150,8 @@ buildCategories = buildTagsWith getCategory
tagsRules :: Tags -> (String -> Pattern -> Rules ()) -> Rules ()
tagsRules tags rules =
forM_ (tagsMap tags) $ \(tag, identifiers) ->
- create [tagsMakeId tags tag] $
- rulesExtraDependencies [tagsDependency tags] $
+ rulesExtraDependencies [tagsDependency tags] $
+ create [tagsMakeId tags tag] $
rules tag $ fromList identifiers
diff --git a/src/Hakyll/Web/Template/List.hs b/src/Hakyll/Web/Template/List.hs
index f9ccc08..1f2a570 100644
--- a/src/Hakyll/Web/Template/List.hs
+++ b/src/Hakyll/Web/Template/List.hs
@@ -13,6 +13,8 @@ module Hakyll.Web.Template.List
, applyJoinTemplateList
, chronological
, recentFirst
+ , sortChronological
+ , sortRecentFirst
) where
@@ -25,6 +27,7 @@ import System.Locale (defaultTimeLocale)
--------------------------------------------------------------------------------
import Hakyll.Core.Compiler
+import Hakyll.Core.Identifier
import Hakyll.Core.Item
import Hakyll.Core.Metadata
import Hakyll.Web.Template
@@ -65,7 +68,24 @@ chronological =
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]
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-27 10:43:58 +0000