treefmt: Ensure all Haskell files are formatted with fourmolu

Haskell has various formatters and no standard one.
While I originally wanted to use ormolu, we agreed to switch to fourmolu
because we weren't super happy about some decisions in ormolu.

default.nix

@@ -49,6 +49,9 @@ let
     programs.nixfmt-rfc-style.enable = true;
     # We don't want to format the files we use to test the formatter!
     settings.formatter.nixfmt-rfc-style.excludes = [ "test/*" ];
+
+    # Haskell formatter
+    programs.fourmolu.enable = true;
   };
 in
 build

fourmolu.yaml

@@ -0,0 +1,51 @@
+# Number of spaces per indentation step
+indentation: 2
+
+# Max line length for automatic line breaking
+column-limit: none
+
+# Styling of arrows in type signatures (choices: trailing, leading, or leading-args)
+function-arrows: trailing
+
+# How to place commas in multi-line lists, records, etc. (choices: leading or trailing)
+comma-style: trailing
+
+# Styling of import/export lists (choices: leading, trailing, or diff-friendly)
+import-export-style: diff-friendly
+
+# Whether to full-indent or half-indent 'where' bindings past the preceding body
+indent-wheres: true
+
+# Whether to leave a space before an opening record brace
+record-brace-space: false
+
+# Number of spaces between top-level declarations
+newlines-between-decls: 1
+
+# How to print Haddock comments (choices: single-line, multi-line, or multi-line-compact)
+haddock-style: single-line
+
+# How to print module docstring
+haddock-style-module: null
+
+# Styling of let blocks (choices: auto, inline, newline, or mixed)
+let-style: inline
+
+# How to align the 'in' keyword with respect to the 'let' keyword (choices: left-align, right-align, or no-space)
+in-style: no-space
+
+# Whether to put parentheses around a single constraint (choices: auto, always, or never)
+single-constraint-parens: always
+
+# Output Unicode syntax (choices: detect, always, or never)
+unicode: never
+
+# Give the programmer more choice on where to insert blank lines
+respectful: true
+
+# Fixity information for operators
+fixities: []
+
+# Module reexports Fourmolu should know about
+reexports: []
+

main/Main.hs

@@ -1,97 +1,108 @@
-{-# LANGUAGE DeriveDataTypeable, NamedFieldPuns, MultiWayIf #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NamedFieldPuns #-}
 
 module Main where
 
 import Control.Concurrent (Chan, forkIO, newChan, readChan, writeChan)
 import Data.Either (lefts)
-import Data.Text (Text)
 import Data.List (isSuffixOf)
+import Data.Text (Text)
+import qualified Data.Text.IO as TextIO (getContents, hPutStr, putStr)
 import Data.Version (showVersion)
 import GHC.IO.Encoding (utf8)
+import qualified Nixfmt
 import Paths_nixfmt (version)
-import System.Console.CmdArgs
-  (Data, Typeable, args, cmdArgs, help, summary, typ, (&=))
-import System.Exit (ExitCode(..), exitFailure, exitSuccess)
+import System.Console.CmdArgs (
+  Data,
+  Typeable,
+  args,
+  cmdArgs,
+  help,
+  summary,
+  typ,
+  (&=),
+ )
+import System.Directory (doesDirectoryExist, listDirectory)
+import System.Exit (ExitCode (..), exitFailure, exitSuccess)
 import System.FilePath ((</>))
 import System.IO (hPutStrLn, hSetEncoding, stderr)
-import System.Posix.Process (exitImmediately)
-import System.Posix.Signals (Handler(..), installHandler, keyboardSignal)
-import System.Directory (listDirectory, doesDirectoryExist)
-
-import qualified Data.Text.IO as TextIO (getContents, hPutStr, putStr)
-
-import qualified Nixfmt
 import System.IO.Atomic (withOutputFile)
 import System.IO.Utf8 (readFileUtf8, withUtf8StdHandles)
+import System.Posix.Process (exitImmediately)
+import System.Posix.Signals (Handler (..), installHandler, keyboardSignal)
 
 type Result = Either String ()
+
 type Width = Int
 
 data Nixfmt = Nixfmt
-    { files :: [FilePath]
-    , width :: Width
-    , check :: Bool
-    , quiet :: Bool
-    , verify :: Bool
-    } deriving (Show, Data, Typeable)
+  { files :: [FilePath],
+    width :: Width,
+    check :: Bool,
+    quiet :: Bool,
+    verify :: Bool
+  }
+  deriving (Show, Data, Typeable)
 
 options :: Nixfmt
 options =
   let defaultWidth = 100
       addDefaultHint value message =
         message ++ "\n[default: " ++ show value ++ "]"
-   in Nixfmt
-        { files = [] &= args &= typ "FILES"
-        , width =
-            defaultWidth &=
-            help (addDefaultHint defaultWidth "Maximum width in characters")
-        , check = False &= help "Check whether files are formatted without modifying them"
-        , quiet = False &= help "Do not report errors"
-        , verify =
-            False &=
-            help
+  in Nixfmt
+      { files = [] &= args &= typ "FILES",
+        width =
+          defaultWidth
+            &= help (addDefaultHint defaultWidth "Maximum width in characters"),
+        check = False &= help "Check whether files are formatted without modifying them",
+        quiet = False &= help "Do not report errors",
+        verify =
+          False
+            &= help
               "Apply sanity checks on the output after formatting"
-        } &=
-      summary ("nixfmt v" ++ showVersion version) &=
-      help "Format Nix source code"
+      }
+      &= summary ("nixfmt v" ++ showVersion version)
+      &= help "Format Nix source code"
 
 data Target = Target
-    { tDoRead :: IO Text
-    , tPath :: FilePath
-      -- The bool is true when the formatted file differs from the input
-    , tDoWrite :: Bool -> Text -> IO ()
-    }
+  { tDoRead :: IO Text,
+    tPath :: FilePath,
+    -- The bool is true when the formatted file differs from the input
+    tDoWrite :: Bool -> Text -> IO ()
+  }
 
 -- | Recursively collect nix files in a directory
 collectNixFiles :: FilePath -> IO [FilePath]
 collectNixFiles path = do
   dir <- doesDirectoryExist path
-  if | dir -> do
-         files <- listDirectory path
-         concat <$> mapM collectNixFiles ((path </>) <$> files)
-     | ".nix" `isSuffixOf` path -> pure [path]
-     | otherwise -> pure []
+  if
+    | dir -> do
+        files <- listDirectory path
+        concat <$> mapM collectNixFiles ((path </>) <$> files)
+    | ".nix" `isSuffixOf` path -> pure [path]
+    | otherwise -> pure []
 
 -- | Recursively collect nix files in a list of directories
 collectAllNixFiles :: [FilePath] -> IO [FilePath]
 collectAllNixFiles paths = concat <$> mapM collectNixFiles paths
 
 formatTarget :: Formatter -> Target -> IO Result
 formatTarget format Target{tDoRead, tPath, tDoWrite} = do
-    contents <- tDoRead
-    let formatResult = format tPath contents
-    mapM (\formatted -> tDoWrite (formatted /= contents) formatted) formatResult
+  contents <- tDoRead
+  let formatResult = format tPath contents
+  mapM (\formatted -> tDoWrite (formatted /= contents) formatted) formatResult
 
 -- | Return an error if target could not be parsed or was not formatted
 -- correctly.
 checkTarget :: Formatter -> Target -> IO Result
 checkTarget format Target{tDoRead, tPath} = do
-    contents <- tDoRead
-    return $ case format tPath contents of
-        Left err -> Left err
-        Right formatted
-            | formatted == contents -> Right ()
-            | otherwise             -> Left $ tPath ++ ": not formatted"
+  contents <- tDoRead
+  return $ case format tPath contents of
+    Left err -> Left err
+    Right formatted
+      | formatted == contents -> Right ()
+      | otherwise -> Left $ tPath ++ ": not formatted"
 
 stdioTarget :: Target
 stdioTarget = Target TextIO.getContents "<stdin>" (const TextIO.putStr)
@@ -109,26 +120,26 @@ checkFileTarget :: FilePath -> Target
 checkFileTarget path = Target (readFileUtf8 path) path (const $ const $ pure ())
 
 toTargets :: Nixfmt -> IO [Target]
-toTargets Nixfmt{ files = [] }    = pure [stdioTarget]
-toTargets Nixfmt{ files = ["-"] } = pure [stdioTarget]
-toTargets Nixfmt{ check = False, files = paths } = map fileTarget <$> collectAllNixFiles paths
-toTargets Nixfmt{ check = True, files = paths } = map checkFileTarget <$> collectAllNixFiles paths
+toTargets Nixfmt{files = []} = pure [stdioTarget]
+toTargets Nixfmt{files = ["-"]} = pure [stdioTarget]
+toTargets Nixfmt{check = False, files = paths} = map fileTarget <$> collectAllNixFiles paths
+toTargets Nixfmt{check = True, files = paths} = map checkFileTarget <$> collectAllNixFiles paths
 
 type Formatter = FilePath -> Text -> Either String Text
 
 toFormatter :: Nixfmt -> Formatter
-toFormatter Nixfmt{ width, verify = True  } = Nixfmt.formatVerify width
-toFormatter Nixfmt{ width, verify = False } = Nixfmt.format width
+toFormatter Nixfmt{width, verify = True} = Nixfmt.formatVerify width
+toFormatter Nixfmt{width, verify = False} = Nixfmt.format width
 
 type Operation = Formatter -> Target -> IO Result
 
 toOperation :: Nixfmt -> Operation
-toOperation Nixfmt{ check = True } = checkTarget
-toOperation Nixfmt{ } = formatTarget
+toOperation Nixfmt{check = True} = checkTarget
+toOperation Nixfmt{} = formatTarget
 
 toWriteError :: Nixfmt -> String -> IO ()
-toWriteError Nixfmt{ quiet = False } = hPutStrLn stderr
-toWriteError Nixfmt{ quiet = True } = const $ return ()
+toWriteError Nixfmt{quiet = False} = hPutStrLn stderr
+toWriteError Nixfmt{quiet = True} = const $ return ()
 
 toJobs :: Nixfmt -> IO [IO Result]
 toJobs opts = map (toOperation opts $ toFormatter opts) <$> toTargets opts
@@ -141,36 +152,39 @@ doParallel = sequence
 
 errorWriter :: (String -> IO ()) -> Chan (Maybe String) -> Chan () -> IO ()
 errorWriter doWrite chan done = do
-    item <- readChan chan
-    case item of
-         Nothing  -> return ()
-         Just msg -> doWrite msg >> errorWriter doWrite chan done
-    writeChan done ()
+  item <- readChan chan
+  case item of
+    Nothing -> return ()
+    Just msg -> doWrite msg >> errorWriter doWrite chan done
+  writeChan done ()
 
 writeErrorBundle :: Chan (Maybe String) -> Result -> IO Result
 writeErrorBundle chan result = do
-    case result of
-         Right () -> return ()
-         Left err -> writeChan chan $ Just err
-    return result
+  case result of
+    Right () -> return ()
+    Left err -> writeChan chan $ Just err
+  return result
 
 -- | Run a list of jobs and write errors to stderr without interleaving them.
 runJobs :: (String -> IO ()) -> [IO Result] -> IO [Result]
 runJobs writeError jobs = do
-    errChan <- newChan
-    doneChan <- newChan
-    _ <- forkIO $ errorWriter writeError errChan doneChan
-    results <- doParallel $ map (>>= writeErrorBundle errChan) jobs
-    writeChan errChan Nothing
-    _ <- readChan doneChan
-    return results
+  errChan <- newChan
+  doneChan <- newChan
+  _ <- forkIO $ errorWriter writeError errChan doneChan
+  results <- doParallel $ map (>>= writeErrorBundle errChan) jobs
+  writeChan errChan Nothing
+  _ <- readChan doneChan
+  return results
 
 main :: IO ()
 main = withUtf8StdHandles $ do
-    _ <- installHandler keyboardSignal
-            (Catch (exitImmediately $ ExitFailure 2)) Nothing
-    opts <- cmdArgs options
-    results <- runJobs (toWriteError opts) =<< toJobs opts
-    case lefts results of
-         [] -> exitSuccess
-         _  -> exitFailure
+  _ <-
+    installHandler
+      keyboardSignal
+      (Catch (exitImmediately $ ExitFailure 2))
+      Nothing
+  opts <- cmdArgs options
+  results <- runJobs (toWriteError opts) =<< toJobs opts
+  case lefts results of
+    [] -> exitSuccess
+    _ -> exitFailure

main/System/IO/Atomic.hs

@@ -5,9 +5,10 @@
 --
 -- This module is a crossover of the `atomic-write` and `safeio` libraries
 -- with the fs-related behaviour of the first and interface of the second.
-module System.IO.Atomic
-  ( withOutputFile
-  ) where
+module System.IO.Atomic (
+  withOutputFile,
+)
+where
 
 import Control.Exception.Safe (mask, onException)
 import Control.Monad (when)
@@ -16,7 +17,6 @@ import System.FilePath (takeDirectory, takeFileName)
 import System.IO (Handle, hClose, openTempFileWithDefaultPermissions)
 import System.Posix.Files (fileMode, getFileStatus, setFileMode)
 
-
 -- | Like @withFile@ but replaces the contents atomically.
 --
 -- This function allocates a temporary file and provides its handle to the
@@ -28,12 +28,14 @@ import System.Posix.Files (fileMode, getFileStatus, setFileMode)
 -- the attributes is a challenge. This function tries its best, but currently
 -- it is Unix-specific and there is definitely room for improvement even on Unix.
 withOutputFile ::
-     FilePath  -- ^ Final file path
-  -> (Handle -> IO a)  -- ^ IO action that writes to the file
-  -> IO a
+  -- | Final file path
+  FilePath ->
+  -- | IO action that writes to the file
+  (Handle -> IO a) ->
+  IO a
 withOutputFile path act = transact begin commit rollback $ \(tpath, th) -> do
-    copyAttributes (tpath, th)
-    act th
+  copyAttributes (tpath, th)
+  act th
   where
     tmpDir = takeDirectory path
     tmpTemplate = "." <> takeFileName path <> ".atomic"
@@ -56,8 +58,6 @@ withOutputFile path act = transact begin commit rollback $ \(tpath, th) -> do
     rollback :: (FilePath, Handle) -> IO ()
     rollback (tpath, th) = hClose th *> removeFile tpath
 
-
-
 ---
 -- Helpers
 --
@@ -72,11 +72,15 @@ withOutputFile path act = transact begin commit rollback $ \(tpath, th) -> do
 -- here, if the action completes but commit fails, we will still run rollback,
 -- so there exists an execution in which both finalisation actions are run.
 transact ::
-     IO a         -- ^ computation to run first (\"begin transaction\")
-  -> (a -> IO b)  -- ^ computation to run on success (\"commit transaction\")
-  -> (a -> IO c)  -- ^ computation to run on failure (\"rollback transaction\")
-  -> (a -> IO d)  -- ^ computation to run in-between
-  -> IO d         -- returns the value from the in-between computation
+  -- | computation to run first (\"begin transaction\")
+  IO a ->
+  -- | computation to run on success (\"commit transaction\")
+  (a -> IO b) ->
+  -- | computation to run on failure (\"rollback transaction\")
+  (a -> IO c) ->
+  -- | computation to run in-between
+  (a -> IO d) ->
+  IO d -- returns the value from the in-between computation
 transact begin commit rollback act =
   mask $ \restore -> do
     a <- begin