Skip to content

Commit 6480428

Browse files
merijnphadej
merijn
authored and
phadej
committed
Generate a diff between two sets of options.
1 parent e81a202 commit 6480428

File tree

4 files changed

+177
-0
lines changed

4 files changed

+177
-0
lines changed

‎haskell-ci.cabal

+1
Original file line numberDiff line numberDiff line change
@@ -92,6 +92,7 @@ library haskell-ci-internal
9292
HaskellCI.Config.CopyFields
9393
HaskellCI.Config.Docspec
9494
HaskellCI.Config.Doctest
95+
HaskellCI.Config.Diff
9596
HaskellCI.Config.Dump
9697
HaskellCI.Config.Empty
9798
HaskellCI.Config.Folds

‎src/HaskellCI.hs

+32
Original file line numberDiff line numberDiff line change
@@ -56,6 +56,7 @@ import HaskellCI.Bash
5656
import HaskellCI.Cli
5757
import HaskellCI.Compiler
5858
import HaskellCI.Config
59+
import HaskellCI.Config.Diff
5960
import HaskellCI.Config.Dump
6061
import HaskellCI.Diagnostics
6162
import HaskellCI.GitConfig
@@ -87,6 +88,17 @@ main = do
8788
CommandDumpConfig -> do
8889
putStr $ unlines $ runDG configGrammar
8990

91+
CommandDiffConfig cfg fp Nothing -> do
92+
newConfig <- configFromRegenOrConfigFile fp
93+
94+
let oldConfig = optConfigMorphism opts emptyConfig
95+
putStr . unlines $ diffConfigs cfg configGrammar oldConfig newConfig
96+
97+
CommandDiffConfig cfg oldConfigFp (Just newConfigFp) -> do
98+
oldConfig <- configFromRegenOrConfigFile oldConfigFp
99+
newConfig <- configFromRegenOrConfigFile newConfigFp
100+
putStr . unlines $ diffConfigs cfg configGrammar oldConfig newConfig
101+
90102
CommandRegenerate -> do
91103
regenerateBash opts
92104
regenerateGitHub opts
@@ -113,6 +125,26 @@ main = do
113125
ifor_ :: Map.Map k v -> (k -> v -> IO a) -> IO ()
114126
ifor_ xs f = Map.foldlWithKey' (\m k a -> m >> void (f k a)) (return ()) xs
115127

128+
-------------------------------------------------------------------------------
129+
-- Diffing
130+
-------------------------------------------------------------------------------
131+
configFromRegenOrConfigFile :: FilePath -> IO Config
132+
configFromRegenOrConfigFile fp = do
133+
withContents fp noFile $ \contents -> case findRegendataArgv contents of
134+
Nothing -> readConfigFile fp
135+
Just (mversion, argv) -> do
136+
-- warn if we regenerate using older haskell-ci
137+
for_ mversion $ \version -> for_ (simpleParsec haskellCIVerStr) $ \haskellCIVer ->
138+
when (haskellCIVer < version) $ do
139+
putStrLnWarn $ "Regenerating using older haskell-ci-" ++ haskellCIVerStr
140+
putStrLnWarn $ "File generated using haskell-ci-" ++ prettyShow version
141+
142+
opts <- snd <$> parseOptions argv
143+
optConfigMorphism opts <$> findConfigFile (optConfig opts)
144+
where
145+
noFile :: IO Config
146+
noFile = putStrLnErr $ "No file named \"" ++ fp ++ "\" exists."
147+
116148
-------------------------------------------------------------------------------
117149
-- Travis
118150
-------------------------------------------------------------------------------

‎src/HaskellCI/Cli.hs

+8
Original file line numberDiff line numberDiff line change
@@ -12,6 +12,7 @@ import System.IO (hPutStrLn, stderr)
1212
import qualified Options.Applicative as O
1313

1414
import HaskellCI.Config
15+
import HaskellCI.Config.Diff (DiffConfig, defaultDiffConfig, diffConfigGrammar)
1516
import HaskellCI.OptparseGrammar
1617
import HaskellCI.VersionInfo
1718

@@ -26,6 +27,7 @@ data Command
2627
| CommandRegenerate
2728
| CommandListGHC
2829
| CommandDumpConfig
30+
| CommandDiffConfig DiffConfig FilePath (Maybe FilePath)
2931
| CommandVersionInfo
3032
deriving Show
3133

@@ -135,6 +137,7 @@ cliParserInfo = O.info ((,) <$> cmdP <*> optionsP O.<**> versionP O.<**> O.helpe
135137
, O.command "github" $ O.info githubP $ O.progDesc "Generate GitHub Actions config"
136138
, O.command "list-ghc" $ O.info (pure CommandListGHC) $ O.progDesc "List known GHC versions"
137139
, O.command "dump-config" $ O.info (pure CommandDumpConfig) $ O.progDesc "Dump cabal.haskell-ci config with default values"
140+
, O.command "diff-config" $ O.info diffP $ O.progDesc ""
138141
, O.command "version-info" $ O.info (pure CommandVersionInfo) $ O.progDesc "Print versions info haskell-ci was compiled with"
139142
]) <|> travisP
140143

@@ -147,6 +150,11 @@ cliParserInfo = O.info ((,) <$> cmdP <*> optionsP O.<**> versionP O.<**> O.helpe
147150
githubP = CommandGitHub
148151
<$> O.strArgument (O.metavar "CABAL.FILE" <> O.action "file" <> O.help "Either <pkg.cabal> or cabal.project")
149152

153+
diffP = CommandDiffConfig
154+
<$> (runOptparseGrammar diffConfigGrammar <*> pure defaultDiffConfig)
155+
<*> O.strArgument (O.metavar "FILE" <> O.action "file" <> O.help "Either a generated CI file or Haskell-CI config file.")
156+
<*> O.optional (O.strArgument (O.metavar "FILE" <> O.action "file" <> O.help "Either a generated CI file or Haskell-CI config file."))
157+
150158
-------------------------------------------------------------------------------
151159
-- Parsing helpers
152160
-------------------------------------------------------------------------------

‎src/HaskellCI/Config/Diff.hs

+136
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,136 @@
1+
{-# LANGUAGE ConstraintKinds #-}
2+
{-# LANGUAGE DataKinds #-}
3+
{-# LANGUAGE FunctionalDependencies #-}
4+
{-# LANGUAGE OverloadedStrings #-}
5+
{-# LANGUAGE TypeApplications #-}
6+
module HaskellCI.Config.Diff where
7+
8+
import HaskellCI.Prelude
9+
10+
import Distribution.Fields.Field (FieldName)
11+
import Distribution.Utils.ShortText (fromShortText)
12+
13+
import qualified Distribution.Compat.Lens as L
14+
import qualified Distribution.Compat.CharParsing as C
15+
import qualified Distribution.FieldGrammar as C
16+
import qualified Distribution.Parsec as C
17+
import qualified Distribution.Pretty as C
18+
import qualified Text.PrettyPrint as PP
19+
20+
import HaskellCI.OptionsGrammar
21+
import HaskellCI.Config.Empty (runEG)
22+
23+
data ShowDiffOptions = ShowAllOptions | ShowChangedOptions
24+
deriving (Eq, Show, Generic, Binary)
25+
26+
instance C.Parsec ShowDiffOptions where
27+
parsec = ShowAllOptions <$ C.string "all"
28+
<|> ShowChangedOptions <$ C.string "changed"
29+
30+
instance C.Pretty ShowDiffOptions where
31+
pretty ShowAllOptions = PP.text "all"
32+
pretty ShowChangedOptions = PP.text "changed"
33+
34+
data DiffConfig = DiffConfig
35+
{ diffShowOptions :: ShowDiffOptions
36+
, diffShowOld :: Bool
37+
} deriving (Show, Generic, Binary)
38+
39+
diffConfigGrammar
40+
:: ( OptionsGrammar c g
41+
, Applicative (g DiffConfig)
42+
, c (Identity ShowDiffOptions))
43+
=> g DiffConfig DiffConfig
44+
diffConfigGrammar = DiffConfig
45+
<$> C.optionalFieldDef "diff-show-options" (field @"diffShowOptions") ShowChangedOptions
46+
^^^ help "Which fields to show"
47+
<*> C.booleanFieldDef "diff-show-old" (field @"diffShowOld") False
48+
^^^ help "Show the old values for every field"
49+
50+
defaultDiffConfig :: DiffConfig
51+
defaultDiffConfig = case runEG diffConfigGrammar of
52+
Left xs -> error $ "Required fields: " ++ show xs
53+
Right x -> x
54+
55+
newtype DiffOptions s a =
56+
DiffOptions { runDiffOptions :: (s, s) -> DiffConfig -> [String] }
57+
deriving Functor
58+
59+
instance Applicative (DiffOptions s) where
60+
pure _ = DiffOptions $ \_ _ -> []
61+
DiffOptions f <*> DiffOptions x = DiffOptions (f <> x)
62+
63+
diffConfigs :: DiffConfig -> DiffOptions a a -> a -> a -> [String]
64+
diffConfigs config grammar oldVal newVal =
65+
runDiffOptions grammar (oldVal, newVal) config
66+
67+
diffUnique
68+
:: Eq b
69+
=> (a -> b)
70+
-> (a -> String)
71+
-> FieldName
72+
-> L.ALens' s a
73+
-> (s, s)
74+
-> DiffConfig
75+
-> [String]
76+
diffUnique project render fn lens (diffOld, diffNew) opts =
77+
case diffShowOptions opts of
78+
ShowChangedOptions | notEqual -> []
79+
ShowAllOptions | notEqual -> newLine
80+
_ -> oldLine ++ newLine
81+
where
82+
notEqual = project oldValue == project newValue
83+
oldValue = L.aview lens $ diffOld
84+
newValue = L.aview lens $ diffNew
85+
86+
oldLine
87+
| diffShowOld opts = ["-- " ++ fromUTF8BS fn ++ ": " ++ render oldValue]
88+
| otherwise = []
89+
90+
newLine = [ fromUTF8BS fn ++ ": " ++ render newValue, ""]
91+
92+
93+
instance C.FieldGrammar C.Pretty DiffOptions where
94+
blurFieldGrammar lens (DiffOptions diff) =
95+
DiffOptions $ diff . bimap (L.aview lens) (L.aview lens)
96+
97+
uniqueFieldAla fn pack valueLens = DiffOptions $
98+
diffUnique (C.prettyShow . pack) (C.prettyShow . pack) fn valueLens
99+
100+
booleanFieldDef fn valueLens _ = DiffOptions $
101+
diffUnique id C.prettyShow fn valueLens
102+
103+
optionalFieldAla fn pack valueLens = DiffOptions $
104+
diffUnique toPretty toPretty fn valueLens
105+
where
106+
toPretty = maybe "" (C.prettyShow . pack)
107+
108+
optionalFieldDefAla fn pack valueLens _ = DiffOptions $
109+
diffUnique id (C.prettyShow . pack) fn valueLens
110+
111+
monoidalFieldAla fn pack valueLens = DiffOptions $
112+
diffUnique (C.prettyShow . pack) (C.prettyShow . pack) fn valueLens
113+
114+
freeTextField fn valueLens = DiffOptions $
115+
diffUnique id (fromMaybe "") fn valueLens
116+
117+
freeTextFieldDef fn valueLens = DiffOptions $
118+
diffUnique id id fn valueLens
119+
120+
freeTextFieldDefST fn valueLens = DiffOptions $
121+
diffUnique id fromShortText fn valueLens
122+
123+
prefixedFields _ _ = pure []
124+
knownField _ = pure ()
125+
deprecatedSince _ _ = id
126+
availableSince _ _ = id
127+
removedIn _ _ = id
128+
hiddenField = id
129+
130+
instance OptionsGrammar C.Pretty DiffOptions where
131+
metahelp _ = help
132+
133+
help h (DiffOptions xs) = DiffOptions $ \vals config ->
134+
case xs vals config of
135+
[] -> []
136+
diffString -> ("-- " ++ h) : diffString

0 commit comments

Comments
 (0)