Config diff

haskell-ci.cabal

@@ -92,6 +92,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
@@ -87,6 +88,12 @@ main = do
         CommandDumpConfig -> do
             putStr $ unlines $ runDG configGrammar
 
+        CommandDiffConfig -> do
+            let oldConfig = emptyConfig -- default
+            newConfig' <- findConfigFile (optConfig opts)
+            let newConfig = optConfigMorphism opts newConfig'
+            putStr $ unlines $ diffConfigs configGrammar oldConfig newConfig
+
         CommandRegenerate -> do
             regenerateBash opts
             regenerateGitHub opts
@@ -113,6 +120,29 @@ 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

@@ -26,6 +26,7 @@ data Command
     | CommandRegenerate
     | CommandListGHC
     | CommandDumpConfig
+    | CommandDiffConfig
     | CommandVersionInfo
   deriving Show
 
@@ -135,6 +136,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 "Diff between default and current configuration"
         , O.command "version-info" $ O.info (pure CommandVersionInfo) $ O.progDesc "Print versions info haskell-ci was compiled with"
         ]) <|> travisP
 
@@ -147,6 +149,8 @@ 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 = pure CommandDiffConfig
+
 -------------------------------------------------------------------------------
 -- Parsing helpers
 -------------------------------------------------------------------------------

src/HaskellCI/Config/Diff.hs

@@ -0,0 +1,95 @@
+{-# 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.FieldGrammar       as C
+import qualified Distribution.Pretty             as C
+
+import HaskellCI.OptionsGrammar
+
+newtype DiffOptions s a =
+  DiffOptions { runDiffOptions :: (s, s) -> [String] }
+  deriving Functor
+
+instance Applicative (DiffOptions s) where
+    pure _ = DiffOptions $ \_ -> []
+    DiffOptions f <*> DiffOptions x = DiffOptions (f <> x)
+
+diffConfigs :: DiffOptions a a -> a -> a -> [String]
+diffConfigs grammar oldVal newVal =
+  runDiffOptions grammar (oldVal, newVal)
+
+diffUnique
+    :: Eq b
+    => (a -> b)
+    -> (a -> String)
+    -> FieldName
+    -> L.ALens' s a
+    -> (s, s)
+    -> [String]
+diffUnique project render fn lens (diffOld, diffNew)
+    | notEqual =
+    [ "-" ++ fromUTF8BS fn ++ ": " ++ render oldValue
+    , "+" ++ fromUTF8BS fn ++ ": " ++ render newValue
+    , ""
+    ]
+
+    | otherwise = []
+  where
+    notEqual = project oldValue /= project newValue
+    oldValue = L.aview lens $ diffOld
+    newValue = L.aview lens $ diffNew
+
+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 ->
+        case xs vals of
+            [] -> []
+            diffString -> ("-- " ++ h) : diffString