Initial diff command.

haskell-CI · Aug 2, 2021 · 5e2e32b · 5e2e32b
1 parent 39d9630
commit 5e2e32b
Show file tree

Hide file tree

Showing 3 changed files with 47 additions and 1 deletion.
diff --git a/src/HaskellCI.hs b/src/HaskellCI.hs
@@ -57,6 +57,7 @@ import HaskellCI.Bash
 import HaskellCI.Cli
 import HaskellCI.Compiler
 import HaskellCI.Config
+import HaskellCI.Config.Diff
 import HaskellCI.Config.Dump
 import HaskellCI.Diagnostics
 import HaskellCI.GitConfig
@@ -89,6 +90,17 @@ main = do
         CommandDumpConfig -> do
             putStr $ unlines $ runDG configGrammar
 
+        CommandDiffConfig cfg fp Nothing -> do
+            newConfig <- configFromRegenOrConfigFile fp
+
+            let oldConfig = optConfigMorphism opts emptyConfig
+            putStr . unlines $ diffConfigs cfg configGrammar oldConfig newConfig
+
+        CommandDiffConfig cfg oldConfigFp (Just newConfigFp) -> do
+            oldConfig <- configFromRegenOrConfigFile oldConfigFp
+            newConfig <- configFromRegenOrConfigFile newConfigFp
+            putStr . unlines $ diffConfigs cfg configGrammar oldConfig newConfig
+
         CommandRegenerate -> do
             regenerateBash opts
             regenerateGitHub opts
@@ -115,6 +127,26 @@ main = do
     ifor_ :: Map.Map k v -> (k -> v -> IO a) -> IO ()
     ifor_ xs f = Map.foldlWithKey' (\m k a -> m >> void (f k a)) (return ()) xs
 
+-------------------------------------------------------------------------------
+-- Diffing
+-------------------------------------------------------------------------------
+configFromRegenOrConfigFile :: FilePath -> IO Config
+configFromRegenOrConfigFile fp = do
+    withContents fp noFile $ \contents -> case findRegendataArgv contents of
+        Nothing     -> readConfigFile fp
+        Just (mversion, argv) -> do
+            -- warn if we regenerate using older haskell-ci
+            for_ mversion $ \version -> for_ (simpleParsec haskellCIVerStr) $ \haskellCIVer ->
+                when (haskellCIVer < version) $ do
+                    putStrLnWarn $ "Regenerating using older haskell-ci-" ++ haskellCIVerStr
+                    putStrLnWarn $ "File generated using haskell-ci-" ++ prettyShow version
+
+            opts <- snd <$> parseOptions argv
+            optConfigMorphism opts <$> findConfigFile (optConfig opts)
+  where
+    noFile :: IO Config
+    noFile = putStrLnErr $ "No file named \"" ++ fp ++ "\" exists."
+
 -------------------------------------------------------------------------------
 -- Travis
 -------------------------------------------------------------------------------

diff --git a/src/HaskellCI/Cli.hs b/src/HaskellCI/Cli.hs
@@ -12,6 +12,7 @@ import System.IO             (hPutStrLn, stderr)
 import qualified Options.Applicative as O
 
 import HaskellCI.Config
+import HaskellCI.Config.Diff (DiffConfig, defaultDiffConfig, diffConfigGrammar)
 import HaskellCI.OptparseGrammar
 import HaskellCI.VersionInfo
 
@@ -26,6 +27,7 @@ data Command
     | CommandRegenerate
     | CommandListGHC
     | CommandDumpConfig
+    | CommandDiffConfig DiffConfig FilePath (Maybe FilePath)
     | CommandVersionInfo
   deriving Show
 
@@ -135,6 +137,7 @@ cliParserInfo = O.info ((,) <$> cmdP <*> optionsP O.<**> versionP O.<**> O.helpe
         , O.command "github"       $ O.info githubP                   $ O.progDesc "Generate GitHub Actions config"
         , O.command "list-ghc"     $ O.info (pure CommandListGHC)     $ O.progDesc "List known GHC versions"
         , O.command "dump-config"  $ O.info (pure CommandDumpConfig)  $ O.progDesc "Dump cabal.haskell-ci config with default values"
+        , O.command "diff-config"  $ O.info diffP $ O.progDesc ""
         , O.command "version-info" $ O.info (pure CommandVersionInfo) $ O.progDesc "Print versions info haskell-ci was compiled with"
         ]) <|> travisP
 
@@ -147,6 +150,11 @@ cliParserInfo = O.info ((,) <$> cmdP <*> optionsP O.<**> versionP O.<**> O.helpe
     githubP = CommandGitHub
         <$> O.strArgument (O.metavar "CABAL.FILE" <> O.action "file" <> O.help "Either <pkg.cabal> or cabal.project")
 
+    diffP = CommandDiffConfig
+        <$> (runOptparseGrammar diffConfigGrammar <*> pure defaultDiffConfig)
+        <*> O.strArgument (O.metavar "FILE" <> O.action "file" <> O.help "Either a generated CI file or Haskell-CI config file.")
+        <*> O.optional (O.strArgument (O.metavar "FILE" <> O.action "file" <> O.help "Either a generated CI file or Haskell-CI config file."))
+
 -------------------------------------------------------------------------------
 -- Parsing helpers
 -------------------------------------------------------------------------------

diff --git a/src/HaskellCI/Config/Diff.hs b/src/HaskellCI/Config/Diff.hs
@@ -19,6 +19,7 @@ import qualified Distribution.Pretty             as C
 import qualified Text.PrettyPrint                as PP
 
 import HaskellCI.OptionsGrammar
+import HaskellCI.Config.Empty (runEG)
 
 data ShowDiffOptions = ShowAllOptions | ShowChangedOptions
     deriving (Eq, Show, Generic, Binary)
@@ -47,6 +48,11 @@ diffConfigGrammar = DiffConfig
     <*> C.booleanFieldDef "diff-show-old" (field @"diffShowOld") False
         ^^^ help "Show the old values for every field"
 
+defaultDiffConfig :: DiffConfig
+defaultDiffConfig = case runEG diffConfigGrammar of
+    Left xs -> error $ "Required fields: " ++ show xs
+    Right x -> x
+
 newtype DiffOptions s a =
   DiffOptions { runDiffOptions :: (s, s) -> DiffConfig -> [String] }
   deriving Functor
@@ -98,7 +104,7 @@ instance C.FieldGrammar C.Pretty DiffOptions where
     optionalFieldAla fn pack valueLens = DiffOptions $
         diffUnique toPretty toPretty fn valueLens
       where
-        toPretty = maybe "" C.prettyShow . fmap pack
+        toPretty = maybe "" (C.prettyShow . pack)
 
     optionalFieldDefAla fn pack valueLens _ = DiffOptions $
         diffUnique id (C.prettyShow . pack) fn valueLens