diff --git a/haskell-ci.cabal b/haskell-ci.cabal index ddd75259..2f3ca57b 100644 --- a/haskell-ci.cabal +++ b/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 diff --git a/src/HaskellCI.hs b/src/HaskellCI.hs index adbcf103..0d18002b 100644 --- a/src/HaskellCI.hs +++ b/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 ------------------------------------------------------------------------------- diff --git a/src/HaskellCI/Cli.hs b/src/HaskellCI/Cli.hs index ce10fea8..7aafd082 100644 --- 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 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 new file mode 100644 index 00000000..5262483a --- /dev/null +++ b/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