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