achille (empty) → 0.0.0
raw patch · 14 files changed
+1230/−0 lines, 14 filesdep +Globdep +achilledep +aesonsetup-changed
Dependencies added: Glob, achille, aeson, base, binary, binary-instances, bytestring, containers, data-default, directory, filepath, frontmatter, mtl, optparse-applicative, pandoc, pandoc-types, process, tasty, tasty-hunit, text, time
Files
- LICENSE +22/−0
- Setup.hs +2/−0
- achille.cabal +80/−0
- src/Achille.hs +59/−0
- src/Achille/Config.hs +30/−0
- src/Achille/Internal.hs +151/−0
- src/Achille/Internal/IO.hs +81/−0
- src/Achille/Recipe.hs +155/−0
- src/Achille/Recipe/Pandoc.hs +105/−0
- src/Achille/Task.hs +224/−0
- src/Achille/Timestamped.hs +71/−0
- src/Achille/Writable.hs +37/−0
- tests/FakeIO.hs +154/−0
- tests/Main.hs +59/−0
+ LICENSE view
@@ -0,0 +1,22 @@+MIT License++Copyright (c) 2020 Lucas Escot++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ achille.cabal view
@@ -0,0 +1,80 @@+name: achille+version: 0.0.0+synopsis: A library for building static site generators+category: Web+description:+ achille is a library for building incremental static site generators.+ For more information, see here: <https://acatalepsie.fr/projects/achille>.++bug-reports: https://github.com/flupe/achille/issues+homepage: https://acatalepsie.fr/projects/achille+author: Lucas Escot <lucas@escot.me>+maintainer: Lucas Escot <lucas@escot.me>+license: MIT+license-file: LICENSE+cabal-version: >= 1.10+build-type: Simple+tested-with: GHC == 8.8.4++source-repository head+ type: git+ location: git://github.com/flupe/achille.git++flag pandoc+ description: Enable Pandoc and Front Matter header support+ default: True++library+ default-language: Haskell2010+ hs-source-dirs: src+ default-extensions: BlockArguments+ , LambdaCase+ , TupleSections+ , CPP+ exposed-modules: Achille+ , Achille.Config+ , Achille.Writable+ , Achille.Timestamped+ , Achille.Internal+ , Achille.Internal.IO+ , Achille.Recipe+ , Achille.Task+ build-depends: base >= 4.11 && < 5+ , process >= 1.6.9 && < 1.7+ , filepath >= 1.4.2 && < 1.5+ , directory >= 1.3.6 && < 1.4+ , Glob >= 0.10.1 && < 0.11+ , binary >= 0.8.7 && < 0.9+ , bytestring >= 0.10.10 && < 0.11+ , text >= 1.2.4 && < 1.3+ , time >= 1.9.3 && < 1.10+ , data-default >= 0.7.1 && < 0.8+ , optparse-applicative >= 0.15.1 && < 0.16+ , binary-instances >= 1.0.0 && < 1.1+++ if flag(pandoc)+ exposed-modules: Achille.Recipe.Pandoc+ build-depends: pandoc >= 2.9.2 && < 2.10+ , pandoc-types >= 1.20 && < 1.21+ , frontmatter >= 0.1.0 && < 0.2+ , aeson >= 1.4.7 && < 1.5++test-suite test-achille+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules: FakeIO+ hs-source-dirs: tests+ build-depends: base >= 4.11 && < 5+ , directory+ , text+ , containers+ , filepath+ , bytestring+ , Glob+ , tasty+ , tasty-hunit+ , time+ , mtl+ , achille
+ src/Achille.hs view
@@ -0,0 +1,59 @@+-- | Top-level module for achille, providing the CLI and task runner.+module Achille+ ( module Achille.Config+ , module Achille.Timestamped+ , module Achille.Recipe+ , module Achille.Task+ , AchilleCommand+ , achilleCLI+ , achille+ , achilleWith+ ) where+++import Control.Monad (void, mapM_)+import Control.Monad.IO.Class (MonadIO)+import System.Directory (removePathForcibly)+import System.FilePath.Glob (compile)+import Options.Applicative++import qualified System.Process as Process++import Achille.Config+import Achille.Timestamped+import Achille.Recipe+import Achille.Task+++-- | CLI commands.+data AchilleCommand+ = Build [String] -- ^ Build the site once+ | Deploy -- ^ Deploy to the server+ | Clean -- ^ Delete all artefacts+ deriving (Eq, Show)+++-- | CLI parser.+achilleCLI :: Parser AchilleCommand+achilleCLI = subparser $+ command "build" (info (Build <$> many (argument str (metavar "FILES"))) (progDesc "Build the site once" ))+ <> command "deploy" (info (pure Deploy) (progDesc "Server go brrr" ))+ <> command "clean" (info (pure Clean) (progDesc "Delete all artefacts"))+++-- | Main entrypoint for achille. Provides a CLI for running a task.+achille :: Task IO a -> IO ()+achille = achilleWith def+++-- | CLI for running a task using given options.+achilleWith :: Config -> Task IO a -> IO ()+achilleWith config task = customExecParser p opts >>= \case+ Deploy -> mapM_ Process.callCommand (deployCmd config)+ Clean -> removePathForcibly (outputDir config)+ >> removePathForcibly (cacheFile config)+ Build paths -> void $ runTask (map compile paths) config task+ where+ opts = info (achilleCLI <**> helper) $ fullDesc <> header desc+ p = prefs showHelpOnEmpty+ desc = "A static site generator for fun and profit"
+ src/Achille/Config.hs view
@@ -0,0 +1,30 @@+-- | Exports a datatype for the top-level achille config.+module Achille.Config+ ( Config (..)+ , def+ ) where+++import System.FilePath (FilePath)+import Data.Default (Default, def)+++-- | achille configuration datatype.+data Config = Config+ { contentDir :: FilePath -- ^ Root of the source directory.+ -- Defaults to @"content"@.+ , outputDir :: FilePath -- ^ Root of the output directory.+ -- Defaults to @"_site"@.+ , cacheFile :: FilePath -- ^ Path where the cache is stored.+ -- Defaults to @".cache"@.+ , deployCmd :: Maybe String -- ^ Command to run for deploying the result.+ }+++instance Default Config where+ def = Config+ { contentDir = "content"+ , outputDir = "_site"+ , cacheFile = ".cache"+ , deployCmd = Nothing+ }
+ src/Achille/Internal.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE DeriveFunctor #-}++-- | Defines recipes, how they compose and evaluate.+module Achille.Internal+ ( Cache+ , emptyCache+ , toCache+ , fromCache+ , fromContext+ , MustRun(..)+ , Context(..)+ , Recipe(..)+ , Task+ , runRecipe+ , nonCached+ ) where++import Prelude hiding (fail, liftIO)++import Data.Binary (Binary, encode, decodeOrFail)+import Data.Maybe (fromMaybe)+import Data.Functor (void)+import Control.Monad (ap)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Fail (MonadFail, fail)+import Control.Applicative (liftA2)+import Data.Time.Clock (UTCTime)+import Data.ByteString.Lazy (ByteString, empty)+import Data.Bifunctor (first, second)+import System.FilePath.Glob (Pattern)+++-- | A cache is a lazy bytestring.+type Cache = ByteString+++-- | The empty cache.+emptyCache :: Cache+emptyCache = empty++-- | Cache a value.+toCache :: Binary a => a -> Cache+toCache = encode++-- | Retrieve a value from cache.+fromCache :: Binary a => Cache -> Maybe a+fromCache cache =+ case decodeOrFail cache of+ Left _ -> Nothing+ Right (_, _, x) -> Just x+++-- | Local rules for running a recipe+data MustRun = MustRunOne -- ^ The current recipe, and only this one, must run+ | MustRunAll -- ^ All subsequent recipes must run+ | NoMust -- ^ No obligation, the current recipe will be run as normal+ deriving (Eq)+++lowerMustRun :: MustRun -> MustRun+lowerMustRun MustRunAll = MustRunAll+lowerMustRun x = NoMust++-- | Try to load a value from the cache,+-- while respecting the rule for running the recipe.+-- That is, if the rule must run, nothing will be returned.+-- We also lower the run rule in the returned context, if possible.+--+-- The types are not explicit enough, should rewrite.+fromContext :: Binary a => Context b -> (Maybe a, Context b)+fromContext c =+ let r = mustRun c in+ if r /= NoMust then (Nothing, c {mustRun = lowerMustRun r})+ else (fromCache (cache c), c)++++-- | Description of a computation producing a value b given some input a.+newtype Recipe m a b = Recipe (Context a -> m (b, Cache))+++-- | Context in which a recipe is being executed.+data Context a = Context+ { inputDir :: FilePath -- ^ Input root directory+ , outputDir :: FilePath -- ^ Output root directory+ , currentDir :: FilePath -- ^ Current directory+ , timestamp :: UTCTime -- ^ Timestamp of the last run+ , forceFiles :: [Pattern] -- ^ Files marked as dirty+ , mustRun :: MustRun -- ^ Whether the current task must run+ , cache :: Cache -- ^ Local cache+ , inputValue :: a -- ^ Input value+ } deriving (Functor)+++-- | A task is a recipe with no input+type Task m = Recipe m ()+++-- | Make a recipe out of a computation that is known not to be cached.+nonCached :: Functor m => (Context a -> m b) -> Recipe m a b+nonCached f = Recipe \c -> (, emptyCache) <$> f c {cache = emptyCache}+++-- | Run a recipe with a given context.+runRecipe :: Recipe m a b -> Context a -> m (b, Cache)+runRecipe (Recipe r) = r+++instance Functor m => Functor (Recipe m a) where+ fmap f (Recipe r) = Recipe \c -> first f <$> r c+++instance Monad m => Applicative (Recipe m a) where+ pure = Recipe . const . pure . (, emptyCache)++ (<*>) = ap+++splitCache :: Cache -> (Cache, Cache)+splitCache = fromMaybe (emptyCache, emptyCache) . fromCache+++instance Monad m => Monad (Recipe m a) where+ Recipe r >>= f = Recipe \c -> do+ let (cr, cf) = splitCache (cache c)+ (x, cr') <- r c {cache = cr}+ (y, cf') <- runRecipe (f x) c {cache = cf}+ pure (y, toCache (cr', cf'))++ -- parallelism for free?+ Recipe r >> Recipe s = Recipe \c -> do+ let (cr, cs) = splitCache (cache c)+ (_, cr') <- r c {cache = cr}+ (y, cs') <- s c {cache = cs}+ pure (y, toCache (cr', cs'))+++instance MonadIO m => MonadIO (Recipe m a) where+ liftIO = nonCached . const . liftIO+++instance MonadFail m => MonadFail (Recipe m a) where+ fail = Recipe . const . fail+++instance (Monad m, Semigroup b) => Semigroup (Recipe m a b) where+ x <> y = liftA2 (<>) x y+++instance (Monad m, Monoid b) => Monoid (Recipe m a b) where+ mempty = pure mempty
+ src/Achille/Internal/IO.hs view
@@ -0,0 +1,81 @@+-- | Defines an IO interface for core recipes+module Achille.Internal.IO+ ( AchilleIO+ , readFile+ , readFileLazy+ , copyFile+ , writeFile+ , writeFileLazy+ , doesFileExist+ , doesDirExist+ , callCommand+ , log+ , glob+ , getModificationTime+ , fail+ ) where++import Prelude as Prelude hiding (log, readFile, writeFile)++import Data.Text (Text)+import System.FilePath (FilePath)+import Data.Time.Clock (UTCTime)+import Control.Monad.Fail (MonadFail)++import qualified System.Directory as Directory+import qualified System.FilePath as FilePath+import qualified System.FilePath.Glob as Glob+import qualified System.Process as Process+import qualified Data.Text as Text+import qualified Data.Text.IO as TextIO+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+++-- | Interface for IO actions used by core recipes.+class (Monad m, MonadFail m) => AchilleIO m where+ -- | Retrieve a file as a bytestring.+ readFile :: FilePath -> m BS.ByteString+ -- | Retrieve a file as a /lazy/ bytestring.+ readFileLazy :: FilePath -> m LBS.ByteString+ -- | Copy a file from one location to another.+ copyFile :: FilePath -> FilePath -> m ()+ -- | Write a bytestring to a file.+ writeFile :: FilePath -> BS.ByteString -> m ()+ -- | Write a /lazy/ bytestring to a file.+ writeFileLazy :: FilePath -> LBS.ByteString -> m ()+ -- | Check whether a file exists.+ doesFileExist :: FilePath -> m Bool+ -- | Check whether a directory exists.+ doesDirExist :: FilePath -> m Bool+ -- | Run a shell command in a new process.+ callCommand :: String -> m ()+ -- | Log a string to stdout.+ log :: String -> m ()+ -- | Find all paths matching a given globpattern, relative to a given directory.+ glob :: FilePath -- ^ Path of the root directory.+ -> Glob.Pattern -> m [FilePath]+ -- | Get modification time of a file.+ getModificationTime :: FilePath -> m UTCTime+++ensureDirExists :: FilePath -> IO ()+ensureDirExists =+ Directory.createDirectoryIfMissing True . FilePath.takeDirectory+++instance AchilleIO IO where+ readFile = BS.readFile+ readFileLazy = LBS.readFile+ copyFile from to = ensureDirExists to >> Directory.copyFile from to+ writeFile to x = ensureDirExists to >> BS.writeFile to x+ writeFileLazy to x = ensureDirExists to >> LBS.writeFile to x+ doesFileExist = Directory.doesFileExist+ doesDirExist = Directory.doesDirectoryExist+ callCommand = Process.callCommand+ log = Prelude.putStrLn+ glob dir pattern =+ Directory.withCurrentDirectory dir $+ Glob.globDir1 pattern ""+ >>= mapM Directory.makeRelativeToCurrentDirectory+ getModificationTime = Directory.getModificationTime
+ src/Achille/Recipe.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE RecordWildCards #-}++-- | Core recipes including reading files, saving them.+module Achille.Recipe+ ( Recipe+ , liftIO+ , getInput+ , getCurrentDir+ , readText+ , readBS+ , saveFile+ , saveFileAs+ , copyFile+ , copyFileAs+ , copy+ , write+ , task+ , debug+ , callCommand+ , runCommandWith+ , toTimestamped+ ) where++import Control.Monad.IO.Class (liftIO)+import Data.Binary (Binary, encodeFile)+import Data.Functor (void)+import Data.Text (Text, pack)+import Data.Text.Encoding (decodeUtf8)+import Data.ByteString (ByteString)+import System.FilePath ((</>))++import Achille.Config+import Achille.Writable (Writable)+import Achille.Timestamped+import qualified Achille.Writable as Writable+import Achille.Internal as Internal+import Achille.Internal.IO (AchilleIO)+import qualified Achille.Internal.IO as AchilleIO+++data Color = Red | Blue++color :: Color -> String -> String+color c x = "\x1b[" <> start <> x <> "\x1b[0m"+ where start = case c of+ Red -> "31m"+ Blue -> "34m"++-------------------------------------+-- Recipe building blocks (uncached)+-------------------------------------++-- | Recipe returning its input.+getInput :: Applicative m+ => Recipe m a a+getInput = nonCached $ pure . inputValue++-- | Recipe for retrieving the current directory+getCurrentDir :: Applicative m+ => Recipe m a FilePath+getCurrentDir = nonCached (pure . Internal.currentDir)++-- | Recipe retrieving the contents of the input file as text+readText :: AchilleIO m+ => Recipe m FilePath Text+readText = nonCached \Context{..} ->+ decodeUtf8 <$> AchilleIO.readFile (inputDir </> currentDir </> inputValue)++-- | Recipe retrieving the contents of the input file as a bytestring.+readBS :: AchilleIO m => Recipe m FilePath ByteString+readBS = nonCached \Context{..} ->+ AchilleIO.readFile (inputDir </> currentDir </> inputValue)++-- | Recipe for saving a value to the location given as input.+-- Returns the input filepath as is.+saveFile :: (AchilleIO m, Writable m a)+ => a -> Recipe m FilePath FilePath+saveFile = saveFileAs id++-- | Recipe for saving a value to a file, using the path modifier applied to the input filepath.+-- Returns the path of the output file.+saveFileAs :: (AchilleIO m, Writable m a)+ => (FilePath -> FilePath) -> a -> Recipe m FilePath FilePath+saveFileAs mod x = flip write x =<< mod <$> getInput++-- | Recipe for copying an input file to the same location in the output dir.+copyFile :: AchilleIO m+ => Recipe m FilePath FilePath+copyFile = copyFileAs id++-- | Recipe for copying an input file to the output dir, using the path modifier.+copyFileAs :: AchilleIO m+ => (FilePath -> FilePath) -> Recipe m FilePath FilePath+copyFileAs mod = getInput >>= \from -> copy from (mod from)++-- | Recipe for copying a file to a given destination.+-- Returns the output filepath.+copy :: AchilleIO m+ => FilePath -> FilePath -> Recipe m a FilePath+copy from to = nonCached \Context{..} -> do+ AchilleIO.copyFile (inputDir </> currentDir </> from)+ (outputDir </> currentDir </> to)+ AchilleIO.log (color Blue $ (currentDir </> from) <> " → " <> (currentDir </> to))+ pure to++-- | Recipe for writing to a an output file.+-- Returns the output filepath.+write :: (AchilleIO m, Writable m b)+ => FilePath -> b -> Recipe m a FilePath+write to x = nonCached \Context{..} -> do+ Writable.write (outputDir </> currentDir </> to) x+ AchilleIO.log (color Blue $ "writing " <> (currentDir </> to))+ pure to++-- | Make a recipe out of a task. The input will simply be discarded.+task :: Task m b -> Recipe m a b+task (Recipe r) = Recipe (r . void)++++------------------------------+-- Lifted IO+------------------------------++-- | Recipe for printing a value to the console.+debug :: AchilleIO m+ => Show b => b -> Recipe m a ()+debug = nonCached . const . AchilleIO.log . show++-- | Recipe for running a shell command in a new process.+callCommand :: AchilleIO m+ => String -> Recipe m a ()+callCommand = nonCached . const . AchilleIO.callCommand++-- | Recipe for running a shell command in a new process.+-- The command is defined with an helper function which depends on an input filepath+-- and the same filepath with a modifier applied.+--+-- Examples:+--+-- > cp :: Recipe IO FilePath FilePath+-- > cp = runCommandWith id (\a b -> "cp " <> a <> " " <> b)+runCommandWith :: AchilleIO m+ => (FilePath -> FilePath)+ -> (FilePath -> FilePath -> String)+ -> Recipe m FilePath FilePath+runCommandWith mod cmd = nonCached \Context{..} ->+ let p' = mod inputValue+ in AchilleIO.callCommand (cmd (inputDir </> currentDir </> inputValue)+ (outputDir </> currentDir </> p'))+ >> pure p'++-- | Recipe that will retrieve the datetime contained in a filepath.+toTimestamped :: Monad m => FilePath -> Recipe m a (Timestamped FilePath)+toTimestamped = pure . timestamped
+ src/Achille/Recipe/Pandoc.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- | Defines convenience recipes for reading and writing documents with pandoc.+module Achille.Recipe.Pandoc+ ( readPandoc+ , readPandocWith+ , readPandocMetadata+ , readPandocMetadataWith+ , renderPandoc+ , renderPandocWith+ , compilePandoc+ , compilePandocWith+ ) where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Binary (Binary, encodeFile)+import Data.Functor (void)+import Data.Text (Text, pack)+import Data.Text.Encoding (decodeUtf8)+import System.Directory (copyFile, createDirectoryIfMissing, withCurrentDirectory)++import System.FilePath+import Text.Pandoc hiding (nonCached)+import Data.Aeson.Types (FromJSON)+import Data.Frontmatter (parseYamlFrontmatter, IResult(..))++import qualified Data.Text.IO as Text+import qualified System.FilePath.Glob as Glob+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Lazy as LazyByteString+import qualified System.FilePath as Path+import qualified System.Process as Process++import Achille.Config+import Achille.Internal hiding (currentDir)+import qualified Achille.Internal as Internal+import Achille.Recipe+import Achille.Writable as Writable+import Achille.Internal.IO (AchilleIO)+++-- | Recipe for loading a pandoc document+readPandoc :: MonadIO m+ => Recipe m FilePath Pandoc+readPandoc = readPandocWith def++-- | Recipe for loading a pandoc document using a given reader config+readPandocWith :: MonadIO m+ => ReaderOptions -> Recipe m FilePath Pandoc+readPandocWith ropts = nonCached \Context{..} ->+ let ext = drop 1 $ takeExtension inputValue+ Just reader = lookup (pack ext) readers+ in case reader of+ ByteStringReader f -> liftIO $ + LazyByteString.readFile (inputDir </> currentDir </> inputValue)+ >>= runIOorExplode <$> f ropts+ TextReader f -> liftIO $+ Text.readFile (inputDir </> currentDir </> inputValue)+ >>= runIOorExplode <$> f ropts++-- | Recipe for loading a pandoc document and a frontmatter header.+readPandocMetadata :: (MonadIO m, MonadFail m, FromJSON a)+ => Recipe m FilePath (a, Pandoc)+readPandocMetadata = readPandocMetadataWith def++-- | Recipe for loading a pandoc document using a given reader config+readPandocMetadataWith :: (MonadIO m, MonadFail m, FromJSON a)+ => ReaderOptions -> Recipe m FilePath (a, Pandoc)+readPandocMetadataWith ropts = nonCached \Context{..} -> do+ let ext = drop 1 $ takeExtension inputValue+ Just reader = lookup (pack ext) readers+ contents <- liftIO $ ByteString.readFile (inputDir </> currentDir </> inputValue)+ (meta, remaining) <-+ case parseYamlFrontmatter contents of+ Done i a -> pure (a, i)+ _ -> fail $ "error while loading meta of " <> inputValue+ (meta,) <$> case reader of+ ByteStringReader f -> liftIO $+ runIOorExplode $ f ropts (LazyByteString.fromStrict remaining)+ TextReader f -> liftIO $+ runIOorExplode $ f ropts (decodeUtf8 remaining)++-- | Recipe to convert a Pandoc document to HTML.+renderPandoc :: MonadIO m+ => Pandoc -> Recipe m a Text+renderPandoc = renderPandocWith def ++-- | Recipe to convert a Pandoc document to HTML using specified writer options.+renderPandocWith :: MonadIO m+ => WriterOptions -> Pandoc -> Recipe m a Text+renderPandocWith wopts = liftIO . runIOorExplode <$> writeHtml5String wopts++-- | Recipe to load and convert a Pandoc document to HTML.+compilePandoc :: MonadIO m+ => Recipe m FilePath Text+compilePandoc = readPandoc >>= renderPandoc++-- | Recipe to load and convert a Pandoc document to HTML.+compilePandocWith :: MonadIO m+ => ReaderOptions -> WriterOptions -> Recipe m FilePath Text+compilePandocWith ropts wopts =+ readPandocWith ropts >>= renderPandocWith wopts
+ src/Achille/Task.hs view
@@ -0,0 +1,224 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}++-- | Defines core combinators for processing files incrementally.+module Achille.Task+ ( Task+ , match+ , match_+ , matchFile+ , matchDir+ , with+ , watch+ , runTask+ ) where+++import Data.Functor ((<&>))+import Control.Monad (forM, filterM)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Binary (Binary)+import System.FilePath (FilePath, (</>), takeDirectory, takeFileName)+import System.FilePath.Glob (Pattern)+import System.Directory+import System.IO (openBinaryFile, hClose, IOMode(ReadMode))+import Data.Time.Clock (UTCTime(..))+import Data.Time.Calendar (Day(..))++import qualified System.FilePath.Glob as Glob+import qualified Data.ByteString.Lazy as ByteString++import Achille.Config (Config)+import Achille.Internal++import qualified Achille.Config as Config+import Achille.Internal.IO (AchilleIO)+import qualified Achille.Internal.IO as AchilleIO++-- what our tasks are caching+type MatchVoid = [(FilePath, Cache)]+type Match b = [(FilePath, (b, Cache))]+type MatchDir = [(FilePath, Cache)]+type With a b = (a, (b, Cache))+type Watch a = (a, Cache)+++shouldForce :: Context a -> FilePath -> Bool+shouldForce ctx x = or (Glob.match <$> forceFiles ctx <*> pure x)++-- TODO: investigate whether we need glob at all?+-- It doesn't look like it's very fast,+-- and it doesn't allow you to do conditionals with {}+-- such as *.{jpg, png}++-- | Run a recipe on every filepath matching a given pattern.+-- The results are cached and the recipe only recomputes+-- when the underlying file has changed since last run.+match :: (AchilleIO m, Binary a)+ => Pattern -> Recipe m FilePath a -> Recipe m c [a]+match pattern (Recipe r :: Recipe m FilePath b) = Recipe \ctx -> do+ let (cached, c'@Context{..}) = fromContext ctx+ paths <- AchilleIO.glob (inputDir </> currentDir) pattern+ >>= filterM (AchilleIO.doesFileExist . ((inputDir </> currentDir) </>))+ case cached :: Maybe (Match b) of+ Nothing -> do+ result <- forM paths \p ->+ (p,) <$> r c' { inputValue = p+ , cache = emptyCache+ }+ return (map (fst . snd) result, toCache (result :: Match b))+ Just cached -> do+ result <- forM paths \p ->+ case lookup p cached of+ Just (v, cache) -> (p,) <$> do+ tfile <- AchilleIO.getModificationTime (inputDir </> currentDir </> p)+ if timestamp < tfile || shouldForce ctx (inputDir </> currentDir </> p) then+ r c' {inputValue = p, cache = cache}+ else pure (v, cache)+ Nothing -> (p,) <$> r c' {inputValue = p, cache = emptyCache}+ return (map (fst . snd) result, toCache (result :: Match b))+++-- | Run a recipe on every filepath matching a given pattern,+-- and discard the result.+-- Filepaths are cached and the recipe only recomputes when+-- the underlying file has changed since last run.+match_ :: AchilleIO m => Pattern -> Recipe m FilePath a -> Task m ()+match_ pattern (Recipe r) = Recipe \ctx -> do+ let (result, c'@Context{..}) = fromContext ctx + paths <- AchilleIO.glob (inputDir </> currentDir) pattern+ >>= filterM (AchilleIO.doesFileExist . ((inputDir </> currentDir) </>))+ case result :: Maybe MatchVoid of+ Nothing -> do+ result <- forM paths \p ->+ ((p,) . snd) <$> r c' { inputValue = p+ , cache = emptyCache+ }+ return (() , toCache (result :: MatchVoid))+ Just cached -> do+ result <- forM paths \p ->+ case lookup p cached of+ Just cache -> (p,) <$> do+ tfile <- AchilleIO.getModificationTime (inputDir </> currentDir </> p)+ if timestamp < tfile || shouldForce ctx (inputDir </> currentDir </> p) then+ snd <$> r c' {inputValue = p, cache = cache}+ else pure cache+ Nothing -> ((p,) . snd) <$> r c' {inputValue = p, cache = emptyCache}+ return ((), toCache (result :: MatchVoid))+++-- | Run a recipe for a filepath matching a given pattern.+-- The result is cached and the recipe only recomputes+-- when the underlying file has changed since last run.+-- Will fail is no file is found matching the pattern.+matchFile :: (AchilleIO m, Binary a)+ => Pattern -> Recipe m FilePath a -> Recipe m b a+matchFile p (Recipe r :: Recipe m FilePath a) = Recipe \ctx@Context{..} ->+ AchilleIO.glob (inputDir </> currentDir) p >>= \case+ [] -> AchilleIO.fail $ unwords+ [ "No file was found matching pattern"+ , Glob.decompile p+ , "inside directory"+ , currentDir+ ]+ (p:xs) ->+ let (result, c'@Context{..}) = fromContext ctx+ in case result :: Maybe (Watch a) of+ Nothing -> r c' {cache = emptyCache, inputValue = p}+ <&> \v -> (fst v, toCache (v :: Watch a))+ Just (x, cache) -> do+ tfile <- AchilleIO.getModificationTime (inputDir </> currentDir </> p)+ if timestamp < tfile || shouldForce ctx (inputDir </> currentDir </> p) then+ r c' {cache = cache, inputValue = p}+ <&> \v -> (fst v, toCache (v :: Watch a))+ else pure (x, toCache ((x, cache) :: Watch a))+++-- | For every file matching the pattern, run a recipe with the+-- file as input and with the file's parent directory as current working directory.+-- The underlying recipe will be run regardless of whether the file was modified.+matchDir :: AchilleIO m+ => Pattern -> Recipe m FilePath a -> Recipe m c [a]+matchDir pattern (Recipe r) = Recipe \ctx -> do+ let (result, c'@Context{..}) = fromContext ctx + paths <- AchilleIO.glob (inputDir </> currentDir) pattern+ case result :: Maybe MatchDir of+ Nothing -> do+ result <- forM paths \p ->+ r c' { inputValue = takeFileName p+ , currentDir = currentDir </> takeDirectory p+ , cache = emptyCache+ }+ return (map fst result, toCache (zip paths (map snd result) :: MatchDir))+ Just cached -> do+ result <- forM paths \p ->+ case lookup p cached of+ Just cache -> r c' { inputValue = takeFileName p+ , currentDir = currentDir </> takeDirectory p+ , cache = cache+ }+ Nothing -> r c' {inputValue = p, cache = emptyCache}+ return (map fst result, toCache (zip paths (map snd result) :: MatchDir))+++-- | Cache a value and only trigger a given recipe if said value has changed between runs.+-- cache the result of the recipe.+with :: (Applicative m, Binary a, Eq a, Binary b)+ => a -> Recipe m c b -> Recipe m c b+with (x :: a) (Recipe r :: Recipe m1 c d) = Recipe \ctx ->+ let (result, c'@Context{..}) = fromContext ctx + in case result :: Maybe (With a d) of+ Nothing ->+ r c' {cache = emptyCache}+ <&> \v -> (fst v, toCache ((x, v) :: With a d))+ Just (x', (v, cache)) ->+ if x == x' then pure (v , toCache ((x', (v, cache)) :: With a d))+ else r c' <&> \v -> (fst v, toCache ((x, v) :: With a d))+++-- | Cache a value and only trigger a given recipe if said value has changed between runs.+-- Like 'with', but the result of the recipe won't be cached.+-- If the recipe must be retriggered, it will be in depth.+watch :: (Functor m, Binary a, Eq a)+ => a -> Recipe m c b -> Recipe m c b+watch (x :: a) (Recipe r :: Recipe m c b) = Recipe \ctx ->+ let (result, c'@Context{..}) = fromContext ctx+ in case result :: Maybe (Watch a) of+ Nothing ->+ r c' {cache = emptyCache}+ <&> \v -> (fst v, toCache ((x, snd v) :: Watch a))+ Just (x', cache) ->+ r c' {mustRun = if x /= x' then MustRunOne else NoMust, cache = cache}+ <&> \v -> (fst v, toCache ((x, snd v) :: Watch a))+++-- | Run a task using the provided config and a list of dirty files.+-- This takes care of loading the existing cache and updating it.+runTask :: MonadIO m+ => [Glob.Pattern] -- ^ Files for which we force recompilation+ -> Config -- ^ The config+ -> Task m a -- ^ The task+ -> m a+runTask force config (Recipe r) = do+ cacheExists <- liftIO $ doesFileExist (Config.cacheFile config)+ timestamp <- if cacheExists then+ liftIO $ getModificationTime (Config.cacheFile config)+ else pure (UTCTime (ModifiedJulianDay 0) 0)+ let ctx = Context (Config.contentDir config)+ (Config.outputDir config)+ ""+ timestamp+ force+ NoMust+ (v, cache') <-+ if cacheExists then do+ handle <- liftIO $ openBinaryFile (Config.cacheFile config) ReadMode+ cache <- liftIO $ ByteString.hGetContents handle+ (value, cache') <- r (ctx cache ())+ liftIO $ hClose handle+ pure (value, cache')+ else do r (ctx emptyCache ())+ liftIO $ ByteString.writeFile (Config.cacheFile config) cache'+ pure v
+ src/Achille/Timestamped.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}++-- | Defines utilies for working with timestamped things.+module Achille.Timestamped+ ( Timestamped(..)+ , IsTimestamped+ , timestamp+ , timestamped+ , timestampedWith+ , compareTimestamped+ , recentFirst+ , oldFirst+ ) where++import Data.Ord (Ord, compare, Ordering)+import System.FilePath (FilePath)+import Data.List (sortBy, sort)+import Data.Typeable (Typeable)+import Data.Binary (Binary, put, get)+import Data.Time.Calendar (fromGregorian)+import Data.Time (UTCTime(..), secondsToDiffTime)+import Data.Time.Format (readSTime, defaultTimeLocale)+import System.FilePath (takeFileName)+import Data.Binary.Instances.Time ()++-- | Container for timestamping data.+data Timestamped a = Timestamped UTCTime a+ deriving (Show, Eq, Ord, Typeable, Functor)++instance Binary a => Binary (Timestamped a) where+ put (Timestamped d x) = put d >> put x+ get = Timestamped <$> get <*> get+++-- | Class for values that can be timestamped.+class IsTimestamped a where+ -- | Retrieve a datetime from a value.+ timestamp :: a -> UTCTime++instance IsTimestamped (Timestamped a) where+ timestamp (Timestamped d _) = d++instance IsTimestamped FilePath where+ timestamp p =+ case readSTime False defaultTimeLocale "%Y-%m-%d" (takeFileName p) of+ [(t, _)] -> t+ _ -> UTCTime (fromGregorian 1970 01 01) (secondsToDiffTime 0)+++-- | Wrap a value that can be timestamped.+timestamped :: IsTimestamped a => a -> Timestamped a+timestamped x = Timestamped (timestamp x) x++-- | Wrap a value that can be timestamped, using the given function for+-- retrieving the timestamp.+timestampedWith :: (a -> UTCTime) -> a -> Timestamped a+timestampedWith f x = Timestamped (f x) x++-- | Compare two timestamped values.+compareTimestamped :: IsTimestamped a => a -> a -> Ordering+compareTimestamped x y = compare (timestamp x) (timestamp y)++-- | Sort timestamped values from most recent to oldest.+recentFirst :: IsTimestamped a => [a] -> [a]+recentFirst = sortBy (flip compareTimestamped)++-- | Sort timestamped values from oldest to most recent.+oldFirst :: IsTimestamped a => [a] -> [a]+oldFirst = sortBy compareTimestamped
+ src/Achille/Writable.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- | Defines an interface for things that can be written to disk.+module Achille.Writable where++import Data.Text as Text+import qualified Data.Text.Lazy as LT+import Data.Text.Encoding (encodeUtf8)+import qualified Data.Text.Lazy.Encoding as LT (encodeUtf8)+import Data.ByteString as BS+import Data.ByteString.Lazy as LBS++import qualified Data.ByteString.Lazy as ByteString++import Achille.Internal.IO as AchilleIO+++-- | Class for things that can be saved.+class Writable m a where+ write :: FilePath -> a -> m ()++instance AchilleIO m => Writable m [Char] where+ write to = write to . Text.pack++instance AchilleIO m => Writable m Text where+ write to = AchilleIO.writeFile to . encodeUtf8++instance AchilleIO m => Writable m LT.Text where+ write to = AchilleIO.writeFileLazy to . LT.encodeUtf8++instance AchilleIO m => Writable m BS.ByteString where+ write = AchilleIO.writeFile++instance AchilleIO m => Writable m LBS.ByteString where+ write = AchilleIO.writeFileLazy
+ tests/FakeIO.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE GADTs, ScopedTypeVariables #-}++module FakeIO where+++import Data.Time.Clock (UTCTime)+import Data.Map.Strict as M+import Data.Maybe+import Data.Bifunctor (bimap)+import Control.Monad.Fail (MonadFail, fail)++import qualified System.Directory as Directory+import qualified System.FilePath as FilePath+import qualified System.FilePath.Glob as Glob+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import Control.Monad.State++import Test.Tasty.HUnit++import Achille.Recipe+import Achille.Internal+import Achille.Internal.IO as AchilleIO+++data FakeIO a where+ ReadFile :: FilePath -> FakeIO BS.ByteString+ ReadFileLazy :: FilePath -> FakeIO LBS.ByteString+ CopyFile :: FilePath -> FilePath -> FakeIO ()+ WriteFile :: FilePath -> BS.ByteString -> FakeIO ()+ WriteFileLazy :: FilePath -> LBS.ByteString -> FakeIO ()+ DoesFileExist :: FilePath -> FakeIO Bool+ DoesDirExist :: FilePath -> FakeIO Bool+ CallCommand :: String -> FakeIO ()+ Log :: String -> FakeIO ()+ Glob :: FilePath -> Glob.Pattern -> FakeIO [FilePath]+ GetModificationTime :: FilePath -> FakeIO UTCTime+ Fail :: String -> FakeIO a++ SeqAp :: FakeIO (a -> b) -> FakeIO a -> FakeIO b+ Fmap :: (a -> b) -> FakeIO a -> FakeIO b+ Pure :: a -> FakeIO a+ Bind :: FakeIO a -> (a -> FakeIO b) -> FakeIO b+++instance Functor FakeIO where+ fmap = Fmap++instance Applicative FakeIO where+ pure = Pure+ (<*>) = SeqAp++instance Monad FakeIO where+ (>>=) = Bind++instance MonadFail FakeIO where+ fail = Fail+++instance AchilleIO FakeIO where+ readFile = ReadFile+ readFileLazy = ReadFileLazy+ copyFile = CopyFile+ writeFile = WriteFile+ writeFileLazy = WriteFileLazy+ doesFileExist = DoesFileExist+ doesDirExist = DoesDirExist+ callCommand = CallCommand+ log = Log+ glob = Glob+ getModificationTime = GetModificationTime+++data FakeIOActions+ = WrittenFile FilePath BS.ByteString+ | WrittenFileLazy FilePath LBS.ByteString+ | HasReadFile FilePath+ | HasReadFileLazy FilePath+ | CopiedFile FilePath FilePath+ | CalledCommand String+ | Failed String+ deriving (Eq, Show)+++type FileSystem = Map FilePath (UTCTime, BS.ByteString)++defMTime :: UTCTime+defMTime = undefined++getMTime :: FilePath -> FileSystem -> UTCTime+getMTime p fs = fromMaybe defMTime (fst <$> M.lookup p fs)++getBS :: FilePath -> FileSystem -> BS.ByteString+getBS p fs = fromMaybe BS.empty (snd <$> M.lookup p fs)++retrieveFakeIOActions :: FakeIO (a, Cache) -- the fake IO computation+ -> FileSystem -- the underlying input FS+ -> (Maybe a, [FakeIOActions])+retrieveFakeIOActions t fs = bimap (fmap fst) reverse $ runState (retrieve t) []+ where+ retrieve :: FakeIO a -> State [FakeIOActions] (Maybe a)+ retrieve (ReadFile key) = do+ modify (HasReadFile key :)+ pure (Just $ getBS key fs)++ retrieve (ReadFileLazy key) = do+ modify (HasReadFileLazy key :)+ pure (Just $ LBS.fromStrict $ getBS key fs)++ retrieve (CopyFile from to) = Just <$> modify (CopiedFile from to :)+ retrieve (WriteFile p c) = Just <$> modify (WrittenFile p c :)+ retrieve (WriteFileLazy p c) = Just <$> modify (WrittenFileLazy p c :)+ retrieve (DoesFileExist p) = undefined++ retrieve (CallCommand cmd) = Just <$> modify (CalledCommand cmd :)+ retrieve (Log str) = pure $ Just ()+ retrieve (Glob dir p) = undefined+ retrieve (GetModificationTime p) = pure $ Just (getMTime p fs)++ retrieve (SeqAp f x) = do+ actions <- get+ let (Just f', actions') = runState (retrieve f) actions+ let (Just x', actions'') = runState (retrieve x) actions'+ put actions''+ pure $ Just (f' x')++ retrieve (Fmap f x) = do+ actions <- get+ let (Just x', actions') = runState (retrieve x) actions+ put actions'+ pure $ Just (f x')++ retrieve (Pure x) = pure (Just x)+ retrieve (Fail str) = modify (Failed str :) >> pure Nothing++ retrieve (Bind (Fail str) f) = modify (Failed str :) >> pure Nothing++ retrieve (Bind x f) = do+ actions <- get+ let (Just x', actions') = runState (retrieve x) actions+ put actions'+ retrieve (f x')+++exactRun :: (Show b, Eq b)+ => FileSystem+ -> Context a+ -> Recipe FakeIO a b+ -> (Maybe b, [FakeIOActions])+ -> Assertion+exactRun fs ctx r expected =+ let fakeIO = runRecipe r ctx+ trace = retrieveFakeIOActions fakeIO fs+ in trace @?= expected
+ tests/Main.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Test.Tasty+import Test.Tasty.Ingredients.ConsoleReporter+import Test.Tasty.HUnit++import FakeIO+import Achille.Recipe+import Achille.Internal+import System.FilePath+import qualified Data.Map.Strict as M+import qualified Data.ByteString.Lazy as LBS+import Data.Text (Text)++fs :: FileSystem+fs = M.fromList+ [ ("content" </> "fichier.txt",+ (defMTime, "helloworld"))+ ]++testCtx :: a -> Context a+testCtx x = Context+ { inputDir = "content"+ , outputDir = "output"+ , currentDir = ""+ , timestamp = defMTime+ , forceFiles = [] + , mustRun = NoMust+ , cache = LBS.empty+ , inputValue = x+ }++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Tests"+ [ testCase "Write on the fs and get the output path back:" $+ exactRun fs (testCtx ())+ (write "somewhere.txt" ("somestuff" :: Text))+ (Just "somewhere.txt", [ WrittenFile "output/somewhere.txt" "somestuff" ])++ , testCase "Read text from the fs" $+ exactRun fs (testCtx "fichier.txt")+ (readText)+ (Just "helloworld", [ HasReadFile "content/fichier.txt" ])++ , testCase "Read text and write it to the fs" $+ exactRun fs (testCtx "fichier.txt")+ (readText >>= saveFile)+ (Just "fichier.txt", [ HasReadFile "content/fichier.txt"+ , WrittenFile "output/fichier.txt" "helloworld" ])+ , testCase "Copy file" $+ exactRun fs (testCtx ())+ (copy "un.txt" "deux.txt")+ (Just "deux.txt", [ CopiedFile "content/un.txt" "output/deux.txt" ])+ ]+