From 0f0bde5f18385631a99615ed6fdf8666038a101f Mon Sep 17 00:00:00 2001 From: "Niels G. W. Serup" Date: Thu, 7 Nov 2024 23:20:28 +0100 Subject: [PATCH] Work on correctly avoiding doing early work if later IO work does not need it Not at all there --- byg/byg.cabal | 1 + byg/default.nix | 2 +- byg/src/DependencyRunner.hs | 264 ++++++++++++++++++++++++++++-------- byg/src/Functions/Image.hs | 7 +- byg/src/Functions/Paths.hs | 23 +++- byg/src/Functions/Text.hs | 7 +- byg/src/Main.hs | 5 +- byg/src/Types/Dependency.hs | 4 +- byg/src/Types/Functions.hs | 3 +- om.md | 2 +- 10 files changed, 238 insertions(+), 80 deletions(-) diff --git a/byg/byg.cabal b/byg/byg.cabal index 0894901..4975890 100644 --- a/byg/byg.cabal +++ b/byg/byg.cabal @@ -43,6 +43,7 @@ library , containers , text , directory + , time , blaze-html , pandoc-types , pandoc diff --git a/byg/default.nix b/byg/default.nix index 9f5650a..4917cbe 100644 --- a/byg/default.nix +++ b/byg/default.nix @@ -3,7 +3,7 @@ pkgs.haskell.lib.overrideCabal (haskell.callCabal2nix "byg" ./. { }) (_: { configureFlags = [ - "--ghc-option=-Werror" + # "--ghc-option=-Werror" "--ghc-option=-O2" ]; doHaddock = false; diff --git a/byg/src/DependencyRunner.hs b/byg/src/DependencyRunner.hs index ff8fd38..f783eaa 100644 --- a/byg/src/DependencyRunner.hs +++ b/byg/src/DependencyRunner.hs @@ -3,9 +3,11 @@ module DependencyRunner ( DepRunM , runDeps , runDepRunMIO + , extractSndToken + , extractSndTokenAsList ) where -import Types (evalFunctionIO) +import Types (evalFunctionIO, functionIOReads, functionIOWrites) import Types.Value import Types.Token import Types.Dependency @@ -13,65 +15,149 @@ import Types.Dependency import Type.Reflection (Typeable) import Data.Map (Map) import qualified Data.Map as M -import Control.Monad (void, forM) +import Data.Maybe (catMaybes) +import Control.Monad (void, forM, filterM) import Control.Monad.State (MonadState, MonadIO, StateT, evalStateT, get, modify, liftIO) +import Control.Monad.Writer (MonadWriter, WriterT, runWriterT, tell) +import System.Directory (getModificationTime) +import Data.Time.Clock (UTCTime(..)) +import qualified System.Directory as SD -data ValueExistence = Evaluated Value - | NotEvaluated (DepRunM Value) +data LastUpdated = Never + | NeverDebug String + | NeverInput + | At UTCTime + deriving (Show, Eq, Ord) -newtype DepRunM a = DepRunM { unDepRunM :: StateT (Map Int ValueExistence) IO a } - deriving (Functor, Applicative, Monad, MonadIO, MonadState (Map Int ValueExistence)) +data ValueExistence = Evaluated Value LastUpdated + | NotEvaluated (LastUpdated -> DepRunM (Maybe (Value, LastUpdated))) + +newtype DepRunM a = DepRunM { unDepRunM :: WriterT [FilePath] (StateT (Map Int ValueExistence) IO) a } + deriving (Functor, Applicative, Monad, MonadIO, + MonadState (Map Int ValueExistence), + MonadWriter [FilePath]) runDeps :: [Dependency] -> DepRunM () runDeps = mapM_ runDep -runDepRunMIO :: DepRunM a -> IO a -runDepRunMIO m = evalStateT (unDepRunM m) M.empty +runDepRunMIO :: DepRunM a -> IO (a, [FilePath]) +runDepRunMIO m = evalStateT (runWriterT (unDepRunM m)) M.empty -evaluate :: ValueExistence -> DepRunM Value -evaluate = \case - Evaluated v -> pure v - NotEvaluated m -> m +evaluate :: LastUpdated -> ValueExistence -> DepRunM (Maybe (Value, LastUpdated)) +evaluate luFuture = \case + Evaluated v lu -> pure (Just (v, lu)) + NotEvaluated m -> m luFuture runDep :: Dependency -> DepRunM () runDep (Dependency _ a action _ b) = if actionWritesAny action - then void m + then void (m Never) else putTokenValue b $ NotEvaluated m - where m :: DepRunM Value - m = do - input <- getTokenValue a - result <- runAction action input - putTokenValue b $ Evaluated result - liftIO $ do - putStrLn ("input: " ++ show input) - putStrLn ("action: " ++ show action) - putStrLn ("output: " ++ show result) - putStrLn "----------" - pure result + where m :: LastUpdated -> DepRunM (Maybe (Value, LastUpdated)) + m luFuture = do + m <- runAction action a luFuture + case m of + Just (result, luResult) -> do + putTokenValue b $ Evaluated result luResult + pure $ Just (result, luResult) + Nothing -> + pure Nothing -getTokenValueByIndex :: Int -> DepRunM Value -getTokenValueByIndex i = do +extractSndToken :: Token (a, b) -> Token b +extractSndToken = \case + TupleToken _ b -> + b + _ -> + error "unsupported" + +extractSndTokenAsList :: (Show b, Typeable b) => Token (a, b) -> Token [b] +extractSndTokenAsList = ListToken . (: []) . extractSndToken + +getTokenValueByIndex :: LastUpdated -> Int -> DepRunM (Maybe (Value, LastUpdated)) +getTokenValueByIndex luFuture i = do m <- get - evaluate (m M.! i) + case m M.!? i of + Nothing -> pure Nothing + Just x -> evaluate luFuture x + +minimumOrNever :: [LastUpdated] -> LastUpdated +minimumOrNever = \case + [] -> Never + times -> minimum times + +maximumOrNever :: [LastUpdated] -> LastUpdated +maximumOrNever = \case + [] -> Never + times -> maximum times + +maximumOrNever' :: [UTCTime] -> LastUpdated +maximumOrNever' = maximumOrNever . map At + +getTokenValueRaw :: LastUpdated -> Token a -> DepRunM (Maybe (a, LastUpdated)) +getTokenValueRaw luFuture token = case token of + Token i -> do + m <- getTokenValueByIndex luFuture i + pure $ do (a, lu) <- m + pure (fromValue a, lu) -getTokenValueRaw :: Token a -> DepRunM a -getTokenValueRaw token = case token of - Token i -> - fromValue <$> getTokenValueByIndex i TupleToken a b -> do - (,) <$> getTokenValueRaw a <*> getTokenValueRaw b - ZipToken a b -> do - zip <$> getTokenValueRaw a <*> getTokenValueRaw b - ListToken ts -> do - mapM getTokenValueRaw ts - NoToken -> - pure () + m0 <- getTokenValueRaw luFuture a + m1 <- getTokenValueRaw luFuture b + case (m0, m1) of + (Just (a', luA), Just (b', luB)) -> + pure $ Just ((a', b'), max luA luB) + (Just (a', luA), Nothing) -> do -- | luA /= NeverInput -> do + r <- getTokenValueRaw (NeverDebug (show (a', luA))) b + pure $ case r of + Nothing -> error ("unexpected " ++ show b ++ " (" ++ show (a', luA) ++ ")") + Just (b', luB) -> Just ((a', b'), max luA luB) + (Nothing, Just (b', luB)) -> do -- | luB /= NeverInput -> do + r <- getTokenValueRaw (NeverDebug (show (b', luB))) a + pure $ case r of + Nothing -> error "unexpected" + Just (a', luA) -> Just ((a', b'), max luA luB) + _ -> + pure $ Nothing -getTokenValue :: Token a -> DepRunM Value -getTokenValue token = case token of + ZipToken a b -> do + m0 <- getTokenValueRaw luFuture a + m1 <- getTokenValueRaw luFuture b + case (m0, m1) of + (Just (a', luA), Just (b', luB)) -> + pure $ Just (zip a' b', max luA luB) + (Just (a', luA), Nothing) -> do -- | luA /= NeverInput -> do + r <- getTokenValueRaw Never b + pure $ case r of + Nothing -> error "unexpected" + Just (b', luB) -> Just (zip a' b', max luA luB) + (Nothing, Just (b', luB)) -> do -- | luB /= NeverInput -> do + r <- getTokenValueRaw Never a + pure $ case r of + Nothing -> error "unexpected" + Just (a', luA) -> Just (zip a' b', max luA luB) + _ -> + pure $ Nothing + + ListToken ts -> do + ms <- mapM (getTokenValueRaw luFuture) ts + if False -- null $ filter ((/= NeverInput) . snd) (catMaybes ms) + then pure Nothing + else do ms' <- case sequence ms of + Just x -> pure x + Nothing -> do r <- mapM (getTokenValueRaw Never) ts + case sequence r of + Nothing -> error "unexpected" + Just x -> pure x + let (as, lus) = unzip ms' + pure $ Just (as, maximumOrNever lus) + + NoToken -> + pure $ Just ((), Never) + +getTokenValue :: Token a -> LastUpdated -> DepRunM (Maybe (Value, LastUpdated)) +getTokenValue token luFuture = case token of Token i -> - getTokenValueByIndex i + getTokenValueByIndex luFuture i TupleToken _ _ -> fromRaw token ZipToken _ _ -> @@ -80,26 +166,70 @@ getTokenValue token = case token of fromRaw token NoToken -> fromRaw token - where fromRaw :: (Typeable a, Show a) => Token a -> DepRunM Value - fromRaw = fmap toValue . getTokenValueRaw + where fromRaw :: (Typeable a, Show a) => Token a -> DepRunM (Maybe (Value, LastUpdated)) + fromRaw t = do + m <- getTokenValueRaw luFuture t + pure $ do (x, lu) <- m + pure (toValue x, lu) putTokenValue :: Token a -> ValueExistence -> DepRunM () -putTokenValue t e = case t of +putTokenValue t v = case t of Token i -> - modify $ M.insert i e + modify $ M.insert i v NoToken -> pure () _ -> error "unexpected" -runAction :: forall a b. Action a b -> Value -> DepRunM Value -runAction action input = case action of +maximumModTime :: [FilePath] -> DepRunM LastUpdated +maximumModTime paths = do + paths' <- filterM (liftIO . SD.doesPathExist) paths + times <- mapM (liftIO . getModificationTime) paths' + pure $ maximumOrNever' times + +runAction :: forall a b. Action a b -> Token a -> LastUpdated + -> DepRunM (Maybe (Value, LastUpdated)) +runAction action tokenInput luFuture = case action of Function (F f) -> calc f - FunctionIO f -> - calcM (liftIO . evalFunctionIO f) + FunctionIO f -> do + m <- getTokenValueRaw luFuture $ functionIOWrites f tokenInput + case m of + Nothing -> + pure Nothing -- error "unexpected" -- wrong? + Just (writes, _writesLu) -> do + tell writes + lastWritten <- max luFuture <$> maximumModTime writes + result <- getTokenValue tokenInput lastWritten + case result of + Just (inputValue, luInput) -> do + let input = inputFromValue inputValue + lastUpdated <- max luInput <$> (maximumModTime $ functionIOReads f input) + if lastUpdated > lastWritten + then do liftIO $ do + putStrLn ("input: " ++ show input) + putStrLn ("input last updated: " ++ show luInput) + putStrLn ("IO function: " ++ show f) + putStrLn ("Source timestamp: " ++ show lastUpdated) + putStrLn ("Target timestamp: " ++ show lastWritten) + v <- toValue <$> (liftIO $ evalFunctionIO f input) + -- tell writes + let luResult = max luInput lastUpdated + liftIO $ do + putStrLn ("output: " ++ show v) + putStrLn ("output last updated: " ++ show luResult) + putStrLn "----------" + pure $ Just (v, luResult) + else do -- liftIO $ putStrLn ("Source timestamp " + -- ++ show lastUpdated + -- ++ " not newer than target timestamp " + -- ++ show lastWritten + -- ++ "; ignoring IO computation.") + pure Nothing -- (toValue (), lastWritten) -- assumes writing FunctionIO always return () + Nothing -> + pure Nothing Inject x -> - pure $ toValue x + pure $ Just (toValue x, NeverInput) FilterComp -> calc (\(vs, mask) -> map fst $ filter snd $ zip vs mask) UntupleFst -> @@ -110,14 +240,28 @@ runAction action input = case action of calc (map fst) UnzipSnd -> calc (map snd) - MapComp subDeps innerInput innerOutput -> - (toValueRep (actionTargetType action) <$>) - $ forM (fromValueRep (actionSourceType action) input) $ \x -> do - putTokenValue innerInput $ Evaluated $ toValue x - runDeps subDeps - fromValue <$> getTokenValue innerOutput - where calcM :: (Typeable a, Typeable b, Show b) => (a -> DepRunM b) -> DepRunM Value - calcM f = toValue <$> (f $ fromValueRep (actionSourceType action) input) + MapComp subDeps innerInput innerOutput -> do + m <- getTokenValue tokenInput luFuture + case m of + Nothing -> pure Nothing + Just (inputValue, luInput) -> do + let input = inputFromValue inputValue + lastUpdated <- maximumModTime $ actionReads action input + result <- forM input $ \x -> do + putTokenValue innerInput $ Evaluated (toValue x) (max luInput lastUpdated) + runDeps subDeps + m <- getTokenValue innerOutput luFuture + pure $ do (vOut, luOut) <- m + pure (fromValue vOut, luOut) + pure $ do result' <- sequence result + let (values, lus) = unzip result' + pure $ (toValueRep (actionTargetType action) values, maximumOrNever lus) + where inputFromValue :: Typeable a => Value -> a + inputFromValue = fromValueRep (actionSourceType action) - calc :: (Typeable a, Typeable b, Show b) => (a -> b) -> DepRunM Value - calc f = calcM (pure . f) + calc :: (Typeable a, Typeable b, Show b) => (a -> b) -> DepRunM (Maybe (Value, LastUpdated)) + calc f = do + m <- getTokenValue tokenInput luFuture + pure $ do (inputValue, luInput) <- m + let input = inputFromValue inputValue + pure (toValue $ f input, luInput) diff --git a/byg/src/Functions/Image.hs b/byg/src/Functions/Image.hs index b385a3a..6f6a017 100644 --- a/byg/src/Functions/Image.hs +++ b/byg/src/Functions/Image.hs @@ -6,9 +6,10 @@ module Functions.Image , convertImage ) where -import Types (IsFunctionIO(..), Token) +import Types (IsFunctionIO(..), Token(..)) import DependencyGenerator (DepGenM, TokenableTo(..), onTupleToken, toTupleToken, runFunctionIO, runFunctionIO_) +import DependencyRunner (extractSndTokenAsList) import qualified Codec.Picture as CP import qualified Codec.Picture.STBIR as CPS @@ -31,7 +32,7 @@ instance IsFunctionIO OpenImage FilePath Image where Left e -> error ("unexpected error: " ++ e) Right image -> pure $ ImageWrapper $ CP.convertRGB8 image functionIOReads OpenImage s = [s] - functionIOWrites OpenImage = const [] + functionIOWrites OpenImage = const (ListToken []) functionIOWritesAny OpenImage = False openImage :: TokenableTo FilePath a => a -> DepGenM (Token Image) @@ -43,7 +44,7 @@ instance IsFunctionIO SaveImage (Image, FilePath) () where evalFunctionIO SaveImage (ImageWrapper image, s) = CP.saveJpgImage 90 s $ CP.ImageRGB8 image functionIOReads SaveImage = const [] - functionIOWrites SaveImage (_, s) = [s] + functionIOWrites SaveImage = extractSndTokenAsList functionIOWritesAny SaveImage = True saveImage :: (TokenableTo Image a, TokenableTo FilePath b) => a -> b -> DepGenM () diff --git a/byg/src/Functions/Paths.hs b/byg/src/Functions/Paths.hs index b5e0d7b..d679b9b 100644 --- a/byg/src/Functions/Paths.hs +++ b/byg/src/Functions/Paths.hs @@ -12,8 +12,10 @@ module Functions.Paths import Types (IsFunctionIO(..), Token(..)) import DependencyGenerator (DepGenM, TokenableTo(..), onToken, onTupleToken, toTupleToken, runFunctionIO, runFunctionIO_, untupleSndDepGenM) +import DependencyRunner (extractSndTokenAsList) import Data.Char (toLower) +import Control.Monad (when) import qualified System.Directory as SD joinPaths :: (TokenableTo FilePath a, TokenableTo FilePath b) => a -> b -> DepGenM (Token FilePath) @@ -37,8 +39,8 @@ data ListDirectory = ListDirectory deriving Show instance IsFunctionIO ListDirectory FilePath [FilePath] where evalFunctionIO ListDirectory s = SD.listDirectory s functionIOReads ListDirectory s = [s] - functionIOWrites ListDirectory = const [] - functionIOWritesAny ListDirectory = False + functionIOWrites ListDirectory = const (ListToken []) + functionIOWritesAny ListDirectory = False -- old: force triggering listDirectory :: TokenableTo FilePath a => a -> DepGenM (Token [FilePath]) listDirectory a = runFunctionIO ListDirectory =<< toToken a @@ -48,7 +50,7 @@ data IsDirectory = IsDirectory deriving Show instance IsFunctionIO IsDirectory FilePath Bool where evalFunctionIO IsDirectory s = SD.doesDirectoryExist s functionIOReads IsDirectory s = [s] - functionIOWrites IsDirectory = const [] + functionIOWrites IsDirectory = const (ListToken []) functionIOWritesAny IsDirectory = False isDirectory :: TokenableTo FilePath a => a -> DepGenM (Token Bool) @@ -57,10 +59,17 @@ isDirectory a = runFunctionIO IsDirectory =<< toToken a data MakeDir = MakeDir deriving Show instance IsFunctionIO MakeDir FilePath () where - evalFunctionIO MakeDir s = - SD.createDirectory s + evalFunctionIO MakeDir s = do + exists <- SD.doesPathExist s + when (not exists) $ SD.createDirectory s functionIOReads MakeDir = const [] - functionIOWrites MakeDir s = [s] + functionIOWrites MakeDir s = ListToken [s] + + + -- Old: Don't consider a created + -- directory "written", as there is + -- no extra information than its name + -- and presence. functionIOWritesAny MakeDir = True makeDir :: TokenableTo FilePath a => a -> DepGenM () @@ -72,7 +81,7 @@ instance IsFunctionIO CopyFile (FilePath, FilePath) () where evalFunctionIO CopyFile (source, target) = SD.copyFile source target functionIOReads CopyFile (i, _) = [i] - functionIOWrites CopyFile (_, o) = [o] + functionIOWrites CopyFile = extractSndTokenAsList functionIOWritesAny CopyFile = True copyFile :: (TokenableTo FilePath a, TokenableTo FilePath b) => a -> b -> DepGenM () diff --git a/byg/src/Functions/Text.hs b/byg/src/Functions/Text.hs index 1a14952..7e37d11 100644 --- a/byg/src/Functions/Text.hs +++ b/byg/src/Functions/Text.hs @@ -3,9 +3,10 @@ module Functions.Text , saveTextFile ) where -import Types (IsFunctionIO(..), Token) +import Types (IsFunctionIO(..), Token(..)) import DependencyGenerator (DepGenM, TokenableTo(..), toTupleToken, runFunctionIO, runFunctionIO_) +import DependencyRunner (extractSndTokenAsList) import Data.Text (Text) import qualified Data.Text.IO as T @@ -14,7 +15,7 @@ data ReadTextFile = ReadTextFile deriving Show instance IsFunctionIO ReadTextFile FilePath Text where evalFunctionIO ReadTextFile s = T.readFile s functionIOReads ReadTextFile s = [s] - functionIOWrites ReadTextFile = const [] + functionIOWrites ReadTextFile = const (ListToken []) functionIOWritesAny ReadTextFile = False readTextFile :: TokenableTo FilePath a => a -> DepGenM (Token Text) @@ -25,7 +26,7 @@ data SaveTextFile = SaveTextFile deriving Show instance IsFunctionIO SaveTextFile (Text, FilePath) () where evalFunctionIO SaveTextFile (t, s) = T.writeFile s t functionIOReads SaveTextFile = const [] - functionIOWrites SaveTextFile (_, s) = [s] + functionIOWrites SaveTextFile = extractSndTokenAsList functionIOWritesAny SaveTextFile = True saveTextFile :: (TokenableTo Text a, TokenableTo FilePath b) => a -> b -> DepGenM () diff --git a/byg/src/Main.hs b/byg/src/Main.hs index 470272a..5d3ba15 100644 --- a/byg/src/Main.hs +++ b/byg/src/Main.hs @@ -16,8 +16,9 @@ main :: IO () main = do args <- getArgs case args of - ["run"] -> - DR.runDepRunMIO $ DR.runDeps dependencies + ["run"] -> do + ((), filesWritten) <- DR.runDepRunMIO $ DR.runDeps dependencies + putStrLn ("Files which could have been written: " ++ show filesWritten) ["tree"] -> T.putStr $ D.formatDependencyTrees dependencies _ -> diff --git a/byg/src/Types/Dependency.hs b/byg/src/Types/Dependency.hs index 6c9312a..e2401ba 100644 --- a/byg/src/Types/Dependency.hs +++ b/byg/src/Types/Dependency.hs @@ -56,10 +56,10 @@ actionReads = \case FunctionIO f -> functionIOReads f _ -> const [] -actionWrites :: Action a b -> a -> [FilePath] +actionWrites :: Action a b -> Token a -> Token [FilePath] actionWrites = \case FunctionIO f -> functionIOWrites f - _ -> const [] + _ -> const (ListToken []) actionWritesAny :: Action a b -> Bool actionWritesAny = \case diff --git a/byg/src/Types/Functions.hs b/byg/src/Types/Functions.hs index b7ca208..6f3240c 100644 --- a/byg/src/Types/Functions.hs +++ b/byg/src/Types/Functions.hs @@ -3,10 +3,11 @@ module Types.Functions ( IsFunctionIO(..) ) where +import Types.Token (Token) import Type.Reflection (Typeable) class (Show f, Show a, Typeable a, Show b, Typeable b) => IsFunctionIO f a b | f -> a b where evalFunctionIO :: f -> a -> IO b functionIOReads :: f -> a -> [FilePath] functionIOWritesAny :: f -> Bool - functionIOWrites :: f -> a -> [FilePath] + functionIOWrites :: f -> Token a -> Token [FilePath] diff --git a/om.md b/om.md index d387c5b..9454f3e 100644 --- a/om.md +++ b/om.md @@ -25,7 +25,7 @@ Klik på [Feed](/atom.xml)-fanen i toppen af siden for at tilgå et Atom-feed me ## Licens -

Niels' mad by Niels G. W. Serup er licenseret under CC BY-SA 4.0

+

Niels' mad af Niels G. W. Serup er licenseret under CC BY-SA 4.0

## Hjemmesidegenerator