Fix compilation errors

- Remove nonexistent confDebounce field from WatchConfig (fsnotify 0.4.4.0) - Remove unused Generic deriving and GHC.Generics import - Replace .!= with fromMaybe (not re-exported by Data.Yaml) - Add missing Data.Text import in Main.hs - Use git -C flag in runGitIn to run in the correct repo directory - Clean up unused imports
2026-05-11 10:04:44 -04:00
parent eb77e7c0e6
commit 77c6de303f
26 changed files with 2503 additions and 173 deletions
@@ -1,5 +1,5 @@
-module Converge
-  ( -- * Core types
+module Converge (
+    -- * Core types
    Options (..),
    RepoConfig (..),
    defaultOptions,
@@ -20,7 +20,7 @@ module Converge

    -- * Notifications
    notifyConflict,
-  )
+)
 where

 import Control.Concurrent (threadDelay)
@@ -31,53 +31,52 @@ import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Yaml (FromJSON (..), decodeFileThrow, withObject, (.:), (.:?))
-import GHC.Generics (Generic)
 import System.Directory (getCurrentDirectory)
 import System.Exit (ExitCode (..))
-import System.FilePath (isAbsolute, (</>))
 import System.FSNotify
+import System.FilePath (isAbsolute, (</>))
 import System.IO (hPutStrLn, stderr)
 import System.Process (readProcessWithExitCode, spawnProcess)

 -- | Configuration for a single repository to watch.
 data RepoConfig = RepoConfig
-  { rcPath :: !FilePath
-  -- ^ Path to the git repository.
-  , rcRemote :: !Text
-  -- ^ Remote name to pull from.
-  , rcBranch :: !Text
-  -- ^ Branch to pull.
-  }
-  deriving (Show, Eq)
+    { rcPath :: !FilePath
+    -- ^ Path to the git repository.
+    , rcRemote :: !Text
+    -- ^ Remote name to pull from.
+    , rcBranch :: !Text
+    -- ^ Branch to pull.
+    }
+    deriving (Show, Eq)

 -- | Top-level options for converge.
 data Options = Options
-  { optRepos :: ![RepoConfig]
-  -- ^ Repositories to watch.
-  , optDebounceMs :: !Int
-  -- ^ Debounce window in milliseconds.
-  , optNotifyCmd :: !Text
-  -- ^ Command used for desktop notifications.
-  }
-  deriving (Show, Eq)
+    { optRepos :: ![RepoConfig]
+    -- ^ Repositories to watch.
+    , optDebounceMs :: !Int
+    -- ^ Debounce window in milliseconds.
+    , optNotifyCmd :: !Text
+    -- ^ Command used for desktop notifications.
+    }
+    deriving (Show, Eq)

 -- | Sensible defaults for a single repo (cwd, origin, main).
 defaultRepoConfig :: RepoConfig
 defaultRepoConfig =
-  RepoConfig
-    { rcPath = "."
-    , rcRemote = "origin"
-    , rcBranch = "main"
-    }
+    RepoConfig
+        { rcPath = "."
+        , rcRemote = "origin"
+        , rcBranch = "main"
+        }

 -- | Sensible defaults for options.
 defaultOptions :: Options
 defaultOptions =
-  Options
-    { optRepos = [defaultRepoConfig]
-    , optDebounceMs = 5000
-    , optNotifyCmd = "notify-send"
-    }
+    Options
+        { optRepos = [defaultRepoConfig]
+        , optDebounceMs = 5000
+        , optNotifyCmd = "notify-send"
+        }

 ----------------------------------------------------------------------
 -- Config file (YAML)
@@ -85,23 +84,23 @@ defaultOptions =

 -- | Shape of the optional YAML config file.
 data Config = Config
-  { cfgRepos :: ![RepoConfig]
-  , cfgDebounceMs :: !(Maybe Int)
-  }
-  deriving (Show, Eq, Generic)
+    { cfgRepos :: ![RepoConfig]
+    , cfgDebounceMs :: !(Maybe Int)
+    }
+    deriving (Show, Eq)

 instance FromJSON Config where
-  parseJSON = withObject "Config" $ \o ->
-    Config
-      <$> o .: "repos"
-      <*> o .:? "debounce_ms"
+    parseJSON = withObject "Config" $ \o ->
+        Config
+            <$> o .: "repos"
+            <*> o .:? "debounce_ms"

 instance FromJSON RepoConfig where
-  parseJSON = withObject "RepoConfig" $ \o ->
-    RepoConfig
-      <$> o .: "path"
-      <*> o .:? "remote" .!= "origin"
-      <*> o .:? "branch" .!= "main"
+    parseJSON = withObject "RepoConfig" $ \o ->
+        RepoConfig
+            <$> o .: "path"
+            <*> (fromMaybe "origin" <$> o .:? "remote")
+            <*> (fromMaybe "main" <$> o .:? "branch")

 -- | Load a YAML config file.
 loadConfig :: FilePath -> IO Config
@@ -110,10 +109,10 @@ loadConfig = decodeFileThrow
 -- | Convert a Config to Options (filling in defaults).
 configToOptions :: Config -> Options
 configToOptions cfg =
-  defaultOptions
-    { optRepos = cfgRepos cfg
-    , optDebounceMs = fromMaybe 5000 (cfgDebounceMs cfg)
-    }
+    defaultOptions
+        { optRepos = cfgRepos cfg
+        , optDebounceMs = fromMaybe 5000 (cfgDebounceMs cfg)
+        }

 ----------------------------------------------------------------------
 -- Running
@@ -122,37 +121,37 @@ configToOptions cfg =
 -- | Watch all configured repositories concurrently.
 runConverge :: Options -> IO ()
 runConverge opts =
-  mapConcurrently_ (watchRepo opts) (optRepos opts)
+    mapConcurrently_ (watchRepo opts) (optRepos opts)

 watchRepo :: Options -> RepoConfig -> IO ()
 watchRepo opts repo = do
-  absPath <- resolvePath (rcPath repo)
-  let debounceUs = optDebounceMs opts * 1000
-  bracket
-    (startManagerConf defaultConfig {confDebounce = NoDebounce})
-    stopManager
-    $ \mgr -> do
-      _ <- watchDir mgr absPath (const True) $ \_event -> do
-        threadDelay debounceUs
-        syncRepo opts repo
-      forever $ threadDelay maxBound
+    absPath <- resolvePath (rcPath repo)
+    let debounceUs = optDebounceMs opts * 1000
+    bracket
+        (startManagerConf defaultConfig)
+        stopManager
+        $ \mgr -> do
+            _ <- watchDir mgr absPath (const True) $ \_event -> do
+                threadDelay debounceUs
+                syncRepo opts repo
+            forever $ threadDelay maxBound
  where
    resolvePath p
-      | isAbsolute p = pure p
-      | otherwise = (</> p) <$> getCurrentDirectory
+        | isAbsolute p = pure p
+        | otherwise = (</> p) <$> getCurrentDirectory

 -- | Run a full sync cycle on a single repo: commit + pull + conflict check.
 syncRepo :: Options -> RepoConfig -> IO ()
 syncRepo opts repo = do
-  (commitCode, _, commitErr) <- gitCommitAll (rcPath repo)
-  unless (commitCode == ExitSuccess) $
-    hPutStrLn stderr ("[" <> rcPath repo <> "] git commit failed: " <> show commitErr)
-  (pullCode, _, pullErr) <- gitPull repo
-  unless (pullCode == ExitSuccess) $
-    hPutStrLn stderr ("[" <> rcPath repo <> "] git pull failed: " <> show pullErr)
-  conflicted <- hasConflicts (rcPath repo)
-  when conflicted $
-    notifyConflict opts repo
+    (commitCode, _, commitErr) <- gitCommitAll (rcPath repo)
+    unless (commitCode == ExitSuccess) $
+        hPutStrLn stderr ("[" <> rcPath repo <> "] git commit failed: " <> show commitErr)
+    (pullCode, _, pullErr) <- gitPull repo
+    unless (pullCode == ExitSuccess) $
+        hPutStrLn stderr ("[" <> rcPath repo <> "] git pull failed: " <> show pullErr)
+    conflicted <- hasConflicts (rcPath repo)
+    when conflicted $
+        notifyConflict opts repo

 ----------------------------------------------------------------------
 -- Git operations
@@ -161,22 +160,23 @@ syncRepo opts repo = do
 -- | Stage all changes and commit with an auto-generated message.
 gitCommitAll :: FilePath -> IO (ExitCode, Text, Text)
 gitCommitAll repoPath = do
-  (_, _, stageErr) <- runGitIn repoPath ["add", "-A"]
-  unless (T.null stageErr) $
-    hPutStrLn stderr ("git add stderr: " <> T.unpack stageErr)
-  runGitIn repoPath ["commit", "-m", "converge: auto-commit"]
+    (_, _, stageErr) <- runGitIn repoPath ["add", "-A"]
+    unless (T.null stageErr) $
+        hPutStrLn stderr ("git add stderr: " <> T.unpack stageErr)
+    runGitIn repoPath ["commit", "-m", "converge: auto-commit"]

 -- | Pull from the configured remote and branch.
 gitPull :: RepoConfig -> IO (ExitCode, Text, Text)
 gitPull repo =
-  runGitIn (rcPath repo)
-    ["pull", "--no-edit", T.unpack (rcRemote repo), T.unpack (rcBranch repo)]
+    runGitIn
+        (rcPath repo)
+        ["pull", "--no-edit", T.unpack (rcRemote repo), T.unpack (rcBranch repo)]

 -- | Check if the repository currently has merge conflicts.
 hasConflicts :: FilePath -> IO Bool
 hasConflicts repoPath = do
-  (_, diffOut, _) <- runGitIn repoPath ["diff", "--check"]
-  pure $ any (`T.isInfixOf` diffOut) ["<<<<<<<", "=======", ">>>>>>>"]
+    (_, diffOut, _) <- runGitIn repoPath ["diff", "--check"]
+    pure $ any (`T.isInfixOf` diffOut) ["<<<<<<<", "=======", ">>>>>>>"]

 ----------------------------------------------------------------------
 -- Notifications
@@ -185,12 +185,14 @@ hasConflicts repoPath = do
 -- | Send a desktop notification about a merge conflict.
 notifyConflict :: Options -> RepoConfig -> IO ()
 notifyConflict opts repo = do
-  let cmd = T.unpack (optNotifyCmd opts)
-      title = "Converge: Merge Conflict"
-      body = "A merge conflict occurred in " <> T.pack (rcPath repo)
-        <> ". Manual resolution required."
-  _ <- spawnProcess cmd ["--urgency=critical", title, T.unpack body]
-  pure ()
+    let cmd = T.unpack (optNotifyCmd opts)
+        title = "Converge: Merge Conflict"
+        body =
+            "A merge conflict occurred in "
+                <> T.pack (rcPath repo)
+                <> ". Manual resolution required."
+    _ <- spawnProcess cmd ["--urgency=critical", title, T.unpack body]
+    pure ()

 ----------------------------------------------------------------------
 -- Internal helpers
@@ -198,5 +200,5 @@ notifyConflict opts repo = do

 runGitIn :: FilePath -> [String] -> IO (ExitCode, Text, Text)
 runGitIn repoPath args = do
-  (code, out, err) <- readProcessWithExitCode "git" args ""
-  pure (code, T.pack out, T.pack err)
+    (code, out, err) <- readProcessWithExitCode "git" ("-C" : repoPath : args) ""
+    pure (code, T.pack out, T.pack err)