Allow diffing of config files and regendata

haskell-ci.cabal

@@ -90,6 +90,7 @@ library haskell-ci-internal
     HaskellCI.Config.CopyFields
     HaskellCI.Config.Docspec
     HaskellCI.Config.Doctest
+    HaskellCI.Config.Diff
     HaskellCI.Config.Dump
     HaskellCI.Config.Empty
     HaskellCI.Config.Folds

src/HaskellCI.hs

@@ -56,6 +56,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
@@ -88,6 +89,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
@@ -114,6 +126,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
 -------------------------------------------------------------------------------

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
 -------------------------------------------------------------------------------

src/HaskellCI/Config/Diff.hs

@@ -0,0 +1,136 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications  #-}
+module HaskellCI.Config.Diff where
+
+import HaskellCI.Prelude
+
+import Distribution.Fields.Field (FieldName)
+import Distribution.Utils.ShortText (fromShortText)
+
+import qualified Distribution.Compat.Lens        as L
+import qualified Distribution.Compat.CharParsing as C
+import qualified Distribution.FieldGrammar       as C
+import qualified Distribution.Parsec             as C
+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)
+
+instance C.Parsec ShowDiffOptions where
+    parsec = ShowAllOptions <$ C.string "all"
+        <|> ShowChangedOptions <$ C.string "changed"
+
+instance C.Pretty ShowDiffOptions where
+    pretty ShowAllOptions = PP.text "all"
+    pretty ShowChangedOptions = PP.text "changed"
+
+data DiffConfig = DiffConfig
+    { diffShowOptions :: ShowDiffOptions
+    , diffShowOld :: Bool
+    } deriving (Show, Generic, Binary)
+
+diffConfigGrammar
+    :: ( OptionsGrammar c g
+       , Applicative (g DiffConfig)
+       , c (Identity ShowDiffOptions))
+    => g DiffConfig DiffConfig
+diffConfigGrammar = DiffConfig
+    <$> C.optionalFieldDef "diff-show-options" (field @"diffShowOptions") ShowChangedOptions
+        ^^^ help "Which fields to show"
+    <*> 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
+
+instance Applicative (DiffOptions s) where
+    pure _ = DiffOptions $ \_ _ -> []
+    DiffOptions f <*> DiffOptions x = DiffOptions (f <> x)
+
+diffConfigs :: DiffConfig -> DiffOptions a a -> a -> a -> [String]
+diffConfigs config grammar oldVal newVal =
+  runDiffOptions grammar (oldVal, newVal) config
+
+diffUnique
+    :: Eq b
+    => (a -> b)
+    -> (a -> String)
+    -> FieldName
+    -> L.ALens' s a
+    -> (s, s)
+    -> DiffConfig
+    -> [String]
+diffUnique project render fn lens (diffOld, diffNew) opts =
+  case diffShowOptions opts of
+    ShowChangedOptions | notEqual -> []
+    ShowAllOptions | notEqual -> newLine
+    _ -> oldLine ++ newLine
+  where
+    notEqual = project oldValue == project newValue
+    oldValue = L.aview lens $ diffOld
+    newValue = L.aview lens $ diffNew
+
+    oldLine
+        | diffShowOld opts = ["-- " ++ fromUTF8BS fn ++ ": " ++ render oldValue]
+        | otherwise = []
+
+    newLine = [ fromUTF8BS fn ++ ": " ++ render newValue, ""]
+
+
+instance C.FieldGrammar C.Pretty DiffOptions where
+    blurFieldGrammar lens (DiffOptions diff) =
+        DiffOptions $ diff . bimap (L.aview lens) (L.aview lens)
+
+    uniqueFieldAla fn pack valueLens = DiffOptions $
+        diffUnique (C.prettyShow . pack) (C.prettyShow . pack) fn valueLens
+
+    booleanFieldDef fn valueLens _ = DiffOptions $
+        diffUnique id C.prettyShow fn valueLens
+
+    optionalFieldAla fn pack valueLens = DiffOptions $
+        diffUnique toPretty toPretty fn valueLens
+      where
+        toPretty = maybe "" (C.prettyShow . pack)
+
+    optionalFieldDefAla fn pack valueLens _ = DiffOptions $
+        diffUnique id (C.prettyShow . pack) fn valueLens
+
+    monoidalFieldAla fn pack valueLens = DiffOptions $
+        diffUnique (C.prettyShow . pack) (C.prettyShow . pack) fn valueLens
+
+    freeTextField fn valueLens = DiffOptions $
+        diffUnique id (fromMaybe "") fn valueLens
+
+    freeTextFieldDef fn valueLens = DiffOptions $
+        diffUnique id id fn valueLens
+
+    freeTextFieldDefST fn valueLens = DiffOptions $
+        diffUnique id fromShortText fn valueLens
+
+    prefixedFields _ _   = pure []
+    knownField _         = pure ()
+    deprecatedSince _  _ = id
+    availableSince _ _   = id
+    removedIn _ _        = id
+    hiddenField          = id
+
+instance OptionsGrammar C.Pretty DiffOptions where
+    metahelp _ = help
+
+    help h (DiffOptions xs) = DiffOptions $ \vals config ->
+        case xs vals config of
+            [] -> []
+            diffString -> ("-- " ++ h) : diffString