treefmt: Ensure all Haskell files are formatted with ormolu

Haskell has various formatters and no standard one. I'm picking ormolu because it's closest in spirit to the new nixfmt (only one style with very limited configurability).
Infinisil-s-Test-Organization · Apr 4, 2024 · a672847 · a672847
1 parent fafeaad
commit a672847
Show file tree

Hide file tree

Showing 12 changed files with 1,889 additions and 1,620 deletions.
diff --git a/default.nix b/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.ormolu.enable = true;
   };
 in
 build

diff --git a/main/Main.hs b/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)
+  ( 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
-              "Apply sanity checks on the output after formatting"
-        } &=
-      summary ("nixfmt v" ++ showVersion version) &=
-      help "Format Nix source code"
+        { 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"
 
 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
+formatTarget format Target {tDoRead, tPath, tDoWrite} = do
+  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"
+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"
 
 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
diff --git a/main/System/IO/Atomic.hs b/main/System/IO/Atomic.hs
@@ -6,8 +6,9 @@
 -- 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
+  ( 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