From b37da38d3911bbc8381a39fe526e69599d9ddcf1 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 12 Apr 2011 10:09:03 +0200 Subject: [PATCH] Major refactoring of identifiers/resources/groups --- src-inotify/Hakyll/Web/Preview/Poll.hs | 3 +- src-interval/Hakyll/Web/Preview/Poll.hs | 3 +- src/Hakyll/Core/Compiler.hs | 17 ++++----- src/Hakyll/Core/Compiler/Internal.hs | 28 ++++++++------- src/Hakyll/Core/DirectedGraph/Dot.hs | 6 ++-- src/Hakyll/Core/Resource.hs | 16 +++++++-- src/Hakyll/Core/Resource/Provider.hs | 12 +++---- src/Hakyll/Core/Resource/Provider/File.hs | 9 +++-- src/Hakyll/Core/Rules.hs | 6 ++-- src/Hakyll/Core/Run.hs | 44 +++++++++++++---------- src/Hakyll/Core/Store.hs | 7 ++-- 11 files changed, 88 insertions(+), 63 deletions(-) diff --git a/src-inotify/Hakyll/Web/Preview/Poll.hs b/src-inotify/Hakyll/Web/Preview/Poll.hs index 2e028cc..0c27f32 100644 --- a/src-inotify/Hakyll/Web/Preview/Poll.hs +++ b/src-inotify/Hakyll/Web/Preview/Poll.hs @@ -14,7 +14,6 @@ import System.INotify import Hakyll.Core.Configuration import Hakyll.Core.Resource -import Hakyll.Core.Identifier -- | Calls the given callback when the directory tree changes -- @@ -27,7 +26,7 @@ previewPoll _ resources callback = do inotify <- initINotify let -- A set of file paths - paths = S.map (toFilePath . unResource) resources + paths = S.map unResource resources -- A list of directories. Run it through a set so we have every -- directory only once. diff --git a/src-interval/Hakyll/Web/Preview/Poll.hs b/src-interval/Hakyll/Web/Preview/Poll.hs index 7a11b6c..0c9f771 100644 --- a/src-interval/Hakyll/Web/Preview/Poll.hs +++ b/src-interval/Hakyll/Web/Preview/Poll.hs @@ -14,7 +14,6 @@ import qualified Data.Set as S import System.Directory (getModificationTime, doesFileExist) import Hakyll.Core.Configuration -import Hakyll.Core.Identifier import Hakyll.Core.Resource -- | A preview thread that periodically recompiles the site. @@ -24,7 +23,7 @@ previewPoll :: HakyllConfiguration -- ^ Configuration -> IO () -- ^ Action called when something changes -> IO () -- ^ Can block forever previewPoll _ resources callback = do - let files = map (toFilePath . unResource) $ S.toList resources + let files = map unResource $ S.toList resources time <- getClockTime loop files time where diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index db51131..f8e8e6f 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -138,15 +138,16 @@ import Hakyll.Core.Logger runCompiler :: Compiler () CompileRule -- ^ Compiler to run -> Identifier -- ^ Target identifier -> ResourceProvider -- ^ Resource provider + -> [Identifier] -- ^ Universe -> Routes -- ^ Route -> Store -- ^ Store -> Bool -- ^ Was the resource modified? -> Logger -- ^ Logger -> IO (Throwing CompileRule) -- ^ Resulting item -runCompiler compiler identifier provider routes store modified logger = do +runCompiler compiler id' provider universe routes store modified logger = do -- Run the compiler job - result <- - runCompilerJob compiler identifier provider routes store modified logger + result <- runCompilerJob compiler id' provider universe + routes store modified logger -- Inspect the result case result of @@ -154,7 +155,7 @@ runCompiler compiler identifier provider routes store modified logger = do -- before we return control. This makes sure the compiled item can later -- be accessed by e.g. require. Right (CompileRule (CompiledItem x)) -> - storeSet store "Hakyll.Core.Compiler.runCompiler" identifier x + storeSet store "Hakyll.Core.Compiler.runCompiler" id' x -- Otherwise, we do nothing here _ -> return () @@ -184,7 +185,7 @@ getResourceString :: Compiler Resource String getResourceString = fromJob $ \resource -> CompilerM $ do let identifier = unResource resource provider <- compilerResourceProvider <$> ask - if resourceExists provider identifier + if resourceExists provider resource then liftIO $ resourceString provider resource else throwError $ error' identifier where @@ -238,9 +239,9 @@ requireAll_ :: (Binary a, Typeable a, Writable a) -> Compiler b [a] requireAll_ pattern = fromDependencies (const getDeps) >>> fromJob requireAll_' where - getDeps = filterMatches pattern . map unResource . resourceList + getDeps = filterMatches pattern requireAll_' = const $ CompilerM $ do - deps <- getDeps . compilerResourceProvider <$> ask + deps <- getDeps . compilerUniverse <$> ask mapM (unCompilerM . getDependency) deps -- | Require a number of targets. Using this function ensures automatic handling @@ -271,7 +272,7 @@ cached name (Compiler d j) = Compiler d $ const $ CompilerM $ do modified <- compilerResourceModified <$> ask report logger $ "Checking cache: " ++ if modified then "modified" else "OK" if modified - then do v <- unCompilerM $ j $ Resource identifier + then do v <- unCompilerM $ j $ fromIdentifier identifier liftIO $ storeSet store name identifier v return v else do v <- liftIO $ storeGet store name identifier diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs index 1a3c4c3..594c23e 100644 --- a/src/Hakyll/Core/Compiler/Internal.hs +++ b/src/Hakyll/Core/Compiler/Internal.hs @@ -39,9 +39,9 @@ type Dependencies = Set Identifier -- data DependencyEnvironment = DependencyEnvironment { -- | Target identifier - dependencyIdentifier :: Identifier - , -- | Resource provider - dependencyResourceProvider :: ResourceProvider + dependencyIdentifier :: Identifier + , -- | List of available identifiers we can depend upon + dependencyUniverse :: [Identifier] } -- | Environment in which a compiler runs @@ -51,6 +51,8 @@ data CompilerEnvironment = CompilerEnvironment compilerIdentifier :: Identifier , -- | Resource provider compilerResourceProvider :: ResourceProvider + , -- | List of all known identifiers + compilerUniverse :: [Identifier] , -- | Site routes compilerRoutes :: Routes , -- | Compiler store @@ -107,17 +109,19 @@ instance ArrowChoice Compiler where runCompilerJob :: Compiler () a -- ^ Compiler to run -> Identifier -- ^ Target identifier -> ResourceProvider -- ^ Resource provider + -> [Identifier] -- ^ Universe -> Routes -- ^ Route -> Store -- ^ Store -> Bool -- ^ Was the resource modified? -> Logger -- ^ Logger -> IO (Throwing a) -- ^ Result -runCompilerJob compiler identifier provider route store modified logger = +runCompilerJob compiler id' provider universe route store modified logger = runReaderT (runErrorT $ unCompilerM $ compilerJob compiler ()) env where env = CompilerEnvironment - { compilerIdentifier = identifier + { compilerIdentifier = id' , compilerResourceProvider = provider + , compilerUniverse = universe , compilerRoutes = route , compilerStore = store , compilerResourceModified = modified @@ -126,25 +130,25 @@ runCompilerJob compiler identifier provider route store modified logger = runCompilerDependencies :: Compiler () a -> Identifier - -> ResourceProvider + -> [Identifier] -> Dependencies -runCompilerDependencies compiler identifier provider = +runCompilerDependencies compiler identifier universe = runReader (compilerDependencies compiler) env where env = DependencyEnvironment - { dependencyIdentifier = identifier - , dependencyResourceProvider = provider + { dependencyIdentifier = identifier + , dependencyUniverse = universe } fromJob :: (a -> CompilerM b) -> Compiler a b fromJob = Compiler (return S.empty) -fromDependencies :: (Identifier -> ResourceProvider -> [Identifier]) +fromDependencies :: (Identifier -> [Identifier] -> [Identifier]) -> Compiler b b fromDependencies collectDeps = flip Compiler return $ do - DependencyEnvironment identifier provider <- ask - return $ S.fromList $ collectDeps identifier provider + DependencyEnvironment identifier universe <- ask + return $ S.fromList $ collectDeps identifier universe -- | Wait until another compiler has finished before running this compiler -- diff --git a/src/Hakyll/Core/DirectedGraph/Dot.hs b/src/Hakyll/Core/DirectedGraph/Dot.hs index 8289992..58f375c 100644 --- a/src/Hakyll/Core/DirectedGraph/Dot.hs +++ b/src/Hakyll/Core/DirectedGraph/Dot.hs @@ -16,11 +16,13 @@ toDot :: Ord a -> String -- ^ Resulting string toDot showTag graph = unlines $ concat [ return "digraph dependencies {" - , concatMap showNode (S.toList $ nodes graph) + , map showNode (S.toList $ nodes graph) + , concatMap showEdges (S.toList $ nodes graph) , return "}" ] where - showNode node = map (showEdge node) $ S.toList $ neighbours node graph + showNode node = " \"" ++ showTag node ++ "\";" + showEdges node = map (showEdge node) $ S.toList $ neighbours node graph showEdge x y = " \"" ++ showTag x ++ "\" -> \"" ++ showTag y ++ "\";" -- | Write out the @.dot@ file to a given file path. See 'toDot' for more diff --git a/src/Hakyll/Core/Resource.hs b/src/Hakyll/Core/Resource.hs index d60fda9..8154752 100644 --- a/src/Hakyll/Core/Resource.hs +++ b/src/Hakyll/Core/Resource.hs @@ -2,13 +2,23 @@ -- module Hakyll.Core.Resource ( Resource (..) + , fromIdentifier + , toIdentifier ) where import Hakyll.Core.Identifier -- | A resource -- --- Invariant: the resource specified by the given identifier must exist --- -newtype Resource = Resource {unResource :: Identifier} +newtype Resource = Resource {unResource :: String} deriving (Eq, Show, Ord) + +-- | Create a resource from an identifier +-- +fromIdentifier :: Identifier -> Resource +fromIdentifier = Resource . toFilePath + +-- | Map the resource to an identifier. Note that the group will not be set! +-- +toIdentifier :: Resource -> Identifier +toIdentifier = parseIdentifier . unResource diff --git a/src/Hakyll/Core/Resource/Provider.hs b/src/Hakyll/Core/Resource/Provider.hs index 67299a6..cb70cf9 100644 --- a/src/Hakyll/Core/Resource/Provider.hs +++ b/src/Hakyll/Core/Resource/Provider.hs @@ -27,7 +27,6 @@ import qualified Data.ByteString.Lazy as LB import OpenSSL.Digest.ByteString.Lazy (digest) import OpenSSL.Digest (MessageDigest (MD5)) -import Hakyll.Core.Identifier import Hakyll.Core.Store import Hakyll.Core.Resource @@ -46,8 +45,8 @@ data ResourceProvider = ResourceProvider -- | Check if a given identifier has a resource -- -resourceExists :: ResourceProvider -> Identifier -> Bool -resourceExists provider = flip elem $ map unResource $ resourceList provider +resourceExists :: ResourceProvider -> Resource -> Bool +resourceExists provider = flip elem $ resourceList provider -- | Retrieve a digest for a given resource -- @@ -64,7 +63,7 @@ resourceModified provider store resource = do Just m -> return m -- Not yet in the cache, check digests (if it exists) Nothing -> do - m <- if resourceExists provider (unResource resource) + m <- if resourceExists provider resource then digestModified provider store resource else return False modifyMVar_ mvar (return . M.insert resource m) @@ -77,7 +76,7 @@ resourceModified provider store resource = do digestModified :: ResourceProvider -> Store -> Resource -> IO Bool digestModified provider store resource = do -- Get the latest seen digest from the store - lastDigest <- storeGet store itemName $ unResource resource + lastDigest <- storeGet store itemName identifier -- Calculate the digest for the resource newDigest <- resourceDigest provider resource -- Check digests @@ -85,7 +84,8 @@ digestModified provider store resource = do -- All is fine, not modified then return False -- Resource modified; store new digest - else do storeSet store itemName (unResource resource) newDigest + else do storeSet store itemName identifier newDigest return True where + identifier = toIdentifier resource itemName = "Hakyll.Core.ResourceProvider.digestModified" diff --git a/src/Hakyll/Core/Resource/Provider/File.hs b/src/Hakyll/Core/Resource/Provider/File.hs index 953d61c..5383b51 100644 --- a/src/Hakyll/Core/Resource/Provider/File.hs +++ b/src/Hakyll/Core/Resource/Provider/File.hs @@ -12,7 +12,6 @@ import qualified Data.ByteString.Lazy as LB import Hakyll.Core.Resource import Hakyll.Core.Resource.Provider -import Hakyll.Core.Identifier import Hakyll.Core.Util.File import Hakyll.Core.Configuration @@ -20,8 +19,8 @@ import Hakyll.Core.Configuration -- fileResourceProvider :: HakyllConfiguration -> IO ResourceProvider fileResourceProvider configuration = do - -- Retrieve a list of identifiers - list <- map parseIdentifier . filter (not . ignoreFile configuration) <$> + -- Retrieve a list of paths + list <- filter (not . ignoreFile configuration) <$> getRecursiveContents False "." -- MVar for the cache @@ -30,7 +29,7 @@ fileResourceProvider configuration = do -- Construct a resource provider return ResourceProvider { resourceList = map Resource list - , resourceString = readFile . toFilePath . unResource - , resourceLazyByteString = LB.readFile . toFilePath . unResource + , resourceString = readFile . unResource + , resourceLazyByteString = LB.readFile . unResource , resourceModifiedCache = mvar } diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs index 9f88b82..93f5028 100644 --- a/src/Hakyll/Core/Rules.hs +++ b/src/Hakyll/Core/Rules.hs @@ -102,11 +102,11 @@ compile :: (Binary a, Typeable a, Writable a) compile compiler = RulesM $ do pattern <- rulesPattern <$> ask provider <- rulesResourceProvider <$> ask - let ids = filterMatches pattern $ map unResource $ resourceList provider + let ids = filterMatches pattern $ map toIdentifier $ resourceList provider unRulesM $ do tellCompilers $ flip map ids $ \identifier -> - (identifier, constA (Resource identifier) >>> compiler) - tellResources $ map Resource ids + (identifier, constA (fromIdentifier identifier) >>> compiler) + tellResources $ map fromIdentifier ids -- | Add a compilation rule -- diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index af2ad22..d9d1cf7 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -64,6 +64,9 @@ run configuration rules = do , hakyllStore = store } + -- DEBUG + report logger $ "Compilers: " ++ show (map fst compilers) + -- Run the program and fetch the resulting state ((), state') <- runStateT stateT $ RuntimeState { hakyllAnalyzer = makeDependencyAnalyzer mempty (const False) oldGraph @@ -118,39 +121,43 @@ addNewCompilers newCompilers = Runtime $ do provider <- hakyllResourceProvider <$> ask store <- hakyllStore <$> ask + -- DEBUG + report logger $ "Adding: " ++ show (map fst newCompilers) + -- Old state information oldCompilers <- hakyllCompilers <$> get oldAnalyzer <- hakyllAnalyzer <$> get - let -- Create a new partial dependency graph + let -- All known compilers + universe = M.keys oldCompilers ++ map fst newCompilers + + -- Create a new partial dependency graph dependencies = flip map newCompilers $ \(id', compiler) -> - let deps = runCompilerDependencies compiler id' provider + let deps = runCompilerDependencies compiler id' universe in (id', deps) -- Create the dependency graph newGraph = fromList dependencies + -- DEBUG + report logger $ "Dependencies: " ++ show dependencies + liftIO $ writeFile "newGraph.dot" $ toDot show newGraph + + -- Check which items have been modified - modified <- fmap S.fromList $ flip filterM (map fst newCompilers) $ - liftIO . resourceModified provider store . Resource - -- newModified <- liftIO $ modified provider store $ map fst newCompilers + modified <- fmap S.fromList $ flip filterM (map fst newCompilers) $ \id' -> do + m <- liftIO $ resourceModified provider store $ fromIdentifier id' + liftIO $ putStrLn $ show id' ++ " " ++ show m + return m + + -- DEBUG + report logger $ "Modified: " ++ show modified -- Create a new analyzer and append it to the currect one let newAnalyzer = makeDependencyAnalyzer newGraph (`S.member` modified) $ analyzerPreviousGraph oldAnalyzer analyzer = mappend oldAnalyzer newAnalyzer - -- Debugging - liftIO $ putStrLn $ "Remains: " ++ show (analyzerRemains newAnalyzer) - liftIO $ putStrLn $ "Done: " ++ show (analyzerDone newAnalyzer) - liftIO $ writeFile "old-prev.dot" $ toDot show (analyzerPreviousGraph oldAnalyzer) - liftIO $ writeFile "old.dot" $ toDot show (analyzerGraph oldAnalyzer) - liftIO $ writeFile "old-prev.dot" $ toDot show (analyzerPreviousGraph oldAnalyzer) - liftIO $ writeFile "new.dot" $ toDot show (analyzerGraph newAnalyzer) - liftIO $ writeFile "new-prev.dot" $ toDot show (analyzerPreviousGraph newAnalyzer) - liftIO $ writeFile "result.dot" $ toDot show (analyzerGraph analyzer) - liftIO $ writeFile "result-prev.dot" $ toDot show (analyzerPreviousGraph analyzer) - -- Update the state put $ RuntimeState { hakyllAnalyzer = analyzer @@ -185,11 +192,12 @@ build id' = Runtime $ do let compiler = compilers M.! id' -- Check if the resource was modified - isModified <- liftIO $ resourceModified provider store (Resource id') + isModified <- liftIO $ resourceModified provider store $ fromIdentifier id' -- Run the compiler result <- timed logger "Total compile time" $ liftIO $ - runCompiler compiler id' provider routes store isModified logger + runCompiler compiler id' provider (M.keys compilers) routes + store isModified logger case result of -- Compile rule for one item, easy stuff diff --git a/src/Hakyll/Core/Store.hs b/src/Hakyll/Core/Store.hs index be1b4a7..e0d6774 100644 --- a/src/Hakyll/Core/Store.hs +++ b/src/Hakyll/Core/Store.hs @@ -11,6 +11,7 @@ module Hakyll.Core.Store import Control.Concurrent.MVar (MVar, newMVar, readMVar, modifyMVar_) import System.FilePath (()) import System.Directory (doesFileExist) +import Data.Maybe (fromMaybe) import Data.Map (Map) import qualified Data.Map as M @@ -52,8 +53,10 @@ addToMap store path value = -- | Create a path -- makePath :: Store -> String -> Identifier -> FilePath -makePath store name identifier = - storeDirectory store name toFilePath identifier "hakyllstore" +makePath store name identifier = storeDirectory store name + group toFilePath identifier "hakyllstore" + where + group = fromMaybe "" $ identifierGroup identifier -- | Store an item --