Kleidukos · mmhat · Jan 6, 2025 · Jan 6, 2025 · Jan 6, 2025 · Jan 6, 2025
diff --git a/app/Command/Check.hs b/app/Command/Check.hs
@@ -0,0 +1,57 @@
+module Command.Check
+  ( checkCommandParserInfo
+  , check
+  ) where
+
+import Data.Vector qualified as Vector
+import Data.Vector.NonEmpty qualified as NEVector
+import Effectful
+import Effectful.Error.Static
+import Effectful.FileSystem (FileSystem)
+import Options.Applicative
+
+import GetTested.CLI.Types
+import GetTested.Extract
+import GetTested.Types
+import Utils
+
+checkCommandParserInfo :: ParserInfo Command
+checkCommandParserInfo =
+  info
+    (CheckCommand <$> checkOptionsParser)
+    (progDesc "Check whether some versions are a subset of the tested versions or not")
+
+checkOptionsParser :: Parser CheckOptions
+checkOptionsParser =
+  CheckOptions
+    <$> (optional . strOption)
+      ( long "from"
+          <> metavar "FILE"
+          <> help "Include the tested versions of this Cabal file"
+          <> action "file"
+      )
+    <*> strArgument
+      ( metavar "FILE"
+          <> action "file"
+      )
+    <*> (fmap Vector.fromList . many . argument versionReader)
+      ( metavar "VERSION"
+          <> help "Check if this version is one of the tested versions"
+      )
+
+check
+  :: (Error ProcessingError :> es, FileSystem :> es)
+  => CheckOptions -> Eff es ()
+check options = do
+  compilers <- extractTestedWith <$> loadFile options.checkOptionsPath
+
+  failures <- case options.checkOptionsFrom of
+    Nothing -> pure $ Vector.filter (`Vector.notElem` compilers) options.checkOptionsVersions
+    Just fp -> do
+      versionsFromFile <- extractTestedWith <$> loadFile fp
+      pure $ Vector.filter (`Vector.notElem` versionsFromFile) compilers
+
+  case NEVector.fromVector failures of
+    Nothing -> pure ()
+    Just failures' ->
+      throwError $ VersionCheckFailed options.checkOptionsPath failures'
diff --git a/app/Command/Generate.hs b/app/Command/Generate.hs
@@ -0,0 +1,136 @@
+module Command.Generate
+  ( generateCommandParserInfo
+  , generateOptionsParser
+  , generate
+  ) where
+
+import Control.Monad (when)
+import Data.Aeson qualified as Aeson
+import Data.Text (Text)
+import Data.Text.Display (display)
+import Data.Vector (Vector)
+import Data.Vector qualified as Vector
+import Effectful
+import Effectful.Console.ByteString (Console)
+import Effectful.Console.ByteString.Lazy qualified as Console.Lazy
+import Effectful.Error.Static
+import Effectful.FileSystem (FileSystem)
+import Options.Applicative
+
+import GetTested.CLI.Types
+import GetTested.Extract
+import GetTested.Types
+import Utils
+
+generateCommandParserInfo :: ParserInfo Command
+generateCommandParserInfo =
+  info
+    (GenerateCommand <$> generateOptionsParser True)
+    (progDesc "Generate a test matrix from the tested-with stanza of your Cabal file")
+
+generateOptionsParser
+  :: Bool
+  -- ^ Whether to display the options in the help text or not
+  -> Parser GenerateOptions
+generateOptionsParser doDisplay =
+  GenerateOptions
+    <$> strArgument
+      ( metavar "FILE"
+          <> action "file"
+          <> minternal
+      )
+    <*> switch
+      ( long "macos"
+          <> help "(legacy) Enable the macOS runner's latest version"
+          <> minternal
+      )
+    <*> (optional . strOption)
+      ( long "macos-version"
+          <> metavar "VERSION"
+          <> help "Enable the macOS runner with the selected version"
+          <> minternal
+      )
+    <*> switch
+      ( long "ubuntu"
+          <> help "(legacy) Enable the Ubuntu runner's latest version"
+          <> minternal
+      )
+    <*> (optional . strOption)
+      ( long "ubuntu-version"
+          <> metavar "VERSION"
+          <> help "Enable the Ubuntu runner with the selected version"
+          <> minternal
+      )
+    <*> switch
+      ( long "windows"
+          <> help "(legacy) Enable the Windows runner's latest version"
+          <> minternal
+      )
+    <*> (optional . strOption)
+      ( long "windows-version"
+          <> metavar "VERSION"
+          <> help "Enable the Windows runner with the selected version"
+          <> minternal
+      )
+    <*> switch
+      ( long "newest"
+          <> help "Enable only the newest GHC version found in the cabal file"
+          <> minternal
+      )
+    <*> switch
+      ( long "oldest"
+          <> help "Enable only the oldest GHC version found in the cabal file"
+          <> minternal
+      )
+  where
+    minternal :: Mod f a
+    minternal
+      | doDisplay = idm
+      | otherwise = internal
+
+generate
+  :: (Console :> es, Error ProcessingError :> es, FileSystem :> es)
+  => GenerateOptions -> Eff es ()
+generate options = do
+  checkIncompatibleRelativeOptions options
+  genericPackageDescription <- loadFile options.generateOptionsPath
+  selectedCompilers <-
+    filterCompilers options
+      <$> extractNonEmptyTestedWith options.generateOptionsPath genericPackageDescription
+  let filteredList =
+        processOSFlag MacOS options.generateOptionsMacosFlag options.generateOptionsMacosVersion
+          <> processOSFlag Ubuntu options.generateOptionsUbuntuFlag options.generateOptionsUbuntuVersion
+          <> processOSFlag Windows options.generateOptionsWindowsFlag options.generateOptionsWindowsVersion
+  Console.Lazy.putStrLn $
+    if null filteredList
+      then Aeson.encode selectedCompilers
+      else
+        let include = PlatformAndVersion <$> filteredList <*> selectedCompilers
+         in "matrix=" <> Aeson.encode (ActionMatrix include)
+
+processOSFlag
+  :: RunnerOS
+  -- ^ OS flag we're processing
+  -> Bool
+  -- ^ legacy fallback
+  -> Maybe Text
+  -- ^ explicit version
+  -> Vector Text
+processOSFlag runnerOS legacyFallback mExplicitVersion =
+  case mExplicitVersion of
+    Just explicitVersion -> Vector.singleton (display runnerOS <> "-" <> explicitVersion)
+    Nothing ->
+      if legacyFallback
+        then Vector.singleton $ display runnerOS <> "-latest"
+        else Vector.empty
+
+checkIncompatibleRelativeOptions
+  :: (Error ProcessingError :> es)
+  => GenerateOptions
+  -> Eff es ()
+checkIncompatibleRelativeOptions options = do
+  when (options.generateOptionsNewest && options.generateOptionsOldest) $
+    throwError $
+      IncompatibleOptions
+        "--newest"
+        "--oldest"
diff --git a/app/Main.hs b/app/Main.hs
@@ -1,116 +1,62 @@
-module Main where
+module Main (main) where
 
-import Control.Monad (when)
-import Data.Aeson qualified as Aeson
-import Data.ByteString.Lazy (ByteString)
-import Data.ByteString.Lazy.Char8 qualified as ByteString
 import Data.Function ((&))
-import Data.Text (Text)
-import Data.Text qualified as Text
 import Data.Text.Display (display)
-import Data.Vector (Vector)
-import Data.Vector qualified as Vector
-import Data.Version (showVersion)
+import Data.Text.IO qualified
+import Data.Version qualified
 import Effectful
 import Effectful.Console.ByteString (Console)
 import Effectful.Console.ByteString qualified as Console
-import Effectful.Error.Static
+import Effectful.Error.Static (Error)
 import Effectful.Error.Static qualified as Error
 import Effectful.FileSystem (FileSystem)
 import Effectful.FileSystem qualified as FileSystem
-import Options.Applicative hiding (action)
+import Options.Applicative
 import System.Exit
 
-import GetTested.CLI.Types
-import GetTested.Extract
+import Command.Check
+import Command.Generate
 import GetTested.Types
 import Paths_get_tested (version)
+import Utils
 
 main :: IO ()
 main = do
-  result <- execParser (parseOptions `withInfo` "Generate a test matrix from the tested-with stanza of your cabal file")
-  processingResult <- runCLIEff $ runOptions result
+  cmd <- execParser (parser `withInfo` "A utility to work with the tested-with stanza of your cabal files")
+  processingResult <- runCLIEff $ case cmd of
+    CheckCommand options -> check options
+    GenerateCommand options -> generate options
+    LegacyDefault options -> do
+      -- TODO: Display a warining and suggest migration to `get-tested generate` ?
+      generate options
   case processingResult of
-    Right json -> putStrLn $ ByteString.unpack json
-    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."
+    Right () -> pure ()
+    Left err -> do
+      Data.Text.IO.putStrLn $ "get-tested: " <> display err
       exitFailure
 
-parseOptions :: Parser Options
-parseOptions =
-  Options
-    <$> argument str (metavar "FILE")
-    <*> switch (long "macos" <> help "(legacy) Enable the macOS runner's latest version")
-    <*> optional (strOption (long "macos-version" <> metavar "VERSION" <> help "Enable the macOS runner with the selected version"))
-    <*> switch (long "ubuntu" <> help "(legacy) Enable the Ubuntu runner's latest version")
-    <*> optional (strOption (long "ubuntu-version" <> metavar "VERSION" <> help "Enable the Ubuntu runner with the selected version"))
-    <*> switch (long "windows" <> help "(legacy) Enable the Windows runner's latest version")
-    <*> optional (strOption (long "windows-version" <> metavar "VERSION" <> help "Enable the Windows runner with the selected version"))
-    <*> switch (long "newest" <> help "Enable only the newest GHC version found in the cabal file")
-    <*> switch (long "oldest" <> help "Enable only the oldest GHC version found in the cabal file")
-      <**> simpleVersioner (showVersion version)
-
-runOptions :: Options -> Eff [Console, FileSystem, Error ProcessingError, IOE] ByteString
-runOptions options = do
-  checkIncompatibleRelativeOptions options
-  genericPackageDescription <- loadFile options.path
-  selectedCompilers <-
-    filterCompilers options
-      <$> extractTestedWith options.path genericPackageDescription
-  let filteredList =
-        processOSFlag MacOS options.macosFlag options.macosVersion
-          <> processOSFlag Ubuntu options.ubuntuFlag options.ubuntuVersion
-          <> processOSFlag Windows options.windowsFlag options.windowsVersion
-  if null filteredList
-    then pure $ Aeson.encode selectedCompilers
-    else do
-      let include = PlatformAndVersion <$> filteredList <*> selectedCompilers
-      pure $ "matrix=" <> Aeson.encode (ActionMatrix include)
+parser :: Parser Command
+parser =
+  ( hsubparser
+      ( command "check" checkCommandParserInfo
+          <> metavar "check"
+      )
+      <|> hsubparser
+        ( command "generate" generateCommandParserInfo
+            <> metavar "generate"
+        )
+      <|> (LegacyDefault <$> generateOptionsParser False)
+  )
+    <**> simpleVersioner (Data.Version.showVersion version)
 
 withInfo :: Parser a -> String -> ParserInfo a
 withInfo opts desc = info (helper <*> opts) $ progDesc desc
 
-processOSFlag
-  :: RunnerOS
-  -- ^ OS flag we're processing
-  -> Bool
-  -- ^ legacy fallback
-  -> Maybe Text
-  -- ^ explicit version
-  -> Vector Text
-processOSFlag runnerOS legacyFallback mExplicitVersion =
-  case mExplicitVersion of
-    Just explicitVersion -> Vector.singleton (display runnerOS <> "-" <> explicitVersion)
-    Nothing ->
-      if legacyFallback
-        then Vector.singleton $ display runnerOS <> "-latest"
-        else Vector.empty
-
-checkIncompatibleRelativeOptions
-  :: (Error ProcessingError :> es)
-  => Options
-  -> Eff es ()
-checkIncompatibleRelativeOptions options = do
-  when (options.newest && options.oldest) $
-    throwError $
-      IncompatibleOptions
-        "--newest"
-        "--oldest"
-
 runCLIEff
   :: Eff [Console, FileSystem, Error ProcessingError, IOE] a
   -> IO (Either ProcessingError a)
-runCLIEff action = do
-  action
+runCLIEff run = do
+  run
     & Console.runConsole
     & FileSystem.runFileSystem
     & Error.runErrorNoCallStack

diff --git a/app/Utils.hs b/app/Utils.hs
@@ -0,0 +1,20 @@
+module Utils where
+
+import Distribution.Parsec (parsec, runParsecParser)
+import Distribution.Parsec.FieldLineStream (fieldLineStreamFromString)
+import Distribution.Types.Version (Version)
+import Options.Applicative
+
+import GetTested.CLI.Types
+
+data Command
+  = CheckCommand CheckOptions
+  | GenerateCommand GenerateOptions
+  | LegacyDefault GenerateOptions
+
+versionReader :: ReadM Version
+versionReader =
+  eitherReader $
+    either (Left . show) Right
+      . runParsecParser parsec "<versionReader>"
+      . fieldLineStreamFromString