More readable Display instance for ProcessingError

Kleidukos · Jan 6, 2025 · acd902c · acd902c
1 parent 8ee38e4
commit acd902c
Show file tree

Hide file tree

Showing 4 changed files with 45 additions and 52 deletions.
diff --git a/app/Main.hs b/app/Main.hs
@@ -4,15 +4,14 @@ import Control.Monad (when)
 import Data.Aeson qualified as Aeson
 import Data.Function ((&))
 import Data.Text (Text)
-import Data.Text qualified as Text
 import Data.Text.Display (display)
+import Data.Text.IO qualified
 import Data.Vector (Vector)
 import Data.Vector qualified as Vector
 import Data.Vector.NonEmpty qualified as NEVector
 import Data.Version qualified
 import Distribution.Parsec (parsec, runParsecParser)
 import Distribution.Parsec.FieldLineStream (fieldLineStreamFromString)
-import Distribution.Pretty (prettyShow)
 import Distribution.Types.Version (Version)
 import Effectful
 import Effectful.Console.ByteString (Console)
@@ -30,6 +29,7 @@ import GetTested.Extract
 import GetTested.Types
 import Paths_get_tested (version)
 
+
 main :: IO ()
 main = do
   cmd <- execParser (parser `withInfo` "Generate a test matrix from the tested-with stanza of your cabal file")
@@ -38,24 +38,8 @@ main = do
     GenerateCommand options -> generate options
   case processingResult of
     Right () -> pure ()
-    Left (CabalFileNotFound path) -> do
-      putStrLn $ "get-tested: Could not find cabal file at path " <> path
-      exitFailure
-    Left (CabalFileCouldNotBeParsed path) -> do
-      putStrLn $ "get-tested: Could not parse cabal file at path " <> path
-      exitFailure
-    Left (NoCompilerVersionsFound path) -> do
-      putStrLn $ "get-tested: No compilers found in " <> path
-      exitFailure
-    Left (IncompatibleOptions opt1 opt2) -> do
-      putStrLn $ Text.unpack $ "get-tested: Incompatible options: " <> opt1 <> " and " <> opt2 <> " cannot be passed simultaneously."
-      exitFailure
-    Left (VersionCheckFailed path failures) -> do
-      putStrLn $
-        "get-tested: Check for "
-          <> path
-          <> " failed:"
-          <> foldMap (\compiler -> "\n  " <> prettyShow compiler) failures
+    Left err -> do
+      Data.Text.IO.putStrLn $ "get-tested: " <> display err
       exitFailure
 
 parser :: Parser Command
@@ -100,7 +84,7 @@ generateOptionsParser =
     <*> switch (long "oldest" <> help "Enable only the oldest GHC version found in the cabal file")
 
 check
-  :: (Console :> es, Error ProcessingError :> es, FileSystem :> es)
+  :: (Error ProcessingError :> es, FileSystem :> es)
   => CheckOptions -> Eff es ()
 check options = do
   compilers <- extractTestedWith <$> loadFile options.checkOptionsPath

diff --git a/get-tested.cabal b/get-tested.cabal
@@ -60,16 +60,17 @@ library
     GetTested.Types
 
   build-depends:
-    , aeson            ^>=2.2
-    , base             ^>=4.19
-    , bytestring       ^>=0.11
-    , Cabal-syntax     ^>=3.10.3
-    , effectful        ^>=2.3
-    , effectful-core   ^>=2.3
-    , nonempty-vector  ^>=0.2.3
-    , text             ^>=2.1
-    , text-display     ^>=0.0.1
-    , vector           ^>=0.13
+    , aeson               ^>=2.2
+    , base                ^>=4.19
+    , bytestring          ^>=0.11
+    , Cabal-syntax        ^>=3.10.3
+    , effectful           ^>=2.3
+    , effectful-core      ^>=2.3
+    , nonempty-vector     ^>=0.2.3
+    , text                ^>=2.1
+    , text-builder-linear ^>=0.1
+    , text-display        ^>=1.0
+    , vector              ^>=0.13
 
 executable get-tested
   import:         extensions
@@ -87,7 +88,7 @@ executable get-tested
     , nonempty-vector       ^>=0.2.3
     , optparse-applicative  ^>=0.18
     , text                  ^>=2.1
-    , text-display          ^>=0.0.1
+    , text-display          ^>=1.0
     , vector                ^>=0.13
 
   hs-source-dirs: app

diff --git a/src/GetTested/Extract.hs b/src/GetTested/Extract.hs
@@ -10,9 +10,6 @@ module GetTested.Extract
 import Control.Monad
 import Data.ByteString qualified as BS
 import Data.Function ((&))
-import Data.Text (Text)
-import Data.Text.Display (display)
-import Data.Text.Encoding qualified as Text
 import Data.Vector (Vector)
 import Data.Vector qualified as Vector
 import Data.Vector.NonEmpty (NonEmptyVector)
@@ -24,8 +21,6 @@ import Distribution.PackageDescription.Parsec
 import Distribution.Types.Version (Version)
 import Distribution.Types.VersionRange.Internal (VersionRange (..))
 import Effectful
-import Effectful.Console.ByteString (Console)
-import Effectful.Console.ByteString qualified as Console
 import Effectful.Error.Static (Error, throwError)
 import Effectful.FileSystem (FileSystem)
 import Effectful.FileSystem qualified as FileSystem
@@ -36,20 +31,19 @@ import GetTested.Types
 
 -- | Loads and parses a Cabal file
 loadFile
-  :: (Console :> es, FileSystem :> es, Error ProcessingError :> es)
+  :: (FileSystem :> es, Error ProcessingError :> es)
   => FilePath
   -- ^ The absolute path to the Cabal file
   -> Eff es GenericPackageDescription
 loadFile path = do
   exists <- FileSystem.doesFileExist path
-  unless exists $
-    throwError $
-      CabalFileNotFound path
+  unless exists $ do
+    throwError $ CabalFileNotFound path
   content <- FileSystem.readFile path
   parseString path content
 
 parseString
-  :: (Console :> es, Error ProcessingError :> es)
+  :: (Error ProcessingError :> es)
   => String
   -- ^ File name
   -> BS.ByteString
@@ -58,9 +52,7 @@ parseString name bs = do
   let (_warnings, result) = runParseResult (parseGenericPackageDescription bs)
   case result of
     Right x -> pure x
-    Left err -> do
-      logAttention (display $ show err)
-      throwError $ CabalFileCouldNotBeParsed name
+    Left err -> throwError $ CabalFileCouldNotBeParsed name (show err)
 
 extractTestedWith
   :: GenericPackageDescription
@@ -85,9 +77,6 @@ extractThisVersion :: VersionRange -> Maybe Version
 extractThisVersion (ThisVersion version) = Just version
 extractThisVersion _ = Nothing
 
-logAttention :: (Console :> es) => Text -> Eff es ()
-logAttention message = Console.putStrLn $ Text.encodeUtf8 message
-
 expandUnionVersionRanges
   :: Vector (CompilerFlavor, VersionRange)
   -> Vector (CompilerFlavor, VersionRange)

diff --git a/src/GetTested/Types.hs b/src/GetTested/Types.hs
@@ -6,6 +6,7 @@ import Data.Aeson
 import Data.String (fromString)
 import Data.Text (Text)
 import Data.Text qualified as Text
+import Data.Text.Builder.Linear qualified as Builder
 import Data.Text.Display
 import Data.Vector (Vector)
 import Data.Vector qualified as Vector
@@ -19,14 +20,29 @@ import GHC.Generics (Generic)
 
 data ProcessingError
   = CabalFileNotFound FilePath
-  | CabalFileCouldNotBeParsed FilePath
+  | CabalFileCouldNotBeParsed FilePath String
   | NoCompilerVersionsFound FilePath
   | IncompatibleOptions Text Text
   | VersionCheckFailed FilePath (NonEmptyVector Version)
   deriving stock (Eq, Ord, Show)
-  deriving
-    (Display)
-    via ShowInstance ProcessingError
+
+instance Display ProcessingError where
+  displayBuilder (CabalFileNotFound path) =
+    "Could not find cabal file at path " <> fromString path
+  displayBuilder (CabalFileCouldNotBeParsed path err) =
+    ("Could not parse cabal file at path " <> fromString path <> ": ")
+      <> fromString err
+  displayBuilder (IncompatibleOptions opt1 opt2) =
+    "Incompatible options: "
+      <> Builder.fromText opt1
+      <> " and "
+      <> Builder.fromText opt2
+      <> " cannot be passed simultaneously."
+  displayBuilder (NoCompilerVersionsFound path) =
+    "No compilers found in " <> fromString path
+  displayBuilder (VersionCheckFailed path failures) =
+    ("Check for " <> fromString path <> " failed:")
+      <> foldMap (\compiler -> "\n  " <> displayBuilder compiler) failures
 
 data RunnerOS
   = Ubuntu
@@ -52,6 +68,9 @@ instance Display CompilerFlavor where
 instance Display VersionRange where
   displayBuilder = fromString . Pretty.prettyShow
 
+instance Display Version where
+  displayBuilder = fromString . Pretty.prettyShow
+
 instance ToJSON Version where
   toJSON = toJSON . Pretty.prettyShow