2012-11-13 16:31:03 +00:00
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
2010-12-25 17:15:44 +00:00
|
|
|
module Hakyll.Core.Compiler
|
2010-12-30 16:47:31 +00:00
|
|
|
( Compiler
|
2012-11-18 20:56:52 +00:00
|
|
|
, getUnderlying
|
2012-12-29 15:24:27 +00:00
|
|
|
, getUnderlyingExtension
|
2012-11-18 20:56:52 +00:00
|
|
|
, makeItem
|
2010-12-30 20:18:55 +00:00
|
|
|
, getRoute
|
2012-11-10 17:11:46 +00:00
|
|
|
, getResourceBody
|
2010-12-29 21:59:38 +00:00
|
|
|
, getResourceString
|
2011-05-06 08:28:35 +00:00
|
|
|
, getResourceLBS
|
2011-09-19 21:08:40 +00:00
|
|
|
, getResourceWith
|
2012-11-24 09:56:19 +00:00
|
|
|
|
|
|
|
, Internal.Snapshot
|
|
|
|
, saveSnapshot
|
2012-12-13 21:25:28 +00:00
|
|
|
, Internal.load
|
|
|
|
, Internal.loadSnapshot
|
|
|
|
, Internal.loadBody
|
|
|
|
, Internal.loadSnapshotBody
|
|
|
|
, Internal.loadAll
|
|
|
|
, Internal.loadAllSnapshots
|
2012-11-24 09:56:19 +00:00
|
|
|
|
2010-12-31 11:38:12 +00:00
|
|
|
, cached
|
2011-01-17 21:43:44 +00:00
|
|
|
, unsafeCompiler
|
2012-11-14 10:17:28 +00:00
|
|
|
, debugCompiler
|
2010-12-25 17:15:44 +00:00
|
|
|
) where
|
|
|
|
|
2010-12-29 21:59:38 +00:00
|
|
|
|
2012-11-13 16:31:03 +00:00
|
|
|
--------------------------------------------------------------------------------
|
2012-11-13 22:59:49 +00:00
|
|
|
import Control.Applicative ((<$>))
|
|
|
|
import Data.Binary (Binary)
|
|
|
|
import Data.ByteString.Lazy (ByteString)
|
|
|
|
import Data.Typeable (Typeable)
|
|
|
|
import System.Environment (getProgName)
|
2012-12-29 15:24:27 +00:00
|
|
|
import System.FilePath (takeExtension)
|
2011-01-04 10:13:08 +00:00
|
|
|
|
2011-01-07 11:12:13 +00:00
|
|
|
|
2012-11-13 16:31:03 +00:00
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
import Hakyll.Core.Compiler.Internal
|
2012-11-24 09:56:19 +00:00
|
|
|
import qualified Hakyll.Core.Compiler.Require as Internal
|
2012-11-13 16:31:03 +00:00
|
|
|
import Hakyll.Core.Identifier
|
2012-11-18 20:56:52 +00:00
|
|
|
import Hakyll.Core.Item
|
2012-11-14 10:17:28 +00:00
|
|
|
import Hakyll.Core.Logger as Logger
|
2012-11-18 20:56:52 +00:00
|
|
|
import Hakyll.Core.Provider
|
2012-11-13 16:31:03 +00:00
|
|
|
import Hakyll.Core.Routes
|
2012-11-13 22:59:49 +00:00
|
|
|
import qualified Hakyll.Core.Store as Store
|
2011-01-07 11:12:13 +00:00
|
|
|
|
2011-01-03 22:24:22 +00:00
|
|
|
|
2012-11-13 16:31:03 +00:00
|
|
|
--------------------------------------------------------------------------------
|
2013-01-14 09:47:04 +00:00
|
|
|
-- | Get the underlying identifier.
|
2012-11-18 20:56:52 +00:00
|
|
|
getUnderlying :: Compiler Identifier
|
|
|
|
getUnderlying = compilerUnderlying <$> compilerAsk
|
2012-11-13 16:31:03 +00:00
|
|
|
|
2010-12-30 20:18:55 +00:00
|
|
|
|
2012-12-29 15:24:27 +00:00
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
-- | Get the extension of the underlying identifier. Returns something like
|
|
|
|
-- @".html"@
|
|
|
|
getUnderlyingExtension :: Compiler String
|
|
|
|
getUnderlyingExtension = takeExtension . toFilePath <$> getUnderlying
|
|
|
|
|
|
|
|
|
2012-11-13 16:31:03 +00:00
|
|
|
--------------------------------------------------------------------------------
|
2012-11-18 20:56:52 +00:00
|
|
|
makeItem :: a -> Compiler (Item a)
|
|
|
|
makeItem x = do
|
|
|
|
identifier <- getUnderlying
|
|
|
|
return $ Item identifier x
|
2011-02-06 17:32:09 +00:00
|
|
|
|
2012-11-13 16:31:03 +00:00
|
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
2011-02-06 17:32:09 +00:00
|
|
|
-- | Get the route for a specified item
|
2012-11-18 20:56:52 +00:00
|
|
|
getRoute :: Identifier -> Compiler (Maybe FilePath)
|
|
|
|
getRoute identifier = do
|
2012-11-13 16:31:03 +00:00
|
|
|
routes <- compilerRoutes <$> compilerAsk
|
2011-02-03 15:07:49 +00:00
|
|
|
return $ runRoutes routes identifier
|
2010-12-29 21:59:38 +00:00
|
|
|
|
2012-11-10 17:11:46 +00:00
|
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
-- | Get the body of the underlying resource
|
2012-11-18 20:56:52 +00:00
|
|
|
getResourceBody :: Compiler (Item String)
|
2012-11-10 17:11:46 +00:00
|
|
|
getResourceBody = getResourceWith resourceBody
|
|
|
|
|
|
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
2010-12-30 20:18:55 +00:00
|
|
|
-- | Get the resource we are compiling as a string
|
2012-11-18 20:56:52 +00:00
|
|
|
getResourceString :: Compiler (Item String)
|
2012-11-19 13:59:55 +00:00
|
|
|
getResourceString = getResourceWith resourceString
|
2012-11-10 17:11:46 +00:00
|
|
|
|
2011-05-06 08:28:35 +00:00
|
|
|
|
2012-11-10 17:11:46 +00:00
|
|
|
--------------------------------------------------------------------------------
|
2011-05-06 08:28:35 +00:00
|
|
|
-- | Get the resource we are compiling as a lazy bytestring
|
2012-11-18 20:56:52 +00:00
|
|
|
getResourceLBS :: Compiler (Item ByteString)
|
2012-11-19 13:59:55 +00:00
|
|
|
getResourceLBS = getResourceWith resourceLBS
|
2011-05-06 08:28:35 +00:00
|
|
|
|
2012-11-10 17:11:46 +00:00
|
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
2011-05-06 08:28:35 +00:00
|
|
|
-- | Overloadable function for 'getResourceString' and 'getResourceLBS'
|
2012-11-18 20:56:52 +00:00
|
|
|
getResourceWith :: (Provider -> Identifier -> IO a) -> Compiler (Item a)
|
2012-11-13 16:31:03 +00:00
|
|
|
getResourceWith reader = do
|
|
|
|
provider <- compilerProvider <$> compilerAsk
|
2012-11-18 20:56:52 +00:00
|
|
|
id' <- compilerUnderlying <$> compilerAsk
|
2012-11-13 16:31:03 +00:00
|
|
|
let filePath = toFilePath id'
|
|
|
|
if resourceExists provider id'
|
2012-11-18 20:56:52 +00:00
|
|
|
then compilerUnsafeIO $ Item id' <$> reader provider id'
|
2012-11-13 16:31:03 +00:00
|
|
|
else compilerThrow $ error' filePath
|
2011-01-24 12:30:23 +00:00
|
|
|
where
|
2012-11-13 16:31:03 +00:00
|
|
|
error' fp = "Hakyll.Core.Compiler.getResourceWith: resource " ++
|
|
|
|
show fp ++ " not found"
|
2011-01-18 22:58:29 +00:00
|
|
|
|
|
|
|
|
2012-11-24 09:56:19 +00:00
|
|
|
--------------------------------------------------------------------------------
|
2012-12-30 08:50:02 +00:00
|
|
|
-- | Save a snapshot of the item. This function returns the same item, which
|
|
|
|
-- convenient for building '>>=' chains.
|
2012-11-24 09:56:19 +00:00
|
|
|
saveSnapshot :: (Binary a, Typeable a)
|
2012-12-30 08:50:02 +00:00
|
|
|
=> Internal.Snapshot -> Item a -> Compiler (Item a)
|
2012-11-24 09:56:19 +00:00
|
|
|
saveSnapshot snapshot item = do
|
2013-01-13 10:35:11 +00:00
|
|
|
store <- compilerStore <$> compilerAsk
|
|
|
|
logger <- compilerLogger <$> compilerAsk
|
|
|
|
compilerUnsafeIO $ do
|
|
|
|
Logger.debug logger $ "Storing snapshot: " ++ snapshot
|
|
|
|
Internal.saveSnapshot store snapshot item
|
|
|
|
return item
|
2012-11-24 09:56:19 +00:00
|
|
|
|
|
|
|
|
2012-11-13 16:31:03 +00:00
|
|
|
--------------------------------------------------------------------------------
|
2012-11-18 20:56:52 +00:00
|
|
|
cached :: (Binary a, Typeable a)
|
2010-12-31 11:38:12 +00:00
|
|
|
=> String
|
2012-11-12 15:10:06 +00:00
|
|
|
-> Compiler a
|
|
|
|
-> Compiler a
|
2012-11-13 16:31:03 +00:00
|
|
|
cached name compiler = do
|
2012-11-18 20:56:52 +00:00
|
|
|
id' <- compilerUnderlying <$> compilerAsk
|
2012-11-13 16:31:03 +00:00
|
|
|
store <- compilerStore <$> compilerAsk
|
|
|
|
provider <- compilerProvider <$> compilerAsk
|
|
|
|
modified <- compilerUnsafeIO $ resourceModified provider id'
|
2010-12-31 11:38:12 +00:00
|
|
|
if modified
|
2012-11-13 16:31:03 +00:00
|
|
|
then do
|
|
|
|
x <- compiler
|
|
|
|
compilerUnsafeIO $ Store.set store [name, show id'] x
|
|
|
|
return x
|
|
|
|
else do
|
2012-11-14 10:17:28 +00:00
|
|
|
compilerTellCacheHits 1
|
2012-11-13 16:31:03 +00:00
|
|
|
x <- compilerUnsafeIO $ Store.get store [name, show id']
|
|
|
|
progName <- compilerUnsafeIO getProgName
|
|
|
|
case x of Store.Found x' -> return x'
|
|
|
|
_ -> compilerThrow (error' progName)
|
2010-12-31 11:38:12 +00:00
|
|
|
where
|
2012-08-30 00:36:15 +00:00
|
|
|
error' progName =
|
|
|
|
"Hakyll.Core.Compiler.cached: Cache corrupt! " ++
|
|
|
|
"Try running: " ++ progName ++ " clean"
|
2011-01-17 21:43:44 +00:00
|
|
|
|
2011-02-09 12:02:28 +00:00
|
|
|
|
2012-11-13 16:31:03 +00:00
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
unsafeCompiler :: IO a -> Compiler a
|
|
|
|
unsafeCompiler = compilerUnsafeIO
|
2011-02-26 14:49:11 +00:00
|
|
|
|
2011-02-25 13:36:34 +00:00
|
|
|
|
2012-11-13 16:31:03 +00:00
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
-- | Compiler for debugging purposes
|
2012-11-14 10:17:28 +00:00
|
|
|
debugCompiler :: String -> Compiler ()
|
|
|
|
debugCompiler msg = do
|
2012-11-13 16:31:03 +00:00
|
|
|
logger <- compilerLogger <$> compilerAsk
|
2012-11-14 10:17:28 +00:00
|
|
|
compilerUnsafeIO $ Logger.debug logger msg
|