diff --git a/haskell-ci.cabal b/haskell-ci.cabal index 32a48d64..69f1958f 100644 --- a/haskell-ci.cabal +++ b/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 diff --git a/src/HaskellCI.hs b/src/HaskellCI.hs index 705a2a3e..17d4d89e 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 @@ -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 ------------------------------------------------------------------------------- diff --git a/src/HaskellCI/Cli.hs b/src/HaskellCI/Cli.hs index ce10fea8..1f2872c5 100644 --- a/src/HaskellCI/Cli.hs +++ b/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 or cabal.project") + diffP = pure CommandDiffConfig + ------------------------------------------------------------------------------- -- Parsing helpers ------------------------------------------------------------------------------- diff --git a/src/HaskellCI/Config/Diff.hs b/src/HaskellCI/Config/Diff.hs new file mode 100644 index 00000000..64238869 --- /dev/null +++ b/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