diff options
Diffstat (limited to 'src')
24 files changed, 0 insertions, 2297 deletions
diff --git a/src/Network/Hakyll/SimpleServer.hs b/src/Network/Hakyll/SimpleServer.hs deleted file mode 100644 index 4eef689..0000000 --- a/src/Network/Hakyll/SimpleServer.hs +++ /dev/null @@ -1,215 +0,0 @@ --- | Module containing a small, simple http file server for testing and preview --- purposes. -module Network.Hakyll.SimpleServer - ( simpleServer - ) where - -import Prelude hiding (log) -import Control.Monad (forever) -import Control.Monad.Reader (ReaderT, runReaderT, ask, liftIO) -import Network -import System.IO -import System.Directory (doesFileExist, doesDirectoryExist) -import Control.Concurrent (forkIO) -import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) -import System.FilePath (takeExtension) -import qualified Data.Map as M -import Data.List (intercalate) - -import Text.Hakyll.Util -import Text.Hakyll.Regex - --- | Function to log from a chan. -log :: Chan String -> IO () -log logChan = forever (readChan logChan >>= hPutStrLn stderr) - --- | General server configuration. -data ServerConfig = ServerConfig { documentRoot :: FilePath - , portNumber :: PortNumber - , logChannel :: Chan String - } - --- | Custom monad stack. -type Server = ReaderT ServerConfig IO - --- | Simple representation of a HTTP request. -data Request = Request { requestMethod :: String - , requestURI :: String - , requestVersion :: String - } deriving (Ord, Eq) - -instance Show Request where - show request = requestMethod request ++ " " - ++ requestURI request ++ " " - ++ requestVersion request - --- | Read a HTTP request from a 'Handle'. For now, this will ignore the request --- headers and body. -readRequest :: Handle -> Server Request -readRequest handle = do - requestLine <- liftIO $ hGetLine handle - let [method, uri, version] = map trim $ splitRegex " " requestLine - request = Request { requestMethod = method - , requestURI = uri - , requestVersion = version - } - return request - --- | Simple representation of the HTTP response we send back. -data Response = Response { responseVersion :: String - , responseStatusCode :: Int - , responsePhrase :: String - , responseHeaders :: M.Map String String - , responseBody :: String - } deriving (Ord, Eq) - -instance Show Response where - show response = responseVersion response ++ " " - ++ show (responseStatusCode response) ++ " " - ++ responsePhrase response - --- | A default response. -defaultResponse :: Response -defaultResponse = Response { responseVersion = "HTTP/1.1" - , responseStatusCode = 0 - , responsePhrase = "" - , responseHeaders = M.empty - , responseBody = "" - } - --- | Create a response for a given HTTP request. -createResponse :: Request -> Server Response -createResponse request - | requestMethod request == "GET" = createGetResponse request - | otherwise = return $ createErrorResponse 501 "Not Implemented" - --- | Create a simple error response. -createErrorResponse :: Int -- ^ Error code. - -> String -- ^ Error phrase. - -> Response -- ^ Result. -createErrorResponse statusCode phrase = defaultResponse - { responseStatusCode = statusCode - , responsePhrase = phrase - , responseHeaders = M.singleton "Content-Type" "text/html" - , responseBody = - "<html> <head> <title>" ++ show statusCode ++ "</title> </head>" - ++ "<body> <h1>" ++ show statusCode ++ "</h1>\n" - ++ "<p>" ++ phrase ++ "</p> </body> </html>" - } - --- | Create a simple get response. -createGetResponse :: Request -> Server Response -createGetResponse request = do - -- Construct the complete fileName of the requested resource. - config <- ask - let -- Drop everything after a '?'. - uri = takeWhile ((/=) '?') $ requestURI request - log' = writeChan (logChannel config) - isDirectory <- liftIO $ doesDirectoryExist $ documentRoot config ++ uri - let fileName = - documentRoot config ++ if isDirectory then uri ++ "/index.html" - else uri - - create200 = do - h <- openBinaryFile fileName ReadMode - contentLength <- hFileSize h - body <- hGetContents h - let mimeHeader = getMIMEHeader fileName - headers = ("Content-Length", show contentLength) : mimeHeader - return $ defaultResponse - { responseStatusCode = 200 - , responsePhrase = "OK" - , responseHeaders = responseHeaders defaultResponse - `M.union` M.fromList headers - , responseBody = body - } - - -- Called when an error occurs during the creation of a 200 response. - create500 e = do - log' $ "Internal Error: " ++ show e - return $ createErrorResponse 500 "Internal Server Error" - - -- Send back the page if found. - exists <- liftIO $ doesFileExist fileName - if exists - then liftIO $ catch create200 create500 - else do liftIO $ log' $ "Not Found: " ++ fileName - return $ createErrorResponse 404 "Not Found" - --- | Get the mime header for a certain filename. This is based on the extension --- of the given 'FilePath'. -getMIMEHeader :: FilePath -> [(String, String)] -getMIMEHeader fileName = - case result of (Just x) -> [("Content-Type", x)] - Nothing -> [] - where - result = lookup (takeExtension fileName) [ (".css", "text/css") - , (".gif", "image/gif") - , (".htm", "text/html") - , (".html", "text/html") - , (".jpeg", "image/jpeg") - , (".jpg", "image/jpeg") - , (".js", "text/javascript") - , (".png", "image/png") - , (".txt", "text/plain") - , (".xml", "text/xml") - ] - --- | Respond to an incoming request. -respond :: Handle -> Server () -respond handle = do - -- Read the request and create a response. - request <- readRequest handle - response <- createResponse request - - -- Generate some output. - config <- ask - liftIO $ writeChan (logChannel config) - $ show request ++ " => " ++ show response - - -- Send the response back to the handle. - liftIO $ putResponse response - where - putResponse response = do hPutStr handle $ intercalate " " - [ responseVersion response - , show $ responseStatusCode response - , responsePhrase response - ] - hPutStr handle "\r\n" - mapM_ putHeader - (M.toList $ responseHeaders response) - hPutStr handle "\r\n" - hPutStr handle $ responseBody response - hPutStr handle "\r\n" - hClose handle - - putHeader (key, value) = - hPutStr handle $ key ++ ": " ++ value ++ "\r\n" - --- | Start a simple http server on the given 'PortNumber', serving the given --- directory. --- -simpleServer :: PortNumber -- ^ Port to listen on. - -> FilePath -- ^ Root directory to serve. - -> IO () -- ^ Optional pre-respond action. - -> IO () -simpleServer port root preRespond = do - -- Channel to send logs to - logChan <- newChan - - let config = ServerConfig { documentRoot = root - , portNumber = port - , logChannel = logChan - } - - -- When a client connects, respond in a separate thread. - listen socket = do (handle, _, _) <- accept socket - preRespond - forkIO (runReaderT (respond handle) config) - - -- Handle logging in a separate thread - _ <- forkIO (log logChan) - - writeChan logChan $ "Starting hakyll server on port " ++ show port ++ "..." - socket <- listenOn (PortNumber port) - forever (listen socket) diff --git a/src/Text/Hakyll.hs b/src/Text/Hakyll.hs deleted file mode 100644 index b0fe479..0000000 --- a/src/Text/Hakyll.hs +++ /dev/null @@ -1,185 +0,0 @@ --- | This is the main Hakyll module, exporting the important @hakyll@ function. --- --- Most configurations would use this @hakyll@ function more or less as the --- main function: --- --- > main = hakyll $ do --- > directory css "css" --- > directory static "images" --- -module Text.Hakyll - ( defaultHakyllConfiguration - , hakyll - , hakyllWithConfiguration - , runDefaultHakyll - - , module Text.Hakyll.Context - , module Text.Hakyll.ContextManipulations - , module Text.Hakyll.CreateContext - , module Text.Hakyll.File - , module Text.Hakyll.HakyllMonad - , module Text.Hakyll.Regex - , module Text.Hakyll.Render - , module Text.Hakyll.HakyllAction - , module Text.Hakyll.Paginate - , module Text.Hakyll.Page - , module Text.Hakyll.Pandoc - , module Text.Hakyll.Util - , module Text.Hakyll.Tags - , module Text.Hakyll.Feed - , module Text.Hakyll.Configurations.Static - ) where - -import Control.Concurrent (forkIO, threadDelay) -import Control.Monad.Reader (runReaderT, liftIO, ask) -import Control.Monad (when) -import Data.Monoid (mempty) -import System.Environment (getArgs, getProgName) -import System.Directory (doesDirectoryExist, removeDirectoryRecursive) -import System.Time (getClockTime) - -import Text.Pandoc -import Text.Hamlet (defaultHamletSettings) - -import Network.Hakyll.SimpleServer (simpleServer) -import Text.Hakyll.Context -import Text.Hakyll.ContextManipulations -import Text.Hakyll.CreateContext -import Text.Hakyll.File -import Text.Hakyll.HakyllMonad -import Text.Hakyll.Regex -import Text.Hakyll.Render -import Text.Hakyll.HakyllAction -import Text.Hakyll.Paginate -import Text.Hakyll.Page -import Text.Hakyll.Pandoc -import Text.Hakyll.Util -import Text.Hakyll.Tags -import Text.Hakyll.Feed -import Text.Hakyll.Configurations.Static - --- | The default reader options for pandoc parsing. --- -defaultPandocParserState :: ParserState -defaultPandocParserState = defaultParserState - { -- The following option causes pandoc to read smart typography, a nice - -- and free bonus. - stateSmart = True - } - --- | The default writer options for pandoc rendering. --- -defaultPandocWriterOptions :: WriterOptions -defaultPandocWriterOptions = defaultWriterOptions - { -- This option causes literate haskell to be written using '>' marks in - -- html, which I think is a good default. - writerLiterateHaskell = True - } - --- | The default hakyll configuration. --- -defaultHakyllConfiguration :: String -- ^ Absolute site URL. - -> HakyllConfiguration -- ^ Default config. -defaultHakyllConfiguration absoluteUrl' = HakyllConfiguration - { absoluteUrl = absoluteUrl' - , additionalContext = mempty - , siteDirectory = "_site" - , cacheDirectory = "_cache" - , enableIndexUrl = False - , previewMode = BuildOnRequest - , pandocParserState = defaultPandocParserState - , pandocWriterOptions = defaultPandocWriterOptions - , hamletSettings = defaultHamletSettings - } - --- | Main function to run Hakyll with the default configuration. The --- absolute URL is only used in certain cases, for example RSS feeds et --- cetera. --- -hakyll :: String -- ^ Absolute URL of your site. Used in certain cases. - -> Hakyll () -- ^ You code. - -> IO () -hakyll absolute = hakyllWithConfiguration configuration - where - configuration = defaultHakyllConfiguration absolute - --- | Main function to run hakyll with a custom configuration. --- -hakyllWithConfiguration :: HakyllConfiguration -> Hakyll () -> IO () -hakyllWithConfiguration configuration buildFunction = do - args <- getArgs - let f = case args of ["build"] -> buildFunction - ["clean"] -> clean - ["preview", p] -> preview (read p) - ["preview"] -> preview defaultPort - ["rebuild"] -> clean >> buildFunction - ["server", p] -> server (read p) (return ()) - ["server"] -> server defaultPort (return ()) - _ -> help - runReaderT f configuration - where - preview port = case previewMode configuration of - BuildOnRequest -> server port buildFunction - BuildOnInterval -> do - let pIO = runReaderT (previewThread buildFunction) configuration - _ <- liftIO $ forkIO pIO - server port (return ()) - - defaultPort = 8000 - --- | A preview thread that periodically recompiles the site. --- -previewThread :: Hakyll () -- ^ Build function - -> Hakyll () -- ^ Result -previewThread buildFunction = run =<< liftIO getClockTime - where - delay = 1000000 - run time = do liftIO $ threadDelay delay - contents <- getRecursiveContents "." - valid <- isMoreRecent time contents - when valid buildFunction - run =<< liftIO getClockTime - --- | Clean up directories. --- -clean :: Hakyll () -clean = do askHakyll siteDirectory >>= remove' - askHakyll cacheDirectory >>= remove' - where - remove' dir = liftIO $ do putStrLn $ "Removing " ++ dir ++ "..." - exists <- doesDirectoryExist dir - when exists $ removeDirectoryRecursive dir - --- | Show usage information. --- -help :: Hakyll () -help = liftIO $ do - name <- getProgName - putStrLn $ "This is a Hakyll site generator program. You should always\n" - ++ "run it from the project root directory.\n" - ++ "\n" - ++ "Usage:\n" - ++ name ++ " build Generate the site.\n" - ++ name ++ " clean Clean up and remove cache.\n" - ++ name ++ " help Show this message.\n" - ++ name ++ " preview [port] Run a server and autocompile.\n" - ++ name ++ " rebuild Clean up and build again.\n" - ++ name ++ " server [port] Run a local test server.\n" - --- | Start a server at the given port number. --- -server :: Integer -- ^ Port number to serve on. - -> Hakyll () -- ^ Pre-respond action. - -> Hakyll () -server port preRespond = do - configuration <- ask - root <- askHakyll siteDirectory - let preRespondIO = runReaderT preRespond configuration - liftIO $ simpleServer (fromIntegral port) root preRespondIO - --- | Run a Hakyll action with default settings. This is mostly aimed at testing --- code. --- -runDefaultHakyll :: Hakyll a -> IO a -runDefaultHakyll f = - runReaderT f $ defaultHakyllConfiguration "http://example.com" diff --git a/src/Text/Hakyll/Configurations/Static.hs b/src/Text/Hakyll/Configurations/Static.hs deleted file mode 100644 index 5a2c1be..0000000 --- a/src/Text/Hakyll/Configurations/Static.hs +++ /dev/null @@ -1,59 +0,0 @@ --- | Module for a simple static configuration of a website. --- --- The configuration works like this: --- --- * The @templates/@ directory should contain one template. --- --- * Renderable files in the directory tree are rendered using this template. --- --- * The @static/@ directory is copied entirely (if it exists). --- --- * All files in the @css/@ directory are compressed. --- -module Text.Hakyll.Configurations.Static - ( staticConfiguration - ) where - -import Control.Applicative ((<$>)) -import Control.Monad (filterM, forM_) - -import Text.Hakyll.File ( getRecursiveContents, inDirectory, inHakyllDirectory - , directory ) -import Text.Hakyll.Internal.FileType (isRenderableFile) -import Text.Hakyll.HakyllMonad (Hakyll, logHakyll) -import Text.Hakyll.Render (renderChain, css, static) -import Text.Hakyll.CreateContext (createPage) - --- | A simple configuration for an entirely static website. --- -staticConfiguration :: Hakyll () -staticConfiguration = do - -- Find all files not in _site or _cache. - files <- filterM isRenderableFile' =<< getRecursiveContents "." - - -- Find a main template to use - mainTemplate <- take 1 <$> getRecursiveContents templateDir - logHakyll $ case mainTemplate of [] -> "Using no template" - (x : _) -> "Using template " ++ x - - -- Render all files using this template - forM_ files $ renderChain mainTemplate . createPage - - -- Render a static directory - directory static staticDir - - -- Render a css directory - directory css cssDir - where - -- A file should have a renderable extension and not be in a hakyll - -- directory, and not in a special directory. - isRenderableFile' file = do - inHakyllDirectory' <- inHakyllDirectory file - return $ isRenderableFile file - && not (any (inDirectory file) [templateDir, cssDir, staticDir]) - && not inHakyllDirectory' - - -- Directories - templateDir = "templates" - cssDir = "css" - staticDir = "static" diff --git a/src/Text/Hakyll/Context.hs b/src/Text/Hakyll/Context.hs deleted file mode 100644 index 9045a65..0000000 --- a/src/Text/Hakyll/Context.hs +++ /dev/null @@ -1,16 +0,0 @@ --- | This (quite small) module exports the datatype used for contexts. A --- @Context@ is a simple key-value mapping. You can render these @Context@s --- with templates, and manipulate them in various ways. -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Text.Hakyll.Context - ( Context (..) - ) where - -import Data.Monoid (Monoid) -import Data.Map (Map) -import Data.Binary (Binary) - --- | Datatype used for key-value mappings. -newtype Context = Context { -- | Extract the context. - unContext :: Map String String - } deriving (Show, Monoid, Binary) diff --git a/src/Text/Hakyll/CreateContext.hs b/src/Text/Hakyll/CreateContext.hs deleted file mode 100644 index 6a0e321..0000000 --- a/src/Text/Hakyll/CreateContext.hs +++ /dev/null @@ -1,114 +0,0 @@ --- | A module that provides different ways to create a @Context@. These --- functions all use the @HakyllAction@ arrow, so they produce values of the --- type @HakyllAction () Context@. -module Text.Hakyll.CreateContext - ( createPage - , createCustomPage - , createListing - , addField - , combine - , combineWithUrl - ) where - -import Prelude hiding (id) - -import qualified Data.Map as M -import Control.Arrow (second, arr, (&&&), (***)) -import Control.Monad (liftM2) -import Control.Applicative ((<$>)) -import Control.Arrow ((>>>)) -import Control.Category (id) - -import Text.Hakyll.Context -import Text.Hakyll.HakyllAction -import Text.Hakyll.Render -import Text.Hakyll.Page -import Text.Hakyll.Pandoc -import Text.Hakyll.Internal.Cache - --- | Create a @Context@ from a page file stored on the disk. This is probably --- the most common way to create a @Context@. -createPage :: FilePath -> HakyllAction () Context -createPage path = cacheAction "pages" $ readPageAction path >>> renderAction - --- | Create a custom page @Context@. --- --- The association list given maps keys to values for substitution. Note --- that as value, you can either give a @String@ or a --- @HakyllAction () String@. The latter is preferred for more complex data, --- since it allows dependency checking. A @String@ is obviously more simple --- to use in some cases. --- -createCustomPage :: FilePath - -> [(String, Either String (HakyllAction () String))] - -> HakyllAction () Context -createCustomPage url association = HakyllAction - { actionDependencies = dataDependencies - , actionUrl = Left $ return url - , actionFunction = \_ -> Context . M.fromList <$> assoc' - } - where - mtuple (a, b) = b >>= \b' -> return (a, b') - toHakyllString = second (either return runHakyllAction) - assoc' = mapM (mtuple . toHakyllString) $ ("url", Left url) : association - dataDependencies = map snd association >>= getDependencies - getDependencies (Left _) = [] - getDependencies (Right x) = actionDependencies x - --- | A @createCustomPage@ function specialized in creating listings. --- --- This function creates a listing of a certain list of @Context@s. Every --- item in the list is created by applying the given template to every --- renderable. You can also specify additional context to be included in the --- @CustomPage@. -createListing :: FilePath -- ^ Destination of the page. - -> [FilePath] -- ^ Templates to render items with. - -> [HakyllAction () Context] -- ^ Renderables in the list. - -> [(String, Either String (HakyllAction () String))] - -> HakyllAction () Context -createListing url templates renderables additional = - createCustomPage url context - where - context = ("body", Right concatenation) : additional - concatenation = renderAndConcat templates renderables - --- | Add a field to a 'Context'. --- -addField :: String -- ^ Key - -> Either String (HakyllAction () String) -- ^ Value - -> HakyllAction Context Context -- ^ Result -addField key value = arr (const ()) &&& id - >>> value' *** id - >>> arr (uncurry insert) - where - value' = arr (const ()) >>> either (arr . const) id value - insert v = Context . M.insert key v . unContext - --- | Combine two @Context@s. The url will always be taken from the first --- @Renderable@. Also, if a `$key` is present in both renderables, the --- value from the first @Context@ will be taken as well. --- --- You can see this as a this as a @union@ between two mappings. -combine :: HakyllAction () Context -> HakyllAction () Context - -> HakyllAction () Context -combine x y = HakyllAction - { actionDependencies = actionDependencies x ++ actionDependencies y - , actionUrl = actionUrl x - , actionFunction = \_ -> - Context <$> liftM2 (M.union) (unContext <$> runHakyllAction x) - (unContext <$> runHakyllAction y) - } - --- | Combine two @Context@s and set a custom URL. This behaves like @combine@, --- except that for the @url@ field, the given URL is always chosen. -combineWithUrl :: FilePath - -> HakyllAction () Context - -> HakyllAction () Context - -> HakyllAction () Context -combineWithUrl url x y = combine' - { actionUrl = Left $ return url - , actionFunction = \_ -> - Context . M.insert "url" url . unContext <$> runHakyllAction combine' - } - where - combine' = combine x y diff --git a/src/Text/Hakyll/Feed.hs b/src/Text/Hakyll/Feed.hs deleted file mode 100644 index be8d023..0000000 --- a/src/Text/Hakyll/Feed.hs +++ /dev/null @@ -1,112 +0,0 @@ --- | A Module that allows easy rendering of RSS feeds. If you use this module, --- you must make sure you set the `absoluteUrl` field in the main Hakyll --- configuration. --- --- Apart from that, the main rendering functions (@renderRss@, @renderAtom@) --- all assume that you pass the list of items so that the most recent entry --- in the feed is the first item in the list. --- --- Also note that the @Context@s should have (at least) the following --- fields to produce a correct feed: --- --- - @$title@: Title of the item. --- --- - @$description@: Description to appear in the feed. --- --- - @$url@: URL to the item - this is usually set automatically. --- --- Furthermore, the feed will be generated, but will be incorrect (it won't --- validate) if an empty list is passed. --- -module Text.Hakyll.Feed - ( FeedConfiguration (..) - , renderRss - , renderAtom - ) where - -import Control.Arrow ((>>>), second) -import Control.Monad.Reader (liftIO) -import Data.Maybe (fromMaybe) -import qualified Data.Map as M - -import Text.Hakyll.Context (Context (..)) -import Text.Hakyll.CreateContext (createListing) -import Text.Hakyll.ContextManipulations (renderDate) -import Text.Hakyll.HakyllMonad (Hakyll) -import Text.Hakyll.Render (render, renderChain) -import Text.Hakyll.HakyllAction - -import Paths_hakyll - --- | This is a data structure to keep the configuration of a feed. -data FeedConfiguration = FeedConfiguration - { -- | Url of the feed (relative to site root). For example, @rss.xml@. - feedUrl :: String - , -- | Title of the feed. - feedTitle :: String - , -- | Description of the feed. - feedDescription :: String - , -- | Name of the feed author. - feedAuthorName :: String - } - --- | This is an auxiliary function to create a listing that is, in fact, a feed. --- The items should be sorted on date. -createFeed :: FeedConfiguration -- ^ Feed configuration. - -> [HakyllAction () Context] -- ^ Items to include. - -> FilePath -- ^ Feed template. - -> FilePath -- ^ Item template. - -> HakyllAction () Context -createFeed configuration renderables template itemTemplate = - listing >>> render template - where - listing = createListing (feedUrl configuration) - [itemTemplate] renderables additional - - additional = map (second $ Left . ($ configuration)) - [ ("title", feedTitle) - , ("description", feedDescription) - , ("authorName", feedAuthorName) - ] ++ updated - - -- Take the first timestamp, which should be the most recent. - updated = let action = createHakyllAction $ return . fromMaybe "foo" - . M.lookup "timestamp" . unContext - toTuple r = ("timestamp", Right $ r >>> action) - in map toTuple $ take 1 renderables - - --- | Abstract function to render any feed. -renderFeed :: FeedConfiguration -- ^ Feed configuration. - -> [HakyllAction () Context] -- ^ Items to include in the feed. - -> FilePath -- ^ Feed template. - -> FilePath -- ^ Item template. - -> Hakyll () -renderFeed configuration renderables template itemTemplate = do - template' <- liftIO $ getDataFileName template - itemTemplate' <- liftIO $ getDataFileName itemTemplate - let renderFeed' = createFeed configuration renderables - template' itemTemplate' - renderChain [] renderFeed' - --- | Render an RSS feed with a number of items. -renderRss :: FeedConfiguration -- ^ Feed configuration. - -> [HakyllAction () Context] -- ^ Items to include in the feed. - -> Hakyll () -renderRss configuration renderables = - renderFeed configuration (map (>>> renderRssDate) renderables) - "templates/rss.xml" "templates/rss-item.xml" - where - renderRssDate = renderDate "timestamp" "%a, %d %b %Y %H:%M:%S UT" - "No date found." - --- | Render an Atom feed with a number of items. -renderAtom :: FeedConfiguration -- ^ Feed configuration. - -> [HakyllAction () Context] -- ^ Items to include in the feed. - -> Hakyll () -renderAtom configuration renderables = - renderFeed configuration (map (>>> renderAtomDate) renderables) - "templates/atom.xml" "templates/atom-item.xml" - where - renderAtomDate = renderDate "timestamp" "%Y-%m-%dT%H:%M:%SZ" - "No date found." diff --git a/src/Text/Hakyll/File.hs b/src/Text/Hakyll/File.hs deleted file mode 100644 index 747608c..0000000 --- a/src/Text/Hakyll/File.hs +++ /dev/null @@ -1,196 +0,0 @@ --- | A module containing various function for manipulating and examinating --- files and directories. -module Text.Hakyll.File - ( toDestination - , toCache - , toUrl - , toRoot - , inDirectory - , inHakyllDirectory - , removeSpaces - , makeDirectories - , getRecursiveContents - , sortByBaseName - , havingExtension - , directory - , isMoreRecent - , isFileMoreRecent - ) where - -import System.Directory -import Control.Applicative ((<$>)) -import System.FilePath -import System.Time (ClockTime) -import Control.Monad -import Data.List (isPrefixOf, sortBy) -import Data.Ord (comparing) -import Control.Monad.Reader (liftIO) - -import Text.Hakyll.Monad -import Text.Hakyll.Internal.FileType (isRenderableFile) - --- | Auxiliary function to remove pathSeparators form the start. We don't deal --- with absolute paths here. We also remove $root from the start. -removeLeadingSeparator :: FilePath -> FilePath -removeLeadingSeparator [] = [] -removeLeadingSeparator path - | head path' `elem` pathSeparators = drop 1 path' - | otherwise = path' - where - path' = if "$root" `isPrefixOf` path then drop 5 path - else path - --- | Convert a relative URL to a filepath in the destination --- (default: @_site@). -toDestination :: FilePath -> Hakyll FilePath -toDestination url = do dir <- askHakyll siteDirectory - toFilePath dir url - --- | Convert a relative URL to a filepath in the cache --- (default: @_cache@). -toCache :: FilePath -> Hakyll FilePath -toCache path = do dir <- askHakyll cacheDirectory - toFilePath dir path - --- | Implementation of toDestination/toCache --- -toFilePath :: String -- ^ Directory (site or cache) - -> String -- ^ URL - -> Hakyll FilePath -- ^ Resulting file path -toFilePath dir url = do - enableIndexUrl' <- askHakyll enableIndexUrl - let destination = if enableIndexUrl' && separatorEnd - then dir </> noSeparator </> "index.html" - else dir </> noSeparator - return destination - where - noSeparator = removeLeadingSeparator url - separatorEnd = not (null url) && last url == '/' - --- | Get the url for a given page. For most extensions, this would be the path --- itself. It's only for rendered extensions (@.markdown@, @.rst@, @.lhs@ this --- function returns a path with a @.html@ extension instead. -toUrl :: FilePath -> Hakyll FilePath -toUrl path = do enableIndexUrl' <- askHakyll enableIndexUrl - -- If the file does not have a renderable extension, like for - -- example favicon.ico, we don't have to change it at all. - return $ if not (isRenderableFile path) - then path - -- If index url's are enabled, we create pick it - -- unless the page is an index already. - else if enableIndexUrl' && not isIndex - then indexUrl - else withSimpleHtmlExtension - where - isIndex = dropExtension (takeFileName path) == "index" - withSimpleHtmlExtension = flip addExtension ".html" $ dropExtension path - indexUrl = dropExtension path ++ "/" - - --- | Get the relative url to the site root, for a given (absolute) url -toRoot :: FilePath -> FilePath -toRoot = emptyException . joinPath . map parent . splitPath - . takeDirectory . removeLeadingSeparator - where - parent = const ".." - emptyException [] = "." - emptyException x = x - --- | Check if a file is in a given directory. --- -inDirectory :: FilePath -- ^ File path - -> FilePath -- ^ Directory - -> Bool -- ^ Result -inDirectory path dir = case splitDirectories path of - [] -> False - (x : _) -> x == dir - --- | Check if a file is in a Hakyll directory. With a Hakyll directory, we mean --- a directory that should be "ignored" such as the @_site@ or @_cache@ --- directory. --- --- Example: --- --- > inHakyllDirectory "_cache/pages/index.html" --- --- Result: --- --- > True --- -inHakyllDirectory :: FilePath -> Hakyll Bool -inHakyllDirectory path = - or <$> mapM (liftM (inDirectory path) . askHakyll) - [siteDirectory, cacheDirectory] - --- | Swaps spaces for '-'. -removeSpaces :: FilePath -> FilePath -removeSpaces = map swap - where - swap ' ' = '-' - swap x = x - --- | Given a path to a file, try to make the path writable by making --- all directories on the path. -makeDirectories :: FilePath -> Hakyll () -makeDirectories path = liftIO $ createDirectoryIfMissing True dir - where - dir = takeDirectory path - --- | Get all contents of a directory. Note that files starting with a dot (.) --- will be ignored. --- -getRecursiveContents :: FilePath -> Hakyll [FilePath] -getRecursiveContents topdir = do - topdirExists <- liftIO $ doesDirectoryExist topdir - if topdirExists - then do names <- liftIO $ getDirectoryContents topdir - let properNames = filter isProper names - paths <- forM properNames $ \name -> do - let path = topdir </> name - isDirectory <- liftIO $ doesDirectoryExist path - if isDirectory - then getRecursiveContents path - else return [normalise path] - return (concat paths) - else return [] - where - isProper = not . (== '.') . head - --- | Sort a list of filenames on the basename. -sortByBaseName :: [FilePath] -> [FilePath] -sortByBaseName = sortBy compareBaseName - where - compareBaseName = comparing takeFileName - --- | A filter that takes all file names with a given extension. Prefix the --- extension with a dot: --- --- > havingExtension ".markdown" [ "index.markdown" --- > , "style.css" --- > ] == ["index.markdown"] -havingExtension :: String -> [FilePath] -> [FilePath] -havingExtension extension = filter ((==) extension . takeExtension) - --- | Perform a Hakyll action on every file in a given directory. -directory :: (FilePath -> Hakyll ()) -> FilePath -> Hakyll () -directory action dir = getRecursiveContents dir >>= mapM_ action - --- | Check if a timestamp is newer then a number of given files. -isMoreRecent :: ClockTime -- ^ The time to check. - -> [FilePath] -- ^ Dependencies of the cached file. - -> Hakyll Bool -isMoreRecent _ [] = return True -isMoreRecent timeStamp depends = do - dependsModified <- liftIO $ mapM getModificationTime depends - return (timeStamp >= maximum dependsModified) - --- | Check if a file is newer then a number of given files. -isFileMoreRecent :: FilePath -- ^ The cached file. - -> [FilePath] -- ^ Dependencies of the cached file. - -> Hakyll Bool -isFileMoreRecent file depends = do - exists <- liftIO $ doesFileExist file - if not exists - then return False - else do timeStamp <- liftIO $ getModificationTime file - isMoreRecent timeStamp depends diff --git a/src/Text/Hakyll/Internal/Cache.hs b/src/Text/Hakyll/Internal/Cache.hs deleted file mode 100644 index b83d9af..0000000 --- a/src/Text/Hakyll/Internal/Cache.hs +++ /dev/null @@ -1,53 +0,0 @@ -module Text.Hakyll.Internal.Cache - ( storeInCache - , getFromCache - , isCacheMoreRecent - , cacheAction - ) where - -import Control.Monad ((<=<)) -import Control.Monad.Reader (liftIO) -import Data.Binary -import System.FilePath ((</>)) - -import Text.Hakyll.File -import Text.Hakyll.HakyllMonad (Hakyll) -import Text.Hakyll.HakyllAction - --- | We can store all datatypes instantiating @Binary@ to the cache. The cache --- directory is specified by the @HakyllConfiguration@, usually @_cache@. -storeInCache :: (Binary a) => a -> FilePath -> Hakyll () -storeInCache value path = do - cachePath <- toCache path - makeDirectories cachePath - liftIO $ encodeFile cachePath value - --- | Get a value from the cache. The filepath given should not be located in the --- cache. This function performs a timestamp check on the filepath and the --- filepath in the cache, and only returns the cached value when it is still --- up-to-date. -getFromCache :: (Binary a) => FilePath -> Hakyll a -getFromCache = liftIO . decodeFile <=< toCache - --- | Check if a file in the cache is more recent than a number of other files. -isCacheMoreRecent :: FilePath -> [FilePath] -> Hakyll Bool -isCacheMoreRecent file depends = toCache file >>= flip isFileMoreRecent depends - --- | Cache an entire arrow --- -cacheAction :: Binary a - => String - -> HakyllAction () a - -> HakyllAction () a -cacheAction key action = action { actionFunction = const cacheFunction } - where - cacheFunction = do - -- Construct a filename - fileName <- fmap (key </>) $ either id (const $ return "unknown") - $ actionUrl action - -- Check the cache - cacheOk <- isCacheMoreRecent fileName $ actionDependencies action - if cacheOk then getFromCache fileName - else do result <- actionFunction action () - storeInCache result fileName - return result diff --git a/src/Text/Hakyll/Internal/CompressCss.hs b/src/Text/Hakyll/Internal/CompressCss.hs deleted file mode 100644 index 4a78791..0000000 --- a/src/Text/Hakyll/Internal/CompressCss.hs +++ /dev/null @@ -1,36 +0,0 @@ --- | Module used for CSS compression. The compression is currently in a simple --- state, but would typically reduce the number of bytes by about 25%. -module Text.Hakyll.Internal.CompressCss - ( compressCss - ) where - -import Data.List (isPrefixOf) - -import Text.Hakyll.Regex (substituteRegex) - --- | Compress CSS to speed up your site. -compressCss :: String -> String -compressCss = compressSeparators - . stripComments - . compressWhitespace - --- | Compresses certain forms of separators. -compressSeparators :: String -> String -compressSeparators = substituteRegex "; *}" "}" - . substituteRegex " *([{};:]) *" "\\1" - . substituteRegex ";;*" ";" - --- | Compresses all whitespace. -compressWhitespace :: String -> String -compressWhitespace = substituteRegex "[ \t\n][ \t\n]*" " " - --- | Function that strips CSS comments away. -stripComments :: String -> String -stripComments [] = [] -stripComments str - | isPrefixOf "/*" str = stripComments $ eatComments $ drop 2 str - | otherwise = head str : stripComments (drop 1 str) - where - eatComments str' | null str' = [] - | isPrefixOf "*/" str' = drop 2 str' - | otherwise = eatComments $ drop 1 str' diff --git a/src/Text/Hakyll/Internal/FileType.hs b/src/Text/Hakyll/Internal/FileType.hs deleted file mode 100644 index 689c77f..0000000 --- a/src/Text/Hakyll/Internal/FileType.hs +++ /dev/null @@ -1,49 +0,0 @@ --- | A module dealing with file extensions and associated file types. -module Text.Hakyll.Internal.FileType - ( FileType (..) - , getFileType - , isRenderable - , isRenderableFile - ) where - -import System.FilePath (takeExtension) - --- | Datatype to represent the different file types Hakyll can deal with. -data FileType = Html - | LaTeX - | LiterateHaskellMarkdown - | Markdown - | ReStructuredText - | Text - | UnknownFileType - deriving (Eq, Ord, Show, Read) - --- | Get the file type for a certain file. The type is determined by extension. -getFileType :: FilePath -> FileType -getFileType = getFileType' . takeExtension - where - getFileType' ".htm" = Html - getFileType' ".html" = Html - getFileType' ".lhs" = LiterateHaskellMarkdown - getFileType' ".markdown" = Markdown - getFileType' ".md" = Markdown - getFileType' ".mdn" = Markdown - getFileType' ".mdown" = Markdown - getFileType' ".mdwn" = Markdown - getFileType' ".mkd" = Markdown - getFileType' ".mkdwn" = Markdown - getFileType' ".page" = Markdown - getFileType' ".rst" = ReStructuredText - getFileType' ".tex" = LaTeX - getFileType' ".text" = Text - getFileType' ".txt" = Text - getFileType' _ = UnknownFileType - --- | Check if a certain @FileType@ is renderable. -isRenderable :: FileType -> Bool -isRenderable UnknownFileType = False -isRenderable _ = True - --- | Check if a certain file is renderable. -isRenderableFile :: FilePath -> Bool -isRenderableFile = isRenderable . getFileType diff --git a/src/Text/Hakyll/Internal/Template.hs b/src/Text/Hakyll/Internal/Template.hs deleted file mode 100644 index cd6a3bd..0000000 --- a/src/Text/Hakyll/Internal/Template.hs +++ /dev/null @@ -1,86 +0,0 @@ -module Text.Hakyll.Internal.Template - ( Template (..) - , fromString - , readTemplate - , substitute - , regularSubstitute - , finalSubstitute - ) where - -import Control.Arrow ((>>>)) -import Control.Applicative ((<$>)) -import Data.List (isPrefixOf) -import Data.Char (isAlphaNum) -import Data.Maybe (fromMaybe) -import System.FilePath ((</>)) -import qualified Data.Map as M - -import Text.Hakyll.Context (Context (..)) -import Text.Hakyll.HakyllMonad (Hakyll) -import Text.Hakyll.HakyllAction -import Text.Hakyll.Pandoc -import Text.Hakyll.Internal.Cache -import Text.Hakyll.Page -import Text.Hakyll.ContextManipulations -import Text.Hakyll.Internal.Template.Template -import Text.Hakyll.Internal.Template.Hamlet - --- | Construct a @Template@ from a string. --- -fromString :: String -> Template -fromString = Template . fromString' - where - fromString' [] = [] - fromString' string - | "$$" `isPrefixOf` string = - EscapeCharacter : (fromString' $ drop 2 string) - | "$" `isPrefixOf` string = - let (key, rest) = span isAlphaNum $ drop 1 string - in Identifier key : fromString' rest - | otherwise = - let (chunk, rest) = break (== '$') string - in Chunk chunk : fromString' rest - --- | Read a @Template@ from a file. This function might fetch the @Template@ --- from the cache, if available. -readTemplate :: FilePath -> Hakyll Template -readTemplate path = do - isCacheMoreRecent' <- isCacheMoreRecent fileName [path] - if isCacheMoreRecent' - then getFromCache fileName - else do - template <- if isHamletRTFile path - then readHamletTemplate - else readDefaultTemplate - storeInCache template fileName - return template - where - fileName = "templates" </> path - readDefaultTemplate = do - body <- runHakyllAction $ readPageAction path - >>> renderAction - >>> takeBody - return $ fromString body - - readHamletTemplate = fromHamletRT <$> readHamletRT path - --- | Substitutes @$identifiers@ in the given @Template@ by values from the given --- "Context". When a key is not found, it is left as it is. You can specify --- the characters used to replace escaped dollars (@$$@) here. -substitute :: String -> Template -> Context -> String -substitute escaper template context = substitute' =<< unTemplate template - where - substitute' (Chunk chunk) = chunk - substitute' (Identifier key) = - fromMaybe ('$' : key) $ M.lookup key $ unContext context - substitute' (EscapeCharacter) = escaper - --- | @substitute@ for use during a chain. This will leave escaped characters as --- they are. -regularSubstitute :: Template -> Context -> String -regularSubstitute = substitute "$$" - --- | @substitute@ for the end of a chain (just before writing). This renders --- escaped characters. -finalSubstitute :: Template -> Context -> String -finalSubstitute = substitute "$" diff --git a/src/Text/Hakyll/Internal/Template/Hamlet.hs b/src/Text/Hakyll/Internal/Template/Hamlet.hs deleted file mode 100644 index 458ab35..0000000 --- a/src/Text/Hakyll/Internal/Template/Hamlet.hs +++ /dev/null @@ -1,56 +0,0 @@ --- | Support for Hamlet templates in Hakyll. --- -module Text.Hakyll.Internal.Template.Hamlet - ( isHamletRTFile - , readHamletRT - , fromHamletRT - ) where - -import Control.Exception (try) -import Control.Monad.Trans (liftIO) -import System.FilePath (takeExtension) - -import Text.Hamlet.RT - -import Text.Hakyll.Internal.Template.Template -import Text.Hakyll.HakyllMonad (Hakyll, askHakyll, hamletSettings, logHakyll) - --- | Determine if a file is a hamlet template by extension. --- -isHamletRTFile :: FilePath -> Bool -isHamletRTFile fileName = takeExtension fileName `elem` [".hamlet", ".hml"] - --- | Read a 'HamletRT' by file name. --- -readHamletRT :: FilePath -- ^ Filename of the template - -> Hakyll HamletRT -- ^ Resulting hamlet template -readHamletRT fileName = do - settings <- askHakyll hamletSettings - string <- liftIO $ readFile fileName - result <- liftIO $ try $ parseHamletRT settings string - case result of - Left (HamletParseException s) -> error' s - Left (HamletUnsupportedDocException d) -> error' $ show d - Left (HamletRenderException s) -> error' s - Right x -> return x - where - error' s = do - logHakyll $ "Parse of hamlet file " ++ fileName ++ " failed." - logHakyll s - error "Parse failed." - --- | Convert a 'HamletRT' to a 'Template' --- -fromHamletRT :: HamletRT -- ^ Hamlet runtime template - -> Template -- ^ Hakyll template -fromHamletRT (HamletRT sd) = Template $ map fromSimpleDoc sd - where - fromSimpleDoc :: SimpleDoc -> TemplateElement - fromSimpleDoc (SDRaw chunk) = Chunk chunk - fromSimpleDoc (SDVar [var]) = Identifier var - fromSimpleDoc (SDVar _) = - error "Hakyll does not support '.' in identifier names when using \ - \hamlet templates." - fromSimpleDoc _ = - error "Only simple $key$ identifiers are allowed when using hamlet \ - \templates." diff --git a/src/Text/Hakyll/Internal/Template/Template.hs b/src/Text/Hakyll/Internal/Template/Template.hs deleted file mode 100644 index 49373fd..0000000 --- a/src/Text/Hakyll/Internal/Template/Template.hs +++ /dev/null @@ -1,34 +0,0 @@ --- | Module containing the template data structure. --- -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Text.Hakyll.Internal.Template.Template - ( Template (..) - , TemplateElement (..) - ) where - -import Control.Applicative ((<$>)) - -import Data.Binary (Binary, get, getWord8, put, putWord8) - --- | Datatype used for template substitutions. --- -newtype Template = Template { unTemplate :: [TemplateElement] } - deriving (Show, Eq, Binary) - --- | Elements of a template. --- -data TemplateElement = Chunk String - | Identifier String - | EscapeCharacter - deriving (Show, Eq) - -instance Binary TemplateElement where - put (Chunk string) = putWord8 0 >> put string - put (Identifier key) = putWord8 1 >> put key - put (EscapeCharacter) = putWord8 2 - - get = getWord8 >>= \tag -> - case tag of 0 -> Chunk <$> get - 1 -> Identifier <$> get - 2 -> return EscapeCharacter - _ -> error "Error reading cached template" diff --git a/src/Text/Hakyll/Metadata.hs b/src/Text/Hakyll/Metadata.hs deleted file mode 100644 index 7698dad..0000000 --- a/src/Text/Hakyll/Metadata.hs +++ /dev/null @@ -1,108 +0,0 @@ --- | This module exports a number of functions to manipulate metadata of --- resources --- -module Text.Hakyll.ContextManipulations - ( renderValue - , changeValue - , changeUrl - , copyValue - , renderDate - , renderDateWithLocale - , changeExtension - ) where - -import System.Locale (TimeLocale, defaultTimeLocale) -import System.FilePath (takeFileName, addExtension, dropExtension) -import Data.Time.Format (parseTime, formatTime) -import Data.Time.Clock (UTCTime) -import Data.Maybe (fromMaybe) -import qualified Data.Map as M - -import Text.Hakyll.Regex (substituteRegex) -import Text.Hakyll.Transformer (Transformer (..), transformMetadata) -import Text.Hakyll.Resource - --- | Do something with a value in a @Context@, but keep the old value as well. --- If the key given is not present in the @Context@, nothing will happen. --- -renderValue :: String -- ^ Key of which the value should be copied. - -> String -- ^ Key the value should be copied to. - -> (String -> String) -- ^ Function to apply on the value. - -> Transformer a a -- ^ Resulting transformer -renderValue source destination f = transformMetadata $ \(Metadata m) -> - Metadata $ case M.lookup source m of - Nothing -> m - (Just value) -> M.insert destination (f value) m - --- | Change a value in the metadata --- --- > import Data.Char (toUpper) --- > changeValue "title" (map toUpper) --- --- Will put the title in UPPERCASE. -changeValue :: String -- ^ Key to change. - -> (String -> String) -- ^ Function to apply on the value. - -> Transformer a a -changeValue key = renderValue key key - --- | Change the URL of a page. You should always use this function instead of --- 'changeValue' for this, because using 'changeValue' might break dependency --- handling when changing the @url@ field. --- -changeUrl :: (String -> String) -- ^ Function to change URL with. - -> Transformer a a -- ^ Resulting action. -changeUrl f = let t = changeValue "url" f - in t {transformerUrl = return . f} - --- | Copy a metadata value from one key to another --- -copyValue :: String -- ^ Source key. - -> String -- ^ Destination key. - -> Transformer a a -- ^ Resulting transformer -copyValue source destination = renderValue source destination id - --- | When the context has a key called @path@ in a --- @folder/yyyy-mm-dd-title.extension@ format (the convention for pages), --- this function can render the date. --- --- > renderDate "date" "%B %e, %Y" "Date unknown" --- --- Will render something like @January 32, 2010@. --- -renderDate :: String -- ^ Key in which the rendered date should be placed. - -> String -- ^ Format to use on the date. - -> String -- ^ Default key, in case the date cannot be parsed. - -> Transformer a a -renderDate = renderDateWithLocale defaultTimeLocale - --- | This is an extended version of 'renderDate' that allows you to specify a --- time locale that is used for outputting the date. For more details, see --- 'renderDate'. --- -renderDateWithLocale :: TimeLocale -- ^ Output time locale. - -> String -- ^ Destination key. - -> String -- ^ Format to use on the date. - -> String -- ^ Default key. - -> Transformer a a -renderDateWithLocale locale key format defaultValue = - renderValue "path" key renderDate' - where - renderDate' filePath = fromMaybe defaultValue $ do - let dateString = substituteRegex "^([0-9]*-[0-9]*-[0-9]*).*" "\\1" - (takeFileName filePath) - time <- parseTime defaultTimeLocale - "%Y-%m-%d" - dateString :: Maybe UTCTime - return $ formatTime locale format time - --- | Change the extension of a file. This is only needed when you want to --- render, for example, mardown to @.php@ files instead of @.html@ files. --- --- > changeExtension "php" --- --- Will render @test.markdown@ to @test.php@ instead of @test.html@. -changeExtension :: String -- ^ Extension to change to. - -> Transformer a a -- ^ Resulting transformer -changeExtension extension = changeValue "url" changeExtension' - where - changeExtension' = flip addExtension extension . dropExtension diff --git a/src/Text/Hakyll/Monad.hs b/src/Text/Hakyll/Monad.hs deleted file mode 100644 index 5de5e44..0000000 --- a/src/Text/Hakyll/Monad.hs +++ /dev/null @@ -1,115 +0,0 @@ --- | Module describing the Hakyll monad stack. -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Text.Hakyll.Monad - ( HakyllConfiguration (..) - , PreviewMode (..) - , Hakyll - , askHakyll - , getAdditionalContext - , logHakyll - , forkHakyllWait - , concurrentHakyll - ) where - -import Control.Monad.Trans (liftIO) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Concurrent.MVar (MVar, putMVar, newEmptyMVar, readMVar) -import Control.Monad.Reader (ReaderT, ask, runReaderT) -import Control.Monad (liftM, forM, forM_) -import qualified Data.Map as M -import System.IO (hPutStrLn, stderr) - -import Text.Pandoc (ParserState, WriterOptions) -import Text.Hamlet (HamletSettings) - -import Text.Hakyll.Context (Context (..)) - --- | Our custom monad stack. --- -newtype Hakyll a = Hakyll (ReaderT HakyllConfiguration IO a) - deriving (Monad, Functor) - -instance MonadIO Hakyll where - liftIO = Hakyll . liftIO - --- | Run a hakyll stack --- -runHakyll :: Hakyll a -> HakyllConfiguration -> IO a -runHakyll (Hakyll h) = runReaderT h - --- | Preview mode. --- -data PreviewMode = BuildOnRequest - | BuildOnInterval - deriving (Show, Eq, Ord) - --- | Hakyll global configuration type. --- -data HakyllConfiguration = HakyllConfiguration - { -- | Absolute URL of the site. - absoluteUrl :: String - , -- | An additional context to use when rendering. This additional context - -- is used globally. - additionalContext :: Context - , -- | Directory where the site is placed. - siteDirectory :: FilePath - , -- | Directory for cache files. - cacheDirectory :: FilePath - , -- | Enable index links. - enableIndexUrl :: Bool - , -- | The preview mode used - previewMode :: PreviewMode - , -- | Pandoc parsing options - pandocParserState :: ParserState - , -- | Pandoc writer options - pandocWriterOptions :: WriterOptions - , -- | Hamlet settings (if you use hamlet for templates) - hamletSettings :: HamletSettings - } - --- | Get the hakyll configuration --- -getHakyllConfiguration :: Hakyll HakyllConfiguration -getHakyllConfiguration = Hakyll ask - --- | Simplified @ask@ function for the Hakyll monad stack. --- --- Usage would typically be something like: --- --- > doSomething :: a -> b -> Hakyll c --- > doSomething arg1 arg2 = do --- > siteDirectory' <- askHakyll siteDirectory --- > ... --- -askHakyll :: (HakyllConfiguration -> a) -> Hakyll a -askHakyll = flip liftM getHakyllConfiguration - --- | Obtain the globally available, additional context. --- -getAdditionalContext :: HakyllConfiguration -> Context -getAdditionalContext configuration = - let (Context c) = additionalContext configuration - in Context $ M.insert "absolute" (absoluteUrl configuration) c - --- | Write some log information. --- -logHakyll :: String -> Hakyll () -logHakyll = Hakyll . liftIO . hPutStrLn stderr - --- | Perform a concurrent hakyll action. Returns an MVar you can wait on --- -forkHakyllWait :: Hakyll () -> Hakyll (MVar ()) -forkHakyllWait action = do - mvar <- liftIO newEmptyMVar - config <- getHakyllConfiguration - liftIO $ do - runHakyll action config - putMVar mvar () - return mvar - --- | Perform a number of concurrent hakyll actions, and waits for them to finish --- -concurrentHakyll :: [Hakyll ()] -> Hakyll () -concurrentHakyll actions = do - mvars <- forM actions forkHakyllWait - forM_ mvars (liftIO . readMVar) diff --git a/src/Text/Hakyll/Page.hs b/src/Text/Hakyll/Page.hs deleted file mode 100644 index f2b5fde..0000000 --- a/src/Text/Hakyll/Page.hs +++ /dev/null @@ -1,108 +0,0 @@ --- | A module for dealing with @Page@s. This module is mostly internally used. -module Text.Hakyll.Page - ( PageSection (..) - , readPage - , readPageAction - ) where - -import Data.List (isPrefixOf) -import Data.Char (isSpace) -import Control.Monad.Reader (liftIO) -import System.FilePath -import Control.Monad.State (State, evalState, get, put) - -import Text.Hakyll.File -import Text.Hakyll.HakyllMonad -import Text.Hakyll.HakyllAction -import Text.Hakyll.Regex (substituteRegex, matchesRegex) -import Text.Hakyll.Util (trim) - --- | A page is first parsed into a number of page sections. A page section --- consists of: --- --- * A key --- --- * A value --- --- * A 'Bool' flag, indicating if the value is applicable for rendering --- -data PageSection = PageSection {unPageSection :: (String, String, Bool)} - deriving (Show) - --- | Split a page into sections. --- -splitAtDelimiters :: [String] -> State (Maybe String) [[String]] -splitAtDelimiters [] = return [] -splitAtDelimiters ls@(x:xs) = do - delimiter <- get - if not (isDelimiter delimiter x) - then return [ls] - else do let proper = takeWhile (== '-') x - (content, rest) = break (isDelimiter $ Just proper) xs - put $ Just proper - rest' <- splitAtDelimiters rest - return $ (x : content) : rest' - where - isDelimiter old = case old of - Nothing -> isPossibleDelimiter - (Just d) -> (== d) . takeWhile (== '-') - --- | Check if the given string is a metadata delimiter. -isPossibleDelimiter :: String -> Bool -isPossibleDelimiter = isPrefixOf "---" - --- | Read one section of a page. --- -readSection :: Bool -- ^ If this section is the first section in the page. - -> [String] -- ^ Lines in the section. - -> [PageSection] -- ^ Key-values extracted. -readSection _ [] = [] -readSection isFirst ls - | not isDelimiter' = [body ls] - | isNamedDelimiter = readSectionMetaData ls - | isFirst = readSimpleMetaData (drop 1 ls) - | otherwise = [body (drop 1 ls)] - where - isDelimiter' = isPossibleDelimiter (head ls) - isNamedDelimiter = head ls `matchesRegex` "^----* *[a-zA-Z0-9][a-zA-Z0-9]*" - body ls' = PageSection ("body", unlines ls', True) - - readSimpleMetaData = map readPair . filter (not . all isSpace) - readPair = trimPair . break (== ':') - trimPair (key, value) = PageSection (trim key, trim (drop 1 value), False) - - readSectionMetaData [] = [] - readSectionMetaData (header:value) = - let key = substituteRegex "[^a-zA-Z0-9]" "" header - in [PageSection (key, unlines value, True)] - --- | Read a page from a file. Metadata is supported. --- -readPage :: FilePath -> Hakyll [PageSection] -readPage path = do - let sectionFunctions = map readSection $ True : repeat False - - -- Read file. - contents <- liftIO $ readFile path - url <- toUrl path - let sections = evalState (splitAtDelimiters $ lines contents) Nothing - sectionsData = concat $ zipWith ($) sectionFunctions sections - - -- Note that url, path etc. are listed first, which means can be overwritten - -- by section data - return $ PageSection ("url", url, False) - : PageSection ("path", path, False) - : PageSection ("title", takeBaseName path, False) - : (category ++ sectionsData) - where - category = let dirs = splitDirectories $ takeDirectory path - in [PageSection ("category", last dirs, False) | not (null dirs)] - --- | Read a page from a file. Metadata is supported. --- -readPageAction :: FilePath -> HakyllAction () [PageSection] -readPageAction path = HakyllAction - { actionDependencies = [path] - , actionUrl = Left $ toUrl path - , actionFunction = const $ readPage path - } diff --git a/src/Text/Hakyll/Paginate.hs b/src/Text/Hakyll/Paginate.hs deleted file mode 100644 index 04194ca..0000000 --- a/src/Text/Hakyll/Paginate.hs +++ /dev/null @@ -1,94 +0,0 @@ --- | Module aimed to paginate web pages. --- -module Text.Hakyll.Paginate - ( PaginateConfiguration (..) - , defaultPaginateConfiguration - , paginate - ) where - -import Control.Applicative ((<$>)) - -import Text.Hakyll.Context (Context) -import Text.Hakyll.CreateContext -import Text.Hakyll.HakyllAction -import Text.Hakyll.Util (link) - --- | A configuration for a pagination. --- -data PaginateConfiguration = PaginateConfiguration - { -- | Label for the link to the previous page. - previousLabel :: String - , -- | Label for the link to the next page. - nextLabel :: String - , -- | Label for the link to the first page. - firstLabel :: String - , -- | Label for the link to the last page. - lastLabel :: String - } - --- | A simple default configuration for pagination. --- -defaultPaginateConfiguration :: PaginateConfiguration -defaultPaginateConfiguration = PaginateConfiguration - { previousLabel = "Previous" - , nextLabel = "Next" - , firstLabel = "First" - , lastLabel = "Last" - } - --- | The most important function for pagination. This function operates on a --- list of @Context@s (the pages), and basically just adds fields to them --- by combining them with a custom page. --- --- The following metadata fields will be added: --- --- - @$previous@: A link to the previous page. --- --- - @$next@: A link to the next page. --- --- - @$first@: A link to the first page. --- --- - @$last@: A link to the last page. --- --- - @$index@: 1-based index of the current page. --- --- - @$length@: Total number of pages. --- --- When @$previous@ or @$next@ are not available, they will be just a label --- without a link. The same goes for when we are on the first or last page for --- @$first@ and @$last@. --- -paginate :: PaginateConfiguration - -> [HakyllAction () Context] - -> [HakyllAction () Context] -paginate configuration renderables = paginate' Nothing renderables (1 :: Int) - where - -- Create a link with a given label, taken from the configuration. - linkWithLabel f r = Right $ case actionUrl r of - Left l -> createSimpleHakyllAction $ - link (f configuration) . ("$root/" ++) <$> l - Right _ -> error "No link found for pagination." - - -- The main function that creates combined renderables by recursing over - -- the list of items. - paginate' _ [] _ = [] - paginate' maybePrev (x:xs) index = - let (previous, first) = case maybePrev of - (Just r) -> ( linkWithLabel previousLabel r - , linkWithLabel firstLabel (head renderables) ) - Nothing -> ( Left $ previousLabel configuration - , Left $ firstLabel configuration ) - (next, last') = case xs of - (n:_) -> ( linkWithLabel nextLabel n - , linkWithLabel lastLabel (last renderables) ) - [] -> ( Left $ nextLabel configuration - , Left $ lastLabel configuration ) - customPage = createCustomPage "" - [ ("previous", previous) - , ("next", next) - , ("first", first) - , ("last", last') - , ("index", Left $ show index) - , ("length", Left $ show $ length renderables) - ] - in (x `combine` customPage) : paginate' (Just x) xs (index + 1) diff --git a/src/Text/Hakyll/Pandoc.hs b/src/Text/Hakyll/Pandoc.hs deleted file mode 100644 index af4be62..0000000 --- a/src/Text/Hakyll/Pandoc.hs +++ /dev/null @@ -1,88 +0,0 @@ --- | Module exporting a pandoc arrow --- -module Text.Hakyll.Pandoc - ( renderAction - , renderActionWith - ) where - -import Data.Maybe (fromMaybe) -import qualified Data.Map as M -import Control.Arrow (second, (>>>), arr, (&&&)) - -import Text.Pandoc - -import Text.Hakyll.Internal.FileType -import Text.Hakyll.Page -import Text.Hakyll.HakyllMonad -import Text.Hakyll.HakyllAction -import Text.Hakyll.Context - --- | Reader function for plain text --- -readText :: ParserState -> String -> Pandoc -readText _ = Pandoc (Meta [] [] []) . return . Plain . return . Str - --- | Get a read function for a given extension. --- -readPandoc :: HakyllAction (FileType, String) Pandoc -readPandoc = createHakyllAction $ \(fileType, inp) -> do - parserState <- askHakyll pandocParserState - return $ readFunction fileType (readOptions parserState fileType) inp - where - readFunction ReStructuredText = readRST - readFunction LaTeX = readLaTeX - readFunction Markdown = readMarkdown - readFunction LiterateHaskellMarkdown = readMarkdown - readFunction Html = readHtml - readFunction Text = readText - readFunction t = error $ "Cannot render " ++ show t - - readOptions options LiterateHaskellMarkdown = options - { stateLiterateHaskell = True } - readOptions options _ = options - --- | Get a render function for a given extension. --- -getRenderFunction :: HakyllAction FileType (String -> String) -getRenderFunction = createHakyllAction $ \fileType -> case fileType of - Html -> return id - Text -> return id - UnknownFileType -> return id - _ -> do parserState <- askHakyll pandocParserState - writerOptions <- askHakyll pandocWriterOptions - return $ writeHtmlString writerOptions - . readFunction fileType (readOptions parserState fileType) - where - readFunction ReStructuredText = readRST - readFunction LaTeX = readLaTeX - readFunction Markdown = readMarkdown - readFunction LiterateHaskellMarkdown = readMarkdown - readFunction t = error $ "Cannot render " ++ show t - - readOptions options LiterateHaskellMarkdown = options - { stateLiterateHaskell = True } - readOptions options _ = options - --- | Get a render action --- -renderPandoc :: HakyllAction Pandoc String -renderPandoc = createHakyllAction $ \p -> do - writerOptions <- askHakyll pandocWriterOptions - return $ writeHtmlString writerOptions p - --- | An action that renders the list of page sections to a context using pandoc --- -renderAction :: HakyllAction [PageSection] Context -renderAction = (arr id &&& (getFileType' >>> getRenderFunction)) - >>> renderActionWith - where - getFileType' = arr $ getFileType . fromMaybe "unknown" . lookup "path" - . map (\(x, y, _) -> (x, y)) . map unPageSection - --- | An action to render pages, offering just a little more flexibility --- -renderActionWith :: HakyllAction ([PageSection], String -> String) Context -renderActionWith = createHakyllAction $ \(sections, render') -> return $ - Context $ M.fromList $ map (renderTriple render' . unPageSection) sections - where - renderTriple render' (k, v, r) = second (if r then render' else id) (k, v) diff --git a/src/Text/Hakyll/Regex.hs b/src/Text/Hakyll/Regex.hs deleted file mode 100644 index ba7ee46..0000000 --- a/src/Text/Hakyll/Regex.hs +++ /dev/null @@ -1,77 +0,0 @@ --- | A module that exports a simple regex interface. This code is mostly copied --- from the regex-compat package at hackage. I decided to write this module --- because I want to abstract the regex package used. -module Text.Hakyll.Regex - ( splitRegex - , substituteRegex - , matchesRegex - ) where - -import Text.Regex.TDFA - --- | Match a regular expression against a string, returning more information --- about the match. -matchRegexAll :: Regex -> String -> Maybe (String, String, String, [String]) -matchRegexAll = matchM - --- | Replaces every occurance of the given regexp with the replacement string. -subRegex :: Regex -- ^ Search pattern - -> String -- ^ Input string - -> String -- ^ Replacement text - -> String -- ^ Output string -subRegex _ "" _ = "" -subRegex regexp inp replacement = - let -- bre matches a backslash then capture either a backslash or some digits - bre = makeRegex "\\\\(\\\\|[0-9]+)" - lookup' _ [] _ = [] - lookup' [] _ _ = [] - lookup' match' repl groups = - case matchRegexAll bre repl of - Nothing -> repl - Just (lead, _, trail, bgroups) -> - let newval = - if head bgroups == "\\" - then "\\" - else let index :: Int - index = read (head bgroups) - 1 - in if index == -1 - then match' - else groups !! index - in lead ++ newval ++ lookup' match' trail groups - in case matchRegexAll regexp inp of - Nothing -> inp - Just (lead, match', trail, groups) -> - lead ++ lookup' match' replacement groups - ++ subRegex regexp trail replacement - --- | Splits a string based on a regular expression. The regular expression --- should identify one delimiter. -splitRegex' :: Regex -> String -> [String] -splitRegex' _ [] = [] -splitRegex' delim strIn = loop strIn where - loop str = case matchOnceText delim str of - Nothing -> [str] - Just (firstline, _, remainder) -> - if null remainder - then [firstline,""] - else firstline : loop remainder - --- | Split a list at a certain element. -splitRegex :: String -> String -> [String] -splitRegex pattern = filter (not . null) - . splitRegex' (makeRegex pattern) - --- | Substitute a regex. Simplified interface. This function performs a global --- substitution. -substituteRegex :: String -- ^ Pattern to replace (regex). - -> String -- ^ Replacement string. - -> String -- ^ Input string. - -> String -- ^ Result. -substituteRegex pattern replacement string = - subRegex (makeRegex pattern) string replacement - --- | Simple regex matching. -matchesRegex :: String -- ^ Input string. - -> String -- ^ Pattern to match. - -> Bool -matchesRegex = (=~) diff --git a/src/Text/Hakyll/Render.hs b/src/Text/Hakyll/Render.hs deleted file mode 100644 index aa3ef8c..0000000 --- a/src/Text/Hakyll/Render.hs +++ /dev/null @@ -1,126 +0,0 @@ --- | Module containing rendering functions. All these functions are used to --- render files to the @_site@ directory. -module Text.Hakyll.Render - ( render - , renderAndConcat - , renderChain - , static - , css - , writePage - ) where - -import Control.Arrow ((>>>)) -import Control.Applicative ((<$>)) -import Control.Monad.Reader (liftIO) -import System.Directory (copyFile) -import Data.Maybe (fromMaybe) -import qualified Data.Map as M - -import Text.Hakyll.Context (Context (..)) -import Text.Hakyll.HakyllMonad (Hakyll, askHakyll, getAdditionalContext) -import Text.Hakyll.File -import Text.Hakyll.HakyllAction -import Text.Hakyll.ContextManipulations -import Text.Hakyll.Internal.CompressCss -import Text.Hakyll.Internal.Template - --- | A pure render function - used internally. -pureRender :: Template -- ^ Template to use for rendering. - -> Context -- ^ Renderable object to render with given template. - -> Context -- ^ The body of the result will contain the render. -pureRender template (Context c) = - -- Ignore $root when substituting here. We will only replace that in the - -- final render (just before writing). - let contextIgnoringRoot = Context $ M.insert "root" "$root" c - body = regularSubstitute template $ contextIgnoringRoot - in Context $ M.insert "body" body c - --- | This is the most simple render action. You render a @Context@ with a --- template, and get back the result. -render :: FilePath -- ^ Template to use for rendering. - -> HakyllAction Context Context -- ^ The render computation. -render templatePath = HakyllAction - { actionDependencies = [templatePath] - , actionUrl = Right id - , actionFunction = \context -> - flip pureRender context <$> readTemplate templatePath - } - --- | Render each @Context@ with the given templates, then concatenate the --- result. So, basically this function: --- --- - Takes every @Context@. --- --- - Renders every @Context@ with all given templates. This is comparable --- with a renderChain action. --- --- - Concatenates the result and returns that as a @String@. -renderAndConcat :: [FilePath] - -> [HakyllAction () Context] - -> HakyllAction () String -renderAndConcat templatePaths renderables = HakyllAction - { actionDependencies = renders >>= actionDependencies - , actionUrl = Right id - , actionFunction = actionFunction' - } - where - render' = chain (map render templatePaths) - renders = map (>>> render') renderables - - actionFunction' _ = do - contexts <- mapM (runHakyllAction . (>>> takeBody)) renders - return $ concat contexts - --- | Chain a render action for a page with a number of templates. This will --- also write the result to the site destination. This is the preferred way --- to do general rendering. --- --- > renderChain [ "templates/notice.html" --- > , "templates/default.html" --- > ] $ createPagePath "warning.html" --- --- This code will first render @warning.html@ using @templates/notice.html@, --- and will then render the result with @templates/default.html@. -renderChain :: [FilePath] - -> HakyllAction () Context - -> Hakyll () -renderChain templatePaths initial = - runHakyllActionIfNeeded renderChainWith' - where - renderChainWith' = initial >>> chain' >>> writePage - chain' = chain $ map render templatePaths - --- | Mark a certain file as static, so it will just be copied when the site is --- generated. -static :: FilePath -> Hakyll () -static source = runHakyllActionIfNeeded static' - where - static' = createFileHakyllAction source $ do - destination <- toDestination source - makeDirectories destination - liftIO $ copyFile source destination - --- | Render a css file, compressing it. -css :: FilePath -> Hakyll () -css source = runHakyllActionIfNeeded css' - where - css' = createFileHakyllAction source $ do - contents <- liftIO $ readFile source - destination <- toDestination source - makeDirectories destination - liftIO $ writeFile destination (compressCss contents) - --- | Write a page to the site destination. Final action after render --- chains and such. -writePage :: HakyllAction Context () -writePage = createHakyllAction $ \(Context initialContext) -> do - additionalContext' <- unContext <$> askHakyll getAdditionalContext - let url = fromMaybe (error "No url defined at write time.") - (M.lookup "url" initialContext) - body = fromMaybe "" (M.lookup "body" initialContext) - let context = additionalContext' `M.union` M.singleton "root" (toRoot url) - destination <- toDestination url - makeDirectories destination - -- Substitute $root here, just before writing. - liftIO $ writeFile destination $ finalSubstitute (fromString body) - (Context context) diff --git a/src/Text/Hakyll/Resource.hs b/src/Text/Hakyll/Resource.hs deleted file mode 100644 index b0ffb8c..0000000 --- a/src/Text/Hakyll/Resource.hs +++ /dev/null @@ -1,57 +0,0 @@ --- | A resource represents data for a website --- -module Text.Hakyll.Resource - ( Metadata (..) - , Resource (..) - , getData - , getMetadata - ) where - -import Data.Monoid (Monoid, mempty, mappend) -import Control.Applicative (Applicative, (<*>), pure) -import Data.Map (Map) -import qualified Data.Map as M - --- | Metadata for a resource --- -newtype Metadata = Metadata {unMetadata :: Map String String} - deriving (Show, Eq, Ord) - -instance Monoid Metadata where - mempty = Metadata M.empty - (Metadata m1) `mappend` (Metadata m2) = Metadata $ m1 `M.union` m2 - --- | A resource represents a data source for the website. It contains a value --- and a number of metadata fields --- -data Resource a = Resource - { resourceMetadata :: Metadata - , resourceData :: a - } deriving (Show, Eq, Ord) - -instance Functor Resource where - fmap f (Resource m d) = Resource m $ f d - -instance Applicative Resource where - pure d = Resource mempty d - (Resource m1 f) <*> (Resource m2 d) = Resource (mappend m2 m1) (f d) - -instance Monad Resource where - return d = Resource mempty d - (Resource m1 d) >>= f = let Resource m2 d' = f d - in Resource (mappend m2 m1) d' - -instance Monoid a => Monoid (Resource a) where - mempty = Resource mempty mempty - mappend (Resource m1 d1) (Resource m2 d2) = - Resource (mappend m1 m2) (mappend d1 d2) - --- | Get the data from a resource --- -getData :: Resource a -> a -getData = resourceData - --- | Get a metadata field from a resource --- -getMetadata :: String -> Resource a -> Maybe String -getMetadata k (Resource m _) = M.lookup k $ unMetadata m diff --git a/src/Text/Hakyll/Tags.hs b/src/Text/Hakyll/Tags.hs deleted file mode 100644 index a4559ca..0000000 --- a/src/Text/Hakyll/Tags.hs +++ /dev/null @@ -1,172 +0,0 @@ --- | Module containing some specialized functions to deal with tags. --- This Module follows certain conventions. Stick with them. --- --- More concrete: all functions in this module assume that the tags are --- located in the @tags@ field, and separated by commas. An example file --- @foo.markdown@ could look like: --- --- > --- --- > author: Philip K. Dick --- > title: Do androids dream of electric sheep? --- > tags: future, science fiction, humanoid --- > --- --- > The novel is set in a post-apocalyptic near future, where the Earth and --- > its populations have been damaged greatly by Nuclear... --- --- All the following functions would work with such a format. In addition to --- tags, Hakyll also supports categories. The convention when using categories --- is to place pages in subdirectories. --- --- An example, the page @posts\/coding\/2010-01-28-hakyll-categories.markdown@ --- Tags or categories are read using the @readTagMap@ and @readCategoryMap@ --- functions. Because categories are implemented using tags - categories can --- be seen as tags, with the restriction that a page can only have one --- category - all functions for tags also work with categories. --- --- When reading a @TagMap@ (which is also used for category maps) using the --- @readTagMap@ or @readCategoryMap@ function, you also have to give a unique --- identifier to it. This identifier is simply for caching reasons, so Hakyll --- can tell different maps apart; it has no other use. --- -module Text.Hakyll.Tags - ( TagMap - , readTagMap - , readCategoryMap - , withTagMap - , renderTagCloud - , renderTagLinks - ) where - -import qualified Data.Map as M -import Data.List (intercalate) -import Data.Maybe (fromMaybe, maybeToList) -import Control.Arrow (second, (>>>)) -import Control.Applicative ((<$>)) -import System.FilePath - -import Text.Blaze.Renderer.String (renderHtml) -import Text.Blaze.Html5 ((!), string, stringValue) -import qualified Text.Blaze.Html5 as H -import qualified Text.Blaze.Html5.Attributes as A - -import Text.Hakyll.Context (Context (..)) -import Text.Hakyll.ContextManipulations (changeValue) -import Text.Hakyll.CreateContext (createPage) -import Text.Hakyll.HakyllMonad (Hakyll) -import Text.Hakyll.Regex -import Text.Hakyll.HakyllAction -import Text.Hakyll.Util -import Text.Hakyll.Internal.Cache - --- | Type for a tag map. --- --- This is a map associating tags or categories to the appropriate pages --- using that tag or category. In the case of categories, each path will only --- appear under one category - this is not the case with tags. -type TagMap = M.Map String [HakyllAction () Context] - --- | Read a tag map. This is a internally used function that can be used for --- tags as well as for categories. -readMap :: (Context -> [String]) -- ^ Function to get tags from a context. - -> String -- ^ Unique identifier for the tagmap. - -> [FilePath] - -> HakyllAction () TagMap -readMap getTagsFunction identifier paths = HakyllAction - { actionDependencies = paths - , actionUrl = Right id - , actionFunction = actionFunction' - } - where - fileName = "tagmaps" </> identifier - - actionFunction' _ = do - isCacheMoreRecent' <- isCacheMoreRecent fileName paths - assocMap <- if isCacheMoreRecent' - then M.fromAscList <$> getFromCache fileName - else do assocMap' <- readTagMap' - storeInCache (M.toAscList assocMap') fileName - return assocMap' - return $ M.map (map createPage) assocMap - - -- TODO: preserve order - readTagMap' :: Hakyll (M.Map String [FilePath]) - readTagMap' = do - pairs' <- concat <$> mapM pairs paths - return $ M.fromListWith (flip (++)) pairs' - - -- | Read a page, and return an association list where every tag is - -- associated with some paths. Of course, this will always be just one - -- @FilePath@ here. - pairs :: FilePath -> Hakyll [(String, [FilePath])] - pairs path = do - context <- runHakyllAction $ createPage path - let tags = getTagsFunction context - return $ map (\tag -> (tag, [path])) tags - --- | Read a @TagMap@, using the @tags@ metadata field. -readTagMap :: String -- ^ Unique identifier for the map. - -> [FilePath] -- ^ Paths to get tags from. - -> HakyllAction () TagMap -readTagMap = readMap getTagsFunction - where - getTagsFunction = map trim . splitRegex "," - . fromMaybe [] . M.lookup "tags" . unContext - --- | Read a @TagMap@, using the subdirectories the pages are placed in. -readCategoryMap :: String -- ^ Unique identifier for the map. - -> [FilePath] -- ^ Paths to get tags from. - -> HakyllAction () TagMap -readCategoryMap = readMap $ maybeToList . M.lookup "category" . unContext - --- | Perform a @Hakyll@ action on every item in the tag --- -withTagMap :: HakyllAction () TagMap - -> (String -> [HakyllAction () Context] -> Hakyll ()) - -> Hakyll () -withTagMap tagMap function = runHakyllAction (tagMap >>> action) - where - action = createHakyllAction (mapM_ (uncurry function) . M.toList) - --- | Render a tag cloud. -renderTagCloud :: (String -> String) -- ^ Function to produce an url for a tag. - -> Float -- ^ Smallest font size, in percent. - -> Float -- ^ Biggest font size, in percent. - -> HakyllAction TagMap String -renderTagCloud urlFunction minSize maxSize = createHakyllAction renderTagCloud' - where - renderTagCloud' tagMap = - return $ intercalate " " $ map (renderTag tagMap) (tagCount tagMap) - - renderTag tagMap (tag, count) = renderHtml $ - H.a ! A.style (stringValue $ "font-size: " ++ sizeTag tagMap count) - ! A.href (stringValue $ urlFunction tag) - $ string tag - - sizeTag tagMap count = show (size' :: Int) ++ "%" - where - size' = floor $ minSize + relative tagMap count * (maxSize - minSize) - - minCount = minimum . map snd . tagCount - maxCount = maximum . map snd . tagCount - relative tagMap count = (count - minCount tagMap) / - (maxCount tagMap - minCount tagMap) - - tagCount = map (second $ fromIntegral . length) . M.toList - --- | Render all tags to links. --- --- On your site, it is nice if you can display the tags on a page, but --- naturally, most people would expect these are clickable. --- --- So, this function takes a function to produce an url for a given tag, and --- applies it on all tags. --- --- Note that it is your own responsibility to ensure a page with such an url --- exists. -renderTagLinks :: (String -> String) -- ^ Function to produce an url for a tag. - -> HakyllAction Context Context -renderTagLinks urlFunction = changeValue "tags" renderTagLinks' - where - renderTagLinks' = intercalate ", " - . map ((\t -> link t $ urlFunction t) . trim) - . splitRegex "," diff --git a/src/Text/Hakyll/Transformer.hs b/src/Text/Hakyll/Transformer.hs deleted file mode 100644 index 669e1d0..0000000 --- a/src/Text/Hakyll/Transformer.hs +++ /dev/null @@ -1,107 +0,0 @@ --- | This is the module which exports @Transformer@. -module Text.Hakyll.Transformer - ( Transformer (..) - , transformResource - , transformResourceM - , transformData - , transformDataM - , transformMetadata - , transformMetadataM - , runTransformer - , runTransformerForced - ) where - -import Data.Monoid (Monoid, mappend, mempty) -import Control.Arrow -import Control.Category -import Control.Applicative ((<$>)) -import Control.Monad ((<=<), unless, liftM2) -import Prelude hiding ((.), id) - -import Text.Hakyll.Resource -import Text.Hakyll.File (toDestination, isFileMoreRecent) -import Text.Hakyll.Monad - --- | Type used for computations that transform resources, carrying along --- dependencies. --- -data Transformer a b = Transformer - { -- | Dependencies of the @Transformer@. - transformerDependencies :: [FilePath] - , -- | URL pointing to the result of this @Transformer@. - transformerUrl :: FilePath -> Hakyll FilePath - , -- | The actual transforming function. - transformerFunction :: Resource a -> Hakyll (Resource b) - } - -instance Monoid b => Monoid (Transformer a b) where - mempty = arr (const mempty) - mappend x y = Transformer - { transformerDependencies = - transformerDependencies x ++ transformerDependencies y - , transformerUrl = transformerUrl x - , transformerFunction = \r -> - liftM2 mappend (transformerFunction x r) (transformerFunction y r) - } - -instance Category Transformer where - id = Transformer - { transformerDependencies = [] - , transformerUrl = return - , transformerFunction = return - } - - x . y = Transformer - { transformerDependencies = - transformerDependencies x ++ transformerDependencies y - , transformerUrl = transformerUrl y <=< transformerUrl x - , transformerFunction = transformerFunction x <=< transformerFunction y - } - -instance Arrow Transformer where - arr = transformData - - first t = t - { transformerFunction = \(Resource m (x, y)) -> do - Resource m' x' <- transformerFunction t $ Resource m x - return $ Resource (mappend m' m) (x', y) - } - -transformResource :: (Resource a -> Resource b) -> Transformer a b -transformResource = transformResourceM . (return .) - -transformResourceM :: (Resource a -> Hakyll (Resource b)) -> Transformer a b -transformResourceM f = id {transformerFunction = f} - -transformData :: (a -> b) -> Transformer a b -transformData = transformResource . fmap - -transformDataM :: (a -> Hakyll b) -> Transformer a b -transformDataM f = transformResourceM $ \(Resource m x) -> - f x >>= return . Resource m - -transformMetadata :: (Metadata -> Metadata) -> Transformer a a -transformMetadata = transformMetadataM . (return .) - -transformMetadataM :: (Metadata -> Hakyll Metadata) -> Transformer a a -transformMetadataM f = transformResourceM $ \(Resource m x) -> do - m' <- f m - return $ Resource m' x - --- | Run a transformer. This might not run it when the result is up-to-date --- -runTransformer :: Transformer () () - -> Hakyll () -runTransformer t = do - url <- transformerUrl t $ - error "runTransformer: No url when checking dependencies." - destination <- toDestination url - valid <- isFileMoreRecent destination $ transformerDependencies t - unless valid $ do logHakyll $ "Rendering " ++ destination - runTransformerForced t - --- | Always run the transformer, even when the target is up-to-date --- -runTransformerForced :: Transformer () () - -> Hakyll () -runTransformerForced t = getData <$> transformerFunction t mempty diff --git a/src/Text/Hakyll/Util.hs b/src/Text/Hakyll/Util.hs deleted file mode 100644 index e032c52..0000000 --- a/src/Text/Hakyll/Util.hs +++ /dev/null @@ -1,34 +0,0 @@ --- | Miscellaneous text manipulation functions. -module Text.Hakyll.Util - ( trim - , stripHtml - , link - ) where - -import Data.Char (isSpace) - -import Text.Blaze.Html5 ((!), string, stringValue, a) -import Text.Blaze.Html5.Attributes (href) -import Text.Blaze.Renderer.String (renderHtml) - --- | Trim a string (drop spaces, tabs and newlines at both sides). -trim :: String -> String -trim = reverse . trim' . reverse . trim' - where - trim' = dropWhile isSpace - --- | Strip html tags from the given string. -stripHtml :: String -> String -stripHtml [] = [] -stripHtml str = let (beforeTag, rest) = break (== '<') str - (_, afterTag) = break (== '>') rest - in beforeTag ++ stripHtml (drop 1 afterTag) - --- | Make a HTML link. --- --- > link "foo" "bar.html" == "<a href='bar.html'>foo</a>" -link :: String -- ^ Link text. - -> String -- ^ Link destination. - -> String -link text destination = renderHtml $ a ! href (stringValue destination) - $ string text |