Work on correctly avoiding doing early work if later IO work does not need it

Not at all there
This commit is contained in:
Niels G. W. Serup 2024-11-07 23:20:28 +01:00
parent 5862fe32bc
commit 0f0bde5f18
No known key found for this signature in database
GPG Key ID: 38EEEBCE67324F19
10 changed files with 238 additions and 80 deletions

View File

@ -43,6 +43,7 @@ library
, containers
, text
, directory
, time
, blaze-html
, pandoc-types
, pandoc

View File

@ -3,7 +3,7 @@ pkgs.haskell.lib.overrideCabal
(haskell.callCabal2nix "byg" ./. { })
(_: {
configureFlags = [
"--ghc-option=-Werror"
# "--ghc-option=-Werror"
"--ghc-option=-O2"
];
doHaddock = false;

View File

@ -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
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
fromValue <$> getTokenValue innerOutput
where calcM :: (Typeable a, Typeable b, Show b) => (a -> DepRunM b) -> DepRunM Value
calcM f = toValue <$> (f $ fromValueRep (actionSourceType action) input)
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)

View File

@ -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 ()

View File

@ -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 ()

View File

@ -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 ()

View File

@ -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
_ ->

View File

@ -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

View File

@ -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]

2
om.md
View File

@ -25,7 +25,7 @@ Klik på [Feed](/atom.xml)-fanen i toppen af siden for at tilgå et Atom-feed me
## Licens
<p xmlns:cc="http://creativecommons.org/ns#" xmlns:dct="http://purl.org/dc/terms/"><span property="dct:title">Niels' mad</span> by <span property="cc:attributionName">Niels G. W. Serup</span> er licenseret under <a href="https://creativecommons.org/licenses/by-sa/4.0/?ref=chooser-v1" target="_blank" rel="license noopener noreferrer" style="display:inline-block;">CC BY-SA 4.0<img style="height:22px!important;margin-left:3px;vertical-align:text-bottom;" src="https://mirrors.creativecommons.org/presskit/icons/cc.svg?ref=chooser-v1" alt=""><img style="height:22px!important;margin-left:3px;vertical-align:text-bottom;" src="https://mirrors.creativecommons.org/presskit/icons/by.svg?ref=chooser-v1" alt=""><img style="height:22px!important;margin-left:3px;vertical-align:text-bottom;" src="https://mirrors.creativecommons.org/presskit/icons/sa.svg?ref=chooser-v1" alt=""></a></p>
<p xmlns:cc="http://creativecommons.org/ns#" xmlns:dct="http://purl.org/dc/terms/"><span property="dct:title">Niels' mad</span> af <span property="cc:attributionName">Niels G. W. Serup</span> er licenseret under <a href="https://creativecommons.org/licenses/by-sa/4.0/?ref=chooser-v1" target="_blank" rel="license noopener noreferrer" style="display:inline-block;">CC BY-SA 4.0<img style="height:22px!important;margin-left:3px;vertical-align:text-bottom;" src="https://mirrors.creativecommons.org/presskit/icons/cc.svg?ref=chooser-v1" alt=""><img style="height:22px!important;margin-left:3px;vertical-align:text-bottom;" src="https://mirrors.creativecommons.org/presskit/icons/by.svg?ref=chooser-v1" alt=""><img style="height:22px!important;margin-left:3px;vertical-align:text-bottom;" src="https://mirrors.creativecommons.org/presskit/icons/sa.svg?ref=chooser-v1" alt=""></a></p>
## Hjemmesidegenerator