diff --git a/CHANGELOG.md b/CHANGELOG.md deleted file mode 100644 --- a/CHANGELOG.md +++ /dev/null @@ -1,120 +0,0 @@ -# Change Log for rib - -## 0.12 - -- Removed pandoc-include-code -- Allow dhall 1.30 -- default.nix: Allow overriding compiler - -## 0.10.0.0 - -- API - - Dropped `path` and `path-io` in favour of good ol' `FilePath` - - This also lifts the restriction with absolute paths -- Misc changes - - #145: CLI arguments have been revamped - - `serve` subcommand is replaced by the options `-wS`. - - Added `--input-dir/--output-dir` to override these paths - - Accept host string in addition to port number - - Exposed `Rib.Shake.getCliConfig` to get full CLI configuration - - Allow customizing fsnotify ignore list - - #141: Allow quiet logging (useful when rib is used as a library) - -## 0.8.0.0 - -- Dependency upgrades - - GHC 8.8 - - pandoc-include-code: 0.5.0.0 - - pandoc-types: 1.20 - - dhall: 1.30 - - clay: 0.13.3 (This is a downgrade, as 0.14 is not released yet) -- New features: - - API exposes the CLI parser (`optparse-applicative`) for user-level composition - - Add `Rib.Parser.Pandoc.getToC` returning rendered Table of contents for a Pandoc document - - Add `Rib.Parser.MMark.getFirstParagraphText` - - Add `Rib.Extra.OpenGraph` for Open Graph protocol - - Add to `Rib.Extra.CSS`, `googleFonts` and `stylesheet` -- Bug fixes and misc changes: - - `routeUrl`: Fix incorrect substitution of "foo-index.html" with "foo-" - - Lucid rendering functions (like `MMark.render`) are now polymorphic in their monad. - - #122: Fix Pandoc parser never returning metadata - - #127: Rib's HTTP server now binds to `127.0.0.1`. - - Allow directory listings in HTTP server - - #130: Prevent unnecessary re-running of Shake action by debouncing fsnotify events - - #136: Move `.shake` database directory under `ribInputDir` - - default.nix: Takes `overrides` and `additional-packages` as extra arguments - -## 0.7.0.0 - -- Dependency upgrades - - mmark: 0.0.7.2 - - megaparsec: 0.8 - - clay: 0.14 - - shake: 0.8.15 -- New features: - - Added Dhall parser, `Rib.Parser.Dhall` - - Add `Rib.Extra` containing useful but non-essential features -- MMark, extensions removed: - - `ghcSyntaxHighlighter`: we already have `skylighting` (which supports more parsers than Haskell) - - `obfuscateEmail`: requires JS, which is not documented. -- API changes: - - Introduced `Route` functionality for simpler management of static routes. - - Removed `buildHtmlMulti`, `buildHtml`, `readSource` functions and `Source` type. - - Introduced `Rib.Shake.forEvery` to run a Shake action over a pattern of files when they change. - - Exposed `Rib.Shake.writeFileCached` - - `MMark.parse` and `Pandoc.parse` now automatically append path to `ribInputDir` and do not return Either. - - Added `MMark.parseWith` (and `parsePureWith`), to specify a custom list of mmark extensions -- Bug fixes - - #95: Fix Shake error `resource busy (file is locked)` - - #97: Fix Shake error `AsyncCancelled` when server thread crashes - - #96 & #108: Drop problematic use of Shake `cacheActionWith` - -## 0.6.0.0 - -- Advance nixpkgs; require Shake >=0.18.4 -- Major API simplication: no more type class! - - Allow user to specify their own source parser as a Haskell function - - Removed types `Document` and `Markup` in favour of `Source` - - Expose `ribInputDir` and `ribOutputDir` for use in custom Shake actions -- Bug fixes: - - #63: create intermediate directories when generating post HTML - - #70: Don't crash on Shake errors - - Fix unnecessary rebuild of all files when only one file changed - - #66: Use caching (via Shake's `cacheActionWith`), to avoid writing HTML to disk until it has changed. - -## 0.5.0.0 - -This release comes with a major API refactor. Key changes: - -- Added MMark support, as an alternative to Pandoc -- Allows using arbitrary records to load metadata - - This replaces the previous complex metadata API -- Added `Document` type that uses the custom metadata record -- Add top-level `Rib` import namespace for ease of use -- Remove the following: - - JSON cache - - `Rib.Simple` -- Support for Table of Contents via MMark - -Other changes: - -- Use type-safe path types using the [path](http://hackage.haskell.org/package/path) library. -- Fix #40: Gracefully handle rendering/ parsing errors, without dying. -- Misc error reporting improvements - -## 0.4.1.0 - -- `Rib.Pandoc`: - - Export `render'` and `renderInlines'` (the non-Lucid versions) - - Re-export `Text.Pandoc.Readers` so the library user does not have to directly depend on `pandoc` only to render its documents. -- `Rib.App`: The `run` funtion now takes two more arguments, specifying the input and output directory, which are no longer hardcoded. -- `Rib.Simple`: add LaTeX to default list of readers -- `Rib.Server`: Remove ".html" detection magic from URLs - -## 0.3.0.0 - -- Rename `Rib.App.Watch` to `Rib.App.WatchAndGenerate` - -## 0.2.0.0 - -- Initial release. diff --git a/README.md b/README.md deleted file mode 100644 --- a/README.md +++ /dev/null @@ -1,29 +0,0 @@ - - -# rib - -[![BSD3](https://img.shields.io/badge/License-BSD-blue.svg)](https://en.wikipedia.org/wiki/BSD_License) -[![Hackage](https://img.shields.io/hackage/v/rib.svg)](https://hackage.haskell.org/package/rib) -[![built with nix](https://img.shields.io/badge/builtwith-nix-purple.svg)](https://builtwithnix.org) -[![Zulip chat](https://img.shields.io/badge/zulip-join_chat-brightgreen.svg)](https://funprog.zulipchat.com/#narrow/stream/218047-Rib) - -Rib is a Haskell **static site generator** based on Shake, with a delightful workflow. - -See for full documentation. - -## Developing rib - -Use ghcid for quicker compilation cycles: - -```bash -nix-shell --run ghcid -``` - -To test your changes, clone [rib-sample](https://github.com/srid/rib-sample) and run it using your local rib checkout: - -```bash -cd .. -git clone https://github.com/srid/rib-sample.git -cd rib-sample -nix-shell --arg rib ../rib --run 'ghcid -T ":main -wS"' -``` diff --git a/rib.cabal b/rib.cabal --- a/rib.cabal +++ b/rib.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: rib -version: 0.12.0.0 +version: 1.0.0.0 license: BSD-3-Clause copyright: 2019 Sridhar Ratnakumar maintainer: srid@srid.ca @@ -13,9 +13,6 @@ Haskell static site generator based on Shake, with a delightful development experience. category: Web build-type: Simple -extra-source-files: - README.md - CHANGELOG.md source-repository head type: git @@ -60,25 +57,18 @@ iso8601-time, wai >=3.2.2 && <3.3, wai-app-static >=3.1.6 && <3.2, - warp + warp, + rib-core library import: library-common exposed-modules: Rib - Rib.App - Rib.Cli - Rib.Watch - Rib.Log Rib.Parser.Dhall Rib.Parser.MMark Rib.Parser.Pandoc - Rib.Route - Rib.Shake Rib.Extra.CSS Rib.Extra.OpenGraph - other-modules: - Rib.Server test-suite rib-test import: library-common diff --git a/src/Rib/App.hs b/src/Rib/App.hs deleted file mode 100644 --- a/src/Rib/App.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | CLI interface for Rib. --- --- Mostly you would only need `Rib.App.run`, passing it your Shake build action. -module Rib.App - ( run, - runWith, - ) -where - -import Control.Concurrent.Async (race_) -import Control.Exception.Safe (catch) -import Development.Shake hiding (command) -import Development.Shake.Forward (shakeForward) -import Options.Applicative -import Relude -import Rib.Cli (CliConfig (CliConfig), cliParser) -import qualified Rib.Cli as Cli -import Rib.Log -import qualified Rib.Server as Server -import Rib.Watch (onTreeChange) -import System.Directory -import System.FSNotify (Event (..), eventPath) -import System.FilePath -import System.IO (BufferMode (LineBuffering), hSetBuffering) - --- | Run Rib using arguments passed in the command line. -run :: - -- | Default value for `Cli.inputDir` - FilePath -> - -- | Deault value for `Cli.outputDir` - FilePath -> - -- | Shake build rules for building the static site - Action () -> - IO () -run src dst buildAction = runWith buildAction =<< execParser opts - where - opts = - info - (cliParser src dst <**> helper) - ( fullDesc - <> progDesc "Generate a static site at OUTPUTDIR using input from INPUTDIR" - ) - --- | Like `run` but with an explicitly passed `CliConfig` -runWith :: Action () -> CliConfig -> IO () -runWith buildAction cfg@CliConfig {..} = do - -- For saner output - flip hSetBuffering LineBuffering `mapM_` [stdout, stderr] - case (watch, serve) of - (True, Just (host, port)) -> do - race_ - (Server.serve cfg host port $ outputDir) - (runShakeAndObserve cfg buildAction) - (True, Nothing) -> - runShakeAndObserve cfg buildAction - (False, Just (host, port)) -> - Server.serve cfg host port $ outputDir - (False, Nothing) -> - runShakeBuild cfg buildAction - -shakeOptionsFrom :: CliConfig -> ShakeOptions -shakeOptionsFrom cfg'@CliConfig {..} = - shakeOptions - { shakeVerbosity = verbosity, - shakeFiles = shakeDbDir, - shakeRebuild = bool [] [(RebuildNow, "**")] rebuildAll, - shakeLintInside = [""], - shakeExtra = addShakeExtra cfg' (shakeExtra shakeOptions) - } - -runShakeBuild :: CliConfig -> Action () -> IO () -runShakeBuild cfg@CliConfig {..} buildAction = do - runShake cfg $ do - logStrLn cfg $ "[Rib] Generating " <> inputDir <> " (rebuildAll=" <> show rebuildAll <> ")" - buildAction - -runShake :: CliConfig -> Action () -> IO () -runShake cfg shakeAction = do - shakeForward (shakeOptionsFrom cfg) shakeAction - `catch` handleShakeException - where - handleShakeException (e :: ShakeException) = - -- Gracefully handle any exceptions when running Shake actions. We want - -- Rib to keep running instead of crashing abruptly. - logErr $ - "[Rib] Unhandled exception when building " <> shakeExceptionTarget e <> ": " <> show e - -runShakeAndObserve :: CliConfig -> Action () -> IO () -runShakeAndObserve cfg@CliConfig {..} buildAction = do - -- Begin with a *full* generation as the HTML layout may have been changed. - -- TODO: This assumption is not true when running the program from compiled - -- binary (as opposed to say via ghcid) as the HTML layout has become fixed - -- by being part of the binary. In this scenario, we should not do full - -- generation (i.e., toggle the bool here to False). Perhaps provide a CLI - -- flag to disable this. - runShakeBuild (cfg {Cli.rebuildAll = True}) buildAction - -- And then every time a file changes under the current directory - logStrLn cfg $ "[Rib] Watching " <> inputDir <> " for changes" - onSrcChange $ runShakeBuild cfg buildAction - where - onSrcChange :: IO () -> IO () - onSrcChange f = do - -- Canonicalizing path is important as we are comparing path ancestor using isPrefixOf - dir <- canonicalizePath inputDir - -- Top-level directories to ignore from notifications - let isBlacklisted :: FilePath -> Bool - isBlacklisted p = or $ flip fmap watchIgnore $ \b -> (dir b) `isPrefixOf` p - onTreeChange dir $ \allEvents -> do - let events = filter (not . isBlacklisted . eventPath) allEvents - unless (null events) $ do - -- Log the changed events for diagnosis. - logEvent `mapM_` events - f - logEvent :: Event -> IO () - logEvent e = do - logStrLn cfg $ eventLogPrefix e <> " " <> eventPath e - eventLogPrefix = \case - -- Single character log prefix to indicate file actions is a convention in Rib. - Added _ _ _ -> "A" - Modified _ _ _ -> "M" - Removed _ _ _ -> "D" - Unknown _ _ _ -> "?" diff --git a/src/Rib/Cli.hs b/src/Rib/Cli.hs deleted file mode 100644 --- a/src/Rib/Cli.hs +++ /dev/null @@ -1,166 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -module Rib.Cli - ( CliConfig (..), - cliParser, - Verbosity (..), - - -- * Parser helpers - directoryReader, - watchOption, - serveOption, - - -- * Internal - hostPortParser, - ) -where - -import Development.Shake (Verbosity (..)) -import Options.Applicative -import Relude -import Relude.Extra.Tuple -import System.FilePath -import qualified Text.Megaparsec as M -import qualified Text.Megaparsec.Char as M - --- Rib's CLI configuration --- --- Can be retrieved using `Rib.Shake.getCliConfig` in the `Development.Shake.Action` monad. -data CliConfig - = CliConfig - { -- | Whether to rebuild all sources in Shake. - rebuildAll :: Bool, - -- | Whether to monitor `inputDir` for changes and re-generate - watch :: Bool, - -- | Whether to run a HTTP server on `outputDir` - serve :: Maybe (Text, Int), - -- | Shake's verbosity level. - -- - -- Setting this to `Silent` will affect Rib's own logging as well. - verbosity :: Verbosity, - -- | Directory from which source content will be read. - inputDir :: FilePath, - -- | The path where static files will be generated. Rib's server uses this - -- directory when serving files. - outputDir :: FilePath, - -- | Path to shake's database directory. - shakeDbDir :: FilePath, - -- | List of relative paths to ignore when watching the source directory - watchIgnore :: [FilePath] - } - deriving (Show, Eq, Generic, Typeable) - -cliParser :: FilePath -> FilePath -> Parser CliConfig -cliParser inputDirDefault outputDirDefault = do - rebuildAll <- - switch - ( long "rebuild-all" - <> help "Rebuild all sources" - ) - watch <- watchOption - serve <- serveOption - verbosity <- - fmap - (bool Verbose Silent) - ( switch - ( long "quiet" - <> help "Log nothing" - ) - ) - ~(inputDir, shakeDbDir) <- - fmap (mapToSnd shakeDbDirFrom) $ - option - directoryReader - ( long "input-dir" - <> metavar "INPUTDIR" - <> value inputDirDefault - <> help ("Directory containing the source files (" <> "default: " <> inputDirDefault <> ")") - ) - outputDir <- - option - directoryReader - ( long "output-dir" - <> metavar "OUTPUTDIR" - <> value outputDirDefault - <> help ("Directory where files will be generated (" <> "default: " <> outputDirDefault <> ")") - ) - ~(watchIgnore) <- pure builtinWatchIgnores - pure CliConfig {..} - -watchOption :: Parser Bool -watchOption = - switch - ( long "watch" - <> short 'w' - <> help "Watch for changes and regenerate" - ) - -serveOption :: Parser (Maybe (Text, Int)) -serveOption = - optional - ( option - (megaparsecReader hostPortParser) - ( long "serve" - <> short 's' - <> metavar "[HOST]:PORT" - <> help "Run a HTTP server on the generated directory" - ) - ) - <|> ( fmap (bool Nothing $ Just (defaultHost, 8080)) $ - switch (short 'S' <> help ("Like `-s " <> toString defaultHost <> ":8080`")) - ) - -builtinWatchIgnores :: [FilePath] -builtinWatchIgnores = - [ ".shake", - ".git" - ] - -shakeDbDirFrom :: FilePath -> FilePath -shakeDbDirFrom inputDir = - -- Keep shake database directory under the src directory instead of the - -- (default) current working directory, which may not always be a project - -- root (as in the case of neuron). - inputDir ".shake" - --- | Like `str` but adds a trailing slash if there isn't one. -directoryReader :: ReadM FilePath -directoryReader = fmap addTrailingPathSeparator str - -megaparsecReader :: M.Parsec Void Text a -> ReadM a -megaparsecReader p = - eitherReader (first M.errorBundlePretty . M.parse p "" . toText) - -hostPortParser :: M.Parsec Void Text (Text, Int) -hostPortParser = do - host <- - optional $ - M.string "localhost" - <|> M.try parseIP - void $ M.char ':' - port <- parseNumRange 1 65535 - pure (fromMaybe defaultHost host, port) - where - readNum = maybe (fail "Not a number") pure . readMaybe - parseIP :: M.Parsec Void Text Text - parseIP = do - a <- parseNumRange 0 255 <* M.char '.' - b <- parseNumRange 0 255 <* M.char '.' - c <- parseNumRange 0 255 <* M.char '.' - d <- parseNumRange 0 255 - pure $ toText $ intercalate "." $ show <$> [a, b, c, d] - parseNumRange :: Int -> Int -> M.Parsec Void Text Int - parseNumRange a b = do - n <- readNum =<< M.some M.digitChar - if a <= n && n <= b - then pure n - else fail $ "Number not in range: " <> show a <> "-" <> show b - -defaultHost :: Text -defaultHost = "127.0.0.1" diff --git a/src/Rib/Log.hs b/src/Rib/Log.hs deleted file mode 100644 --- a/src/Rib/Log.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} - -module Rib.Log - ( logStrLn, - logErr, - ) -where - -import Development.Shake (Verbosity (..)) -import Relude -import Rib.Cli (CliConfig (..)) -import System.IO (hPutStrLn) - -logStrLn :: MonadIO m => CliConfig -> String -> m () -logStrLn CliConfig {..} s = - unless (verbosity == Silent) $ do - putStrLn s - -logErr :: MonadIO m => String -> m () -logErr s = - liftIO $ hPutStrLn stderr s diff --git a/src/Rib/Route.hs b/src/Rib/Route.hs deleted file mode 100644 --- a/src/Rib/Route.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | Type-safe routes for static sites. -module Rib.Route - ( -- * Defining routes - IsRoute (..), - - -- * Rendering routes - routeUrl, - routeUrlRel, - - -- * Writing routes - writeRoute, - ) -where - -import Control.Monad.Catch -import Data.Kind -import qualified Data.Text as T -import Development.Shake (Action) -import Relude -import Rib.Shake (writeFileCached) -import System.FilePath - --- | A route is a GADT which represents the individual routes in a static site. --- --- `r` represents the data used to render that particular route. -class IsRoute (r :: Type -> Type) where - -- | Return the filepath (relative to `Rib.Shake.ribInputDir`) where the - -- generated content for this route should be written. - routeFile :: MonadThrow m => r a -> m (FilePath) - -data UrlType = Relative | Absolute - -path2Url :: FilePath -> UrlType -> Text -path2Url fp = toText . \case - Relative -> - fp - Absolute -> - "/" fp - --- | The absolute URL to this route (relative to site root) -routeUrl :: IsRoute r => r a -> Text -routeUrl = routeUrl' Absolute - --- | The relative URL to this route -routeUrlRel :: IsRoute r => r a -> Text -routeUrlRel = routeUrl' Relative - --- | Get the URL to a route -routeUrl' :: IsRoute r => UrlType -> r a -> Text -routeUrl' urlType = stripIndexHtml . flip path2Url urlType . either (error . toText . displayException) id . routeFile - where - stripIndexHtml s = - -- Because path2Url can return relative URL, we must account for there - -- not being a / at the beginning. - if | "/index.html" `T.isSuffixOf` s -> - T.dropEnd (T.length "index.html") s - | s == "index.html" -> - "." - | otherwise -> - s - --- | Write the content `s` to the file corresponding to the given route. --- --- This is similar to `Rib.Shake.writeFileCached`, but takes a route instead of --- a filepath as its argument. -writeRoute :: (IsRoute r, ToString s) => r a -> s -> Action () -writeRoute r content = do - fp <- liftIO $ routeFile r - writeFileCached fp $ toString $ content diff --git a/src/Rib/Server.hs b/src/Rib/Server.hs deleted file mode 100644 --- a/src/Rib/Server.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | Serve generated static files with HTTP -module Rib.Server - ( serve, - ) -where - -import Network.Wai.Application.Static (defaultFileServerSettings, staticApp) -import qualified Network.Wai.Handler.Warp as Warp -import Relude -import Rib.Cli (CliConfig) -import Rib.Log - --- | Run a HTTP server to serve a directory of static files --- --- Binds the server to host 127.0.0.1. -serve :: - CliConfig -> - -- | Host - Text -> - -- | Port number to bind to - Int -> - -- | Directory to serve. - FilePath -> - IO () -serve cfg host port path = do - logStrLn cfg $ "[Rib] Serving " <> path <> " at http://" <> toString host <> ":" <> show port - Warp.runSettings settings app - where - app = staticApp $ defaultFileServerSettings path - settings = - Warp.setHost (fromString $ toString host) - $ Warp.setPort port - $ Warp.defaultSettings diff --git a/src/Rib/Shake.hs b/src/Rib/Shake.hs deleted file mode 100644 --- a/src/Rib/Shake.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} - --- | Combinators for working with Shake. -module Rib.Shake - ( -- * Basic helpers - buildStaticFiles, - forEvery, - - -- * Writing only - writeFileCached, - - -- * Misc - getCliConfig, - ribInputDir, - ribOutputDir, - ) -where - -import Control.Monad.Catch -import Development.Shake -import Relude -import Rib.Cli (CliConfig) -import qualified Rib.Cli as Cli -import System.Directory -import System.FilePath -import System.IO.Error (isDoesNotExistError) - --- | Get rib settings from a shake Action monad. -getCliConfig :: Action CliConfig -getCliConfig = getShakeExtra >>= \case - Just v -> pure v - Nothing -> fail "CliConfig not initialized" - --- | Input directory containing source files --- --- This is same as the first argument to `Rib.App.run` -ribInputDir :: Action FilePath -ribInputDir = Cli.inputDir <$> getCliConfig - --- | Output directory where files are generated --- --- This is same as the second argument to `Rib.App.run` -ribOutputDir :: Action FilePath -ribOutputDir = do - output <- Cli.outputDir <$> getCliConfig - liftIO $ createDirectoryIfMissing True output - return output - --- | Shake action to copy static files as is. -buildStaticFiles :: [FilePath] -> Action () -buildStaticFiles staticFilePatterns = do - input <- ribInputDir - output <- ribOutputDir - files <- getDirectoryFiles input staticFilePatterns - void $ forP files $ \f -> - copyFileChanged (input f) (output f) - --- | Run the given action when any file matching the patterns changes -forEvery :: - -- | Source file patterns (relative to `ribInputDir`) - [FilePath] -> - (FilePath -> Action a) -> - Action [a] -forEvery pats f = do - input <- ribInputDir - fs <- getDirectoryFiles input pats - forP fs f - --- | Write the given file but only when it has been modified. --- --- Also, always writes under ribOutputDir -writeFileCached :: FilePath -> String -> Action () -writeFileCached !k !s = do - f <- fmap ( k) ribOutputDir - currentS <- liftIO $ forgivingAbsence $ readFile f - unless (Just s == currentS) $ do - writeFile' f $! s - -- Use a character (like +) that contrasts with what Shake uses (#) for - -- logging modified files being read. - putInfo $ "+ " <> f - --- | If argument of the function throws a --- 'System.IO.Error.doesNotExistErrorType', 'Nothing' is returned (other --- exceptions propagate). Otherwise the result is returned inside a 'Just'. -forgivingAbsence :: (MonadIO m, MonadCatch m) => m a -> m (Maybe a) -forgivingAbsence f = - catchIf - isDoesNotExistError - (Just <$> f) - (const $ return Nothing) diff --git a/src/Rib/Watch.hs b/src/Rib/Watch.hs deleted file mode 100644 --- a/src/Rib/Watch.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | Filesystem watching using fsnotify -module Rib.Watch - ( onTreeChange, - ) -where - -import Control.Concurrent (threadDelay) -import Control.Concurrent.Async (race) -import Control.Concurrent.Chan -import Relude -import System.FSNotify (Event (..), watchTreeChan, withManager) - --- | Recursively monitor the contents of the given path and invoke the given IO --- action for every event triggered. --- --- If multiple events fire rapidly, the IO action is invoked only once, taking --- those multiple events as its argument. -onTreeChange :: FilePath -> ([Event] -> IO ()) -> IO () -onTreeChange fp f = do - withManager $ \mgr -> do - eventCh <- newChan - void $ watchTreeChan mgr fp (const True) eventCh - forever $ do - firstEvent <- readChan eventCh - events <- debounce 100 [firstEvent] $ readChan eventCh - f events - -debounce :: Int -> [event] -> IO event -> IO [event] -debounce millies events f = do - -- Race the readEvent against the timelimit. - race f (threadDelay (1000 * millies)) >>= \case - Left event -> - -- If the read event finishes first try again. - debounce millies (events <> [event]) f - Right () -> - -- Otherwise continue - return events