nix-diff 1.0.18 → 1.0.19
raw patch · 14 files changed
+1652/−766 lines, 14 filesdep +QuickCheckdep +aesondep +generic-arbitrarydep ~basedep ~bytestringdep ~containers
Dependencies added: QuickCheck, aeson, generic-arbitrary, nix-diff, quickcheck-instances, tasty, tasty-quickcheck, tasty-silver, typed-process, uniplate
Dependency ranges changed: base, bytestring, containers, mtl, text
Files
- CHANGELOG.md +16/−0
- LICENSE +2/−2
- README.md +11/−6
- app/Main.hs +181/−0
- nix-diff.cabal +60/−9
- src/Main.hs +0/−749
- src/Nix/Diff.hs +518/−0
- src/Nix/Diff/Render/HumanReadable.hs +281/−0
- src/Nix/Diff/Transformations.hs +120/−0
- src/Nix/Diff/Types.hs +308/−0
- test/Golden/Tests.hs +64/−0
- test/Golden/Utils.hs +53/−0
- test/Main.hs +14/−0
- test/Properties.hs +24/−0
CHANGELOG.md view
@@ -1,3 +1,19 @@+1.0.19++* [New Haskell API](https://github.com/Gabriella439/nix-diff/pull/60)+ * Previously `nix-diff` only had a command-line API, but now there is a+ Haskell API available under the `Nix.Diff` module hierarchy+* [Machine-readable output](https://github.com/Gabriella439/nix-diff/pull/61)+ * `nix-diff` now supports a `--json` flag for machine-readable JSON output+* [New `--skip-already-compared` command-line option](https://github.com/Gabriella439/nix-diff/pull/69)+ * This compresses a sub-tree of the diff if the leaves have already been+ compared+* [New `--squash-text-diff` command-line option](https://github.com/Gabriella439/nix-diff/pull/70)+ * This compresses textual diffs into larger spans when possible+* [Ignore `!${OUTPUT}`](https://github.com/Gabriella439/nix-diff/pull/66)+ * `nix-diff` will now strip everything after `!` from a derivation argument+ so that arguments like `/nix/store/…!bin` no longer fail+ 1.0.18 * [Document the `--color` command-line option](https://github.com/Gabriel439/nix-diff/pull/54)
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2017 Gabriel Gonzalez+Copyright (c) 2017 Gabriella Gonzalez All rights reserved. @@ -13,7 +13,7 @@ disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of Gabriel Gonzalez nor the names of other+ * Neither the name of Gabriella Gonzalez nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission.
README.md view
@@ -70,7 +70,7 @@ changed about our system: ```bash-$ nix-diff /nix/store/6z9nr5pzs4j1v9mld517dmlcz61zy78z-nixos-system-nixos-18.03pre119245.5cfd049a03.drv /nix/store/k05ibijg0kknvwrgfyb7dxwjrs8qrlbj-nixos-system-nixos-18.03pre119245.5cfd049a03.drv +$ nix-diff /nix/store/6z9nr5pzs4j1v9mld517dmlcz61zy78z-nixos-system-nixos-18.03pre119245.5cfd049a03.drv /nix/store/k05ibijg0kknvwrgfyb7dxwjrs8qrlbj-nixos-system-nixos-18.03pre119245.5cfd049a03.drv ``` ... which produces the following output:@@ -83,10 +83,15 @@ $ nix-build example.nix $ nix-diff /run/current-system ./result ```+## Testing +Run tests, using `cabal test` command.++You need to have nix installed in your PC.+ ## Development status -[](https://travis-ci.org/Gabriel439/nix-diff)+[](https://travis-ci.org/Gabriella439/nix-diff) I don't currently plan to add any new features, but I do welcome feature requests. Just open an issue on the issue tracker if you would like to request@@ -94,9 +99,9 @@ ## License (BSD 3-clause) - Copyright (c) 2017 Gabriel Gonzalez+ Copyright (c) 2017 Gabriella Gonzalez All rights reserved.- + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice,@@ -104,10 +109,10 @@ * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.- * Neither the name of Gabriel Gonzalez nor the names of other contributors+ * Neither the name of Gabriella Gonzalez nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission.- + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+ app/Main.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Main where++import Control.Applicative ((<|>))+import Data.Text (Text)+import Options.Applicative (Parser, ParserInfo)++import qualified Control.Monad.Reader+import qualified Control.Monad.State+import qualified Data.Set+import qualified GHC.IO.Encoding+import qualified Options.Applicative+import qualified System.Posix.IO+import qualified System.Posix.Terminal+import qualified Data.Aeson+import qualified Data.ByteString.Lazy.Char8+import qualified Data.Text.IO as Text.IO++import Nix.Diff+import Nix.Diff.Types+import Nix.Diff.Render.HumanReadable+import Nix.Diff.Transformations+import Data.Foldable (Foldable(fold))++data Color = Always | Auto | Never++data RenderRunner = HumanReadable | JSON++data TransformOptions = TransformOptions+ { foldAlreadyCompared :: Bool+ , squashTextDiff :: Bool+ }++parseColor :: Parser Color+parseColor =+ Options.Applicative.option+ reader+ ( Options.Applicative.long "color"+ <> Options.Applicative.help ("display colors always, automatically (if terminal detected), or never")+ <> Options.Applicative.value Auto+ <> Options.Applicative.metavar "(always|auto|never)"+ )+ where+ reader = do+ string <- Options.Applicative.str+ case string :: Text of+ "always" -> return Always+ "auto" -> return Auto+ "never" -> return Never+ _ -> fail "Invalid color"++parseLineOriented :: Parser Orientation+parseLineOriented =+ per "line" Line+ <|> per "character" Character+ <|> per "word" Word+ <|> pure Word+ where+ per x orientation =+ Options.Applicative.flag' orientation+ ( Options.Applicative.long (x <> "-oriented")+ <> Options.Applicative.help ("Display textual differences on a per-" <> x <> " basis")+ )++parseEnvironment :: Parser Bool+parseEnvironment =+ Options.Applicative.switch+ ( Options.Applicative.long "environment"+ <> Options.Applicative.help "Force display of environment differences"+ )++parseRenderRunner :: Parser RenderRunner+parseRenderRunner = json <|> pure HumanReadable+ where+ json = Options.Applicative.flag' JSON+ ( Options.Applicative.long "json"+ <> Options.Applicative.help "Print output in JSON format"+ )++parseTransformOptions :: Parser TransformOptions+parseTransformOptions = do+ foldAlreadyCompared <- parseReduceAlreadyCompared+ squashTextDiff <- parseSquashTextDiff++ pure TransformOptions{..}+ where+ parseReduceAlreadyCompared =+ Options.Applicative.switch+ ( Options.Applicative.long "skip-already-compared"+ <> Options.Applicative.help "Fold subtrees, that changed only by already compared input"+ )+ parseSquashTextDiff =+ Options.Applicative.switch+ ( Options.Applicative.long "squash-text-diff"+ <> Options.Applicative.help (fold+ ["Squash text diffs into the lagest spans. It's most useful ",+ "with json output. ",+ "WARNING: can break some parts of human readable output."])+ )++data Options = Options+ { left :: FilePath+ , right :: FilePath+ , color :: Color+ , orientation :: Orientation+ , environment :: Bool+ , renderRunner :: RenderRunner+ , transformOptions :: TransformOptions+ }++parseOptions :: Parser Options+parseOptions = do+ left <- parseLeft+ right <- parseRight+ color <- parseColor+ orientation <- parseLineOriented+ environment <- parseEnvironment+ renderRunner <- parseRenderRunner+ transformOptions <- parseTransformOptions++ return (Options { .. })+ where+ parseFilePath metavar = do+ Options.Applicative.strArgument+ (Options.Applicative.metavar metavar)++ parseLeft = parseFilePath "LEFT"++ parseRight = parseFilePath "RIGHT"++parserInfo :: ParserInfo Options+parserInfo =+ Options.Applicative.info+ (Options.Applicative.helper <*> parseOptions)+ ( Options.Applicative.fullDesc+ <> Options.Applicative.header "Explain why two derivations differ"+ )++transformDiff :: TransformOptions -> DerivationDiff -> DerivationDiff+transformDiff TransformOptions{..}+ = transformIf foldAlreadyCompared foldAlreadyComparedSubTrees+ . transformIf squashTextDiff squashSourcesAndEnvsDiff++renderDiff :: RenderRunner -> RenderContext -> DerivationDiff -> IO ()+renderDiff HumanReadable context derivation+ = Text.IO.putStr $ runRender' (renderDiffHumanReadable derivation) context+renderDiff JSON _ derivation = Data.ByteString.Lazy.Char8.putStrLn (Data.Aeson.encode derivation)++main :: IO ()+main = do+ GHC.IO.Encoding.setLocaleEncoding GHC.IO.Encoding.utf8++ Options { .. } <- Options.Applicative.execParser parserInfo++ tty <- case color of+ Never -> do+ return NotTTY+ Always -> do+ return IsTTY+ Auto -> do+ b <- System.Posix.Terminal.queryTerminal System.Posix.IO.stdOutput+ return (if b then IsTTY else NotTTY)++ let indent = 0+ let diffContext = DiffContext {..}+ let renderContext = RenderContext {..}+ let status = Status Data.Set.empty+ let action = diff True left (Data.Set.singleton "out") right (Data.Set.singleton "out")+ diffTree <- Control.Monad.State.evalStateT (Control.Monad.Reader.runReaderT (unDiff action) diffContext) status+ let diffTree' =+ transformDiff transformOptions diffTree+ renderDiff renderRunner renderContext diffTree'
nix-diff.cabal view
@@ -1,15 +1,15 @@ name: nix-diff-version: 1.0.18+version: 1.0.19 synopsis: Explain why two Nix derivations differ description: This package provides a @nix-diff@ executable which explains why two Nix derivations (i.e. @*.drv@ files) differ-homepage: https://github.com/Gabriel439/nix-diff+homepage: https://github.com/Gabriella439/nix-diff license: BSD3 license-file: LICENSE-author: Gabriel Gonzalez-maintainer: Gabriel439@gmail.com-copyright: 2017 Gabriel Gonzalez+author: Gabriella Gonzalez+maintainer: GenuineGabriella@gmail.com+copyright: 2017 Gabriella Gonzalez category: System build-type: Simple tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.8.3@@ -17,22 +17,73 @@ extra-source-files: README.md CHANGELOG.md -executable nix-diff- main-is: Main.hs+library+ exposed-modules:+ Nix.Diff+ Nix.Diff.Types+ Nix.Diff.Transformations+ Nix.Diff.Render.HumanReadable build-depends: base >= 4.9 && < 5 , attoparsec >= 0.13 && < 0.15+ , aeson , bytestring >= 0.9 && < 0.12 , containers >= 0.5 && < 0.7 , directory < 1.4 , mtl >= 2.2 && < 2.3 , nix-derivation >= 1.1 && < 1.2- , optparse-applicative >= 0.14.0.0 && < 0.17+ , optparse-applicative >= 0.14.0.0 && < 0.18 , patience >= 0.3 && < 0.4 , text >= 1.2 && < 1.3- , unix < 2.8 , vector >= 0.12 && < 0.13 , process < 1.7 , filepath < 1.5+ , QuickCheck < 2.15+ , quickcheck-instances < 3.29+ , generic-arbitrary < 1.1+ , uniplate < 1.17 hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall++executable nix-diff+ main-is: Main.hs++ build-depends: base+ , nix-diff+ , aeson+ , bytestring+ , optparse-applicative >= 0.14.0.0 && < 0.17+ , text+ , unix < 2.8+ , containers+ , mtl+ hs-source-dirs: app+ default-language: Haskell2010+ ghc-options: -Wall++test-suite nix-diff-test+ main-is: Main.hs++ other-modules:+ Properties+ Golden.Tests+ Golden.Utils++ type: exitcode-stdio-1.0++ build-depends: base+ , nix-diff+ , aeson+ , bytestring+ , text+ , containers+ , mtl+ , typed-process < 0.2.11+ , tasty < 1.5+ , tasty-quickcheck < 0.11+ , tasty-silver < 3.4++ hs-source-dirs: test+ default-language: Haskell2010 ghc-options: -Wall
− src/Main.hs
@@ -1,749 +0,0 @@-{-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}--module Main where--import Control.Applicative ((<|>))-import Control.Monad (forM, forM_)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Reader (MonadReader, ReaderT, ask, local)-import Control.Monad.State (MonadState, StateT, get, put)-import Data.Attoparsec.Text (IResult(..))-import Data.List.NonEmpty (NonEmpty(..))-import Data.Map (Map)-import Data.Monoid ((<>))-import Data.Set (Set)-import Data.Text (Text)-import Data.Vector (Vector)-import Nix.Derivation (Derivation, DerivationOutput)-import Numeric.Natural (Natural)-import Options.Applicative (Parser, ParserInfo)--import qualified Control.Monad as Monad-import qualified Control.Monad.Reader-import qualified Control.Monad.State-import qualified Data.Attoparsec.Text-import qualified Data.Char as Char-import qualified Data.List.NonEmpty-import qualified Data.Map-import qualified Data.Set-import qualified Data.String as String-import qualified Data.Text as Text-import qualified Data.Text.IO as Text.IO-import qualified Data.Vector-import qualified GHC.IO.Encoding-import qualified Nix.Derivation-import qualified Options.Applicative-import qualified Patience-import qualified System.Directory as Directory-import qualified System.FilePath as FilePath-import qualified System.Posix.IO-import qualified System.Posix.Terminal-import qualified System.Process as Process--#if MIN_VERSION_base(4,9,0)-import Control.Monad.Fail (MonadFail)-import qualified Data.ByteString-import qualified Data.Text.Encoding-import qualified Data.Text.Encoding.Error-#endif--data Color = Always | Auto | Never--parseColor :: Parser Color-parseColor =- Options.Applicative.option- reader- ( Options.Applicative.long "color"- <> Options.Applicative.help ("display colors always, automatically (if terminal detected), or never")- <> Options.Applicative.value Auto- <> Options.Applicative.metavar "(always|auto|never)"- )- where- reader = do- string <- Options.Applicative.str- case string :: Text of- "always" -> return Always- "auto" -> return Auto- "never" -> return Never- _ -> fail "Invalid color"--parseLineOriented :: Parser Orientation-parseLineOriented =- per "line" Line- <|> per "character" Character- <|> per "word" Word- <|> pure Word- where- per x orientation =- Options.Applicative.flag' orientation- ( Options.Applicative.long (x <> "-oriented")- <> Options.Applicative.help ("Display textual differences on a per-" <> x <> " basis")- )--parseEnvironment :: Parser Bool-parseEnvironment =- Options.Applicative.switch- ( Options.Applicative.long "environment"- <> Options.Applicative.help "Force display of environment differences"- )--data Options = Options- { left :: FilePath- , right :: FilePath- , color :: Color- , orientation :: Orientation- , environment :: Bool- }--data Orientation = Character | Word | Line--parseOptions :: Parser Options-parseOptions = do- left <- parseLeft- right <- parseRight- color <- parseColor- orientation <- parseLineOriented- environment <- parseEnvironment-- return (Options { left, right, color, orientation, environment })- where- parseFilePath metavar = do- Options.Applicative.strArgument- (Options.Applicative.metavar metavar)-- parseLeft = parseFilePath "LEFT"-- parseRight = parseFilePath "RIGHT"--parserInfo :: ParserInfo Options-parserInfo =- Options.Applicative.info- (Options.Applicative.helper <*> parseOptions)- ( Options.Applicative.fullDesc- <> Options.Applicative.header "Explain why two derivations differ"- )--data Context = Context- { tty :: TTY- , indent :: Natural- , orientation :: Orientation- , environment :: Bool- }--newtype Status = Status { visited :: Set Diffed }--data Diffed = Diffed- { leftDerivation :: FilePath- , leftOutput :: Set Text- , rightDerivation :: FilePath- , rightOutput :: Set Text- } deriving (Eq, Ord)--newtype Diff a = Diff { unDiff :: ReaderT Context (StateT Status IO) a }- deriving- ( Functor- , Applicative- , Monad- , MonadReader Context- , MonadState Status- , MonadIO-#if MIN_VERSION_base(4,9,0)- , MonadFail-#endif- )--echo :: Text -> Diff ()-echo text = do- Context { indent } <- ask- let n = fromIntegral indent- liftIO (Text.IO.putStrLn (Text.replicate n " " <> text))--indented :: Natural -> Diff a -> Diff a-indented n = local adapt- where- adapt context = context { indent = indent context + n }--{-| Extract the name of a derivation (i.e. the part after the hash)-- This is used to guess which derivations are related to one another, even- though their hash might differ-- Note that this assumes that the path name is:-- > /nix/store/${32_CHARACTER_HASH}-${NAME}.drv-- Nix technically does not require that the Nix store is actually stored- underneath `/nix/store`, but this is the overwhelmingly common use case--}-derivationName :: FilePath -> Text-derivationName = Text.dropEnd 4 . Text.drop 44 . Text.pack---- | Group paths by their name-groupByName :: Map FilePath a -> Map Text (Map FilePath a)-groupByName m = Data.Map.fromList assocs- where- toAssoc key = (derivationName key, Data.Map.filterWithKey predicate m)- where- predicate key' _ = derivationName key == derivationName key'-- assocs = fmap toAssoc (Data.Map.keys m)--{-| Extract the name of a build product-- Similar to `derivationName`, this assumes that the path name is:-- > /nix/store/${32_CHARACTER_HASH}-${NAME}.drv--}-buildProductName :: FilePath -> Text-buildProductName = Text.drop 44 . Text.pack---- | Like `groupByName`, but for `Set`s-groupSetsByName :: Set FilePath -> Map Text (Set FilePath)-groupSetsByName s = Data.Map.fromList (fmap toAssoc (Data.Set.toList s))- where- toAssoc key = (buildProductName key, Data.Set.filter predicate s)- where- predicate key' = buildProductName key == buildProductName key'---- | Read a file as utf-8 encoded string, replacing non-utf-8 characters--- with the unicode replacement character.--- This is necessary since derivations (and nix source code!) can in principle--- contain arbitrary bytes, but `nix-derivation` can only parse from 'Text'.-readFileUtf8Lenient :: FilePath -> IO Text-readFileUtf8Lenient file =- Data.Text.Encoding.decodeUtf8With Data.Text.Encoding.Error.lenientDecode- <$> Data.ByteString.readFile file---- | Read and parse a derivation from a file-readDerivation :: FilePath -> Diff (Derivation FilePath Text)-readDerivation path = do- let string = path- text <- liftIO (readFileUtf8Lenient string)- case Data.Attoparsec.Text.parse Nix.Derivation.parseDerivation text of- Done _ derivation -> do- return derivation- _ -> do- fail ("Could not parse a derivation from this file: " ++ string)---- | Read and parse a derivation from a store path that can be a derivation--- (.drv) or a realized path, in which case the corresponding derivation is--- queried.-readInput :: FilePath -> Diff (Derivation FilePath Text)-readInput path =- if FilePath.isExtensionOf ".drv" path- then readDerivation path- else do- let string = path- result <- liftIO (Process.readProcess "nix-store" [ "--query", "--deriver", string ] [])- case String.lines result of- [] -> fail ("Could not obtain the derivation of " ++ string)- l : ls -> do- let drv_path = Data.List.NonEmpty.last (l :| ls)- readDerivation drv_path--{-| Join two `Map`s on shared keys, discarding keys which are not present in- both `Map`s--}-innerJoin :: Ord k => Map k a -> Map k b -> Map k (a, b)-innerJoin = Data.Map.mergeWithKey both left right- where- both _ a b = Just (a, b)-- left _ = Data.Map.empty-- right _ = Data.Map.empty--data TTY = IsTTY | NotTTY---- | Color text red-red :: TTY -> Text -> Text-red IsTTY text = "\ESC[1;31m" <> text <> "\ESC[0m"-red NotTTY text = text---- | Color text background red-redBackground :: Orientation -> TTY -> Text -> Text-redBackground Line IsTTY text = "\ESC[41m" <> prefix <> "\ESC[0m" <> suffix- where- (prefix, suffix) = Text.break lineBoundary text-redBackground Word IsTTY text = "\ESC[41m" <> prefix <> "\ESC[0m" <> suffix- where- (prefix, suffix) = Text.break wordBoundary text-redBackground Character IsTTY text = "\ESC[41m" <> text <> "\ESC[0m"-redBackground Line NotTTY text = "- " <> text-redBackground _ NotTTY text = "←" <> text <> "←"---- | Color text green-green :: TTY -> Text -> Text-green IsTTY text = "\ESC[1;32m" <> text <> "\ESC[0m"-green NotTTY text = text---- | Color text background green-greenBackground :: Orientation -> TTY -> Text -> Text-greenBackground Line IsTTY text = "\ESC[42m" <> prefix <> "\ESC[0m" <> suffix- where- (prefix, suffix) = Text.break lineBoundary text-greenBackground Word IsTTY text = "\ESC[42m" <> prefix <> "\ESC[0m" <> suffix- where- (prefix, suffix) = Text.break wordBoundary text-greenBackground Character IsTTY text = "\ESC[42m" <> text <> "\ESC[0m"-greenBackground Line NotTTY text = "+ " <> text-greenBackground _ NotTTY text = "→" <> text <> "→"---- | Color text grey-grey :: Orientation -> TTY -> Text -> Text-grey _ IsTTY text = "\ESC[1;2m" <> text <> "\ESC[0m"-grey Line NotTTY text = " " <> text-grey _ NotTTY text = text---- | Format the left half of a diff-minus :: TTY -> Text -> Text-minus tty text = red tty ("- " <> text)---- | Format the right half of a diff-plus :: TTY -> Text -> Text-plus tty text = green tty ("+ " <> text)---- | Format text explaining a diff-explain :: Text -> Text-explain text = "• " <> text---- `getGroupedDiff` from `Diff` library, adapted for `patience`-getGroupedDiff :: Ord a => [a] -> [a] -> [Patience.Item [a]]-getGroupedDiff oldList newList = go $ Patience.diff oldList newList- where- go = \case- Patience.Old x : xs ->- let (fs, rest) = goOlds xs- in Patience.Old (x : fs) : go rest- Patience.New x : xs ->- let (fs, rest) = goNews xs- in Patience.New (x : fs) : go rest- Patience.Both x y : xs ->- let (fs, rest) = goBoth xs- (fxs, fys) = unzip fs- in Patience.Both (x : fxs) (y : fys) : go rest- [] -> []-- goOlds = \case- Patience.Old x : xs ->- let (fs, rest) = goOlds xs- in (x : fs, rest)- xs -> ([], xs)-- goNews = \case- Patience.New x : xs ->- let (fs, rest) = goNews xs- in (x : fs, rest)- xs -> ([], xs)-- goBoth = \case- Patience.Both x y : xs ->- let (fs, rest) = goBoth xs- in ((x, y) : fs, rest)- xs -> ([], xs)--{-| Utility to automate a common pattern of printing the two halves of a diff.- This passes the correct formatting function to each half--}-diffWith :: a -> a -> ((Text -> Text, a) -> Diff ()) -> Diff ()-diffWith l r k = do- Context { tty } <- ask- k (minus tty, l)- k (plus tty, r)---- | Format the derivation outputs-renderOutputs :: Set Text -> Text-renderOutputs outputs =- ":{" <> Text.intercalate "," (Data.Set.toList outputs) <> "}"---- | Diff two outputs-diffOutput- :: Text- -- ^ Output name- -> (DerivationOutput FilePath Text)- -- ^ Left derivation outputs- -> (DerivationOutput FilePath Text)- -- ^ Right derivation outputs- -> Diff ()-diffOutput outputName leftOutput rightOutput = do- -- We deliberately do not include output paths or hashes in the diff since- -- we already expect them to differ if the inputs differ. Instead, we focus- -- only displaying differing inputs.- let leftHashAlgo = Nix.Derivation.hashAlgo leftOutput- let rightHashAlgo = Nix.Derivation.hashAlgo rightOutput- if leftHashAlgo == rightHashAlgo- then return ()- else do- echo (explain ("{" <> outputName <> "}:"))- echo (explain " Hash algorithm:")- diffWith leftHashAlgo rightHashAlgo \(sign, hashAlgo) -> do- echo (" " <> sign hashAlgo)---- | Diff two sets of outputs-diffOutputs- :: Map Text (DerivationOutput FilePath Text)- -- ^ Left derivation outputs- -> Map Text (DerivationOutput FilePath Text)- -- ^ Right derivation outputs- -> Diff ()-diffOutputs leftOutputs rightOutputs = do- let leftExtraOutputs = Data.Map.difference leftOutputs rightOutputs- let rightExtraOutputs = Data.Map.difference rightOutputs leftOutputs-- let bothOutputs = innerJoin leftOutputs rightOutputs-- if Data.Map.null leftExtraOutputs && Data.Map.null rightExtraOutputs- then return ()- else do- echo (explain "The set of outputs do not match:")- diffWith leftExtraOutputs rightExtraOutputs \(sign, extraOutputs) -> do- forM_ (Data.Map.toList extraOutputs) \(key, _value) -> do- echo (" " <> sign ("{" <> key <> "}"))- forM_ (Data.Map.toList bothOutputs) \(key, (leftOutput, rightOutput)) -> do- if leftOutput == rightOutput- then return ()- else diffOutput key leftOutput rightOutput--mapDiff :: (a -> b) -> Patience.Item a -> Patience.Item b-mapDiff f (Patience.Old l ) = Patience.Old (f l)-mapDiff f (Patience.New r) = Patience.New (f r)-mapDiff f (Patience.Both l r) = Patience.Both (f l) (f r)--{-| Split `Text` into spans of `Text` that alternatively fail and satisfy the- given predicate-- The first span (if present) does not satisfy the predicate (even if the- span is empty)-- >>> decomposeOn (== 'b') "aabbaa"- ["aa","bb","aa"]- >>> decomposeOn (== 'b') "bbaa"- ["","bb","aa"]- >>> decomposeOn (== 'b') ""- []--}-decomposeOn :: (Char -> Bool) -> Text -> [Text]-decomposeOn predicate = unsatisfy- where- unsatisfy text- | Text.null text = []- | otherwise = prefix : satisfy suffix- where- (prefix, suffix) = Text.break predicate text-- satisfy text- | Text.null text = []- | otherwise = prefix : unsatisfy suffix- where- (prefix, suffix) = Text.span predicate text--lineBoundary :: Char -> Bool-lineBoundary = ('\n' ==)--wordBoundary :: Char -> Bool-wordBoundary = Char.isSpace---- | Diff two `Text` values-diffText- :: Text- -- ^ Left value to compare- -> Text- -- ^ Right value to compare- -> Diff Text-diffText left right = do- Context{ indent, orientation, tty } <- ask-- let n = fromIntegral indent-- let leftString = Text.unpack left- let rightString = Text.unpack right-- let decomposeWords = decomposeOn wordBoundary-- let decomposeLines text = loop (decomposeOn lineBoundary text)- where- -- Groups each newline character with the preceding line- loop (x : y : zs) = (x <> y) : loop zs- loop zs = zs-- let leftWords = decomposeWords left- let rightWords = decomposeWords right-- let leftLines = decomposeLines left- let rightLines = decomposeLines right-- let chunks =- case orientation of- Character ->- fmap (mapDiff Text.pack) (getGroupedDiff leftString rightString)- Word ->- Patience.diff leftWords rightWords- Line ->- Patience.diff leftLines rightLines- let prefix = Text.replicate n " "-- let format text =- if 80 <= n + Text.length text- then "''\n" <> indentedText <> prefix <> "''"- else text- where- indentedText =- (Text.unlines . fmap indentLine . Text.lines) text- where- indentLine line = prefix <> " " <> line-- let renderChunk (Patience.Old l ) =- redBackground orientation tty l- renderChunk (Patience.New r) =- greenBackground orientation tty r- renderChunk (Patience.Both l _) =- grey orientation tty l-- return (format (Text.concat (fmap renderChunk chunks)))---- | Diff two environments-diffEnv- :: Set Text- -- ^ Left derivation outputs- -> Set Text- -- ^ Right derivation outputs- -> Map Text Text- -- ^ Left environment to compare- -> Map Text Text- -- ^ Right environment to compare- -> Diff ()-diffEnv leftOutputs rightOutputs leftEnv rightEnv = do- let leftExtraEnv = Data.Map.difference leftEnv rightEnv- let rightExtraEnv = Data.Map.difference rightEnv leftEnv-- let bothEnv = innerJoin leftEnv rightEnv-- let predicate key (left, right) =- left == right- || ( Data.Set.member key leftOutputs- && Data.Set.member key rightOutputs- )- || key == "builder"- || key == "system"-- if Data.Map.null leftExtraEnv- && Data.Map.null rightExtraEnv- && Data.Map.null- (Data.Map.filterWithKey (\k v -> not (predicate k v)) bothEnv)- then return ()- else do- echo (explain "The environments do not match:")- diffWith leftExtraEnv rightExtraEnv \(sign, extraEnv) -> do- forM_ (Data.Map.toList extraEnv) \(key, value) -> do- echo (" " <> sign (key <> "=" <> value))- forM_ (Data.Map.toList bothEnv) \(key, (leftValue, rightValue)) -> do- if predicate key (leftValue, rightValue)- then return ()- else do- text <- diffText leftValue rightValue- echo (" " <> key <> "=" <> text)---- | Diff input sources-diffSrcs- :: Set FilePath- -- ^ Left input sources- -> Set FilePath- -- ^ Right inputSources- -> Diff ()-diffSrcs leftSrcs rightSrcs = do- let groupedLeftSrcs = groupSetsByName leftSrcs- let groupedRightSrcs = groupSetsByName rightSrcs-- let leftNames = Data.Map.keysSet groupedLeftSrcs- let rightNames = Data.Map.keysSet groupedRightSrcs-- let leftExtraNames = Data.Set.difference leftNames rightNames- let rightExtraNames = Data.Set.difference rightNames leftNames-- Monad.when (leftNames /= rightNames) do- echo (explain "The set of input source names do not match:")- diffWith leftExtraNames rightExtraNames \(sign, names) -> do- forM_ names \name -> do- echo (" " <> sign name)-- let assocs = Data.Map.toList (innerJoin groupedLeftSrcs groupedRightSrcs)-- forM_ assocs \(inputName, (leftPaths, rightPaths)) -> do- let leftExtraPaths = Data.Set.difference leftPaths rightPaths- let rightExtraPaths = Data.Set.difference rightPaths leftPaths- case (Data.Set.toList leftExtraPaths, Data.Set.toList rightExtraPaths) of- ([], []) -> return ()- ([leftPath], [rightPath]) -> do- echo (explain ("The input source named `" <> inputName <> "` differs"))- leftExists <- liftIO (Directory.doesFileExist leftPath)- rightExists <- liftIO (Directory.doesFileExist rightPath)- if leftExists && rightExists- then do- leftText <- liftIO (readFileUtf8Lenient leftPath)- rightText <- liftIO (readFileUtf8Lenient rightPath)-- text <- diffText leftText rightText- echo (" " <> text)- else do- return ()- return ()- (leftExtraPathsList, rightExtraPathsList) -> do- echo (explain ("The input sources named `" <> inputName <> "` differ"))- diffWith leftExtraPathsList rightExtraPathsList \(sign, paths) -> do- forM_ paths \path -> do- echo (" " <> sign (Text.pack path))--diffPlatform :: Text -> Text -> Diff ()-diffPlatform leftPlatform rightPlatform = do- if leftPlatform == rightPlatform- then return ()- else do- echo (explain "The platforms do not match")- diffWith leftPlatform rightPlatform \(sign, platform) -> do- echo (" " <> sign platform)--diffBuilder :: Text -> Text -> Diff ()-diffBuilder leftBuilder rightBuilder = do- if leftBuilder == rightBuilder- then return ()- else do- echo (explain "The builders do not match")- diffWith leftBuilder rightBuilder \(sign, builder) -> do- echo (" " <> sign builder)--diffArgs :: Vector Text -> Vector Text -> Diff ()-diffArgs leftArgs rightArgs = do- Context { tty } <- ask- if leftArgs == rightArgs- then return ()- else do- echo (explain "The arguments do not match")- let leftList = Data.Vector.toList leftArgs- let rightList = Data.Vector.toList rightArgs- let diffs = Patience.diff leftList rightList- let renderDiff (Patience.Old arg) =- echo (" " <> minus tty arg)- renderDiff (Patience.New arg) =- echo (" " <> plus tty arg)- renderDiff (Patience.Both arg _) =- echo (" " <> explain arg)- mapM_ renderDiff diffs--diff :: Bool -> FilePath -> Set Text -> FilePath -> Set Text -> Diff ()-diff topLevel leftPath leftOutputs rightPath rightOutputs = do- Status { visited } <- get- let diffed = Diffed leftPath leftOutputs rightPath rightOutputs- if leftPath == rightPath- then return ()- else if Data.Set.member diffed visited- then do- echo (explain "These two derivations have already been compared")- else do- put (Status (Data.Set.insert diffed visited))- diffWith (leftPath, leftOutputs) (rightPath, rightOutputs) \(sign, (path, outputs)) -> do- echo (sign (Text.pack path <> renderOutputs outputs))-- if derivationName leftPath /= derivationName rightPath && not topLevel- then do- echo (explain "The derivation names do not match")- else if leftOutputs /= rightOutputs- then do- echo (explain "The requested outputs do not match")- else do- leftDerivation <- readInput leftPath- rightDerivation <- readInput rightPath-- let leftOuts = Nix.Derivation.outputs leftDerivation- let rightOuts = Nix.Derivation.outputs rightDerivation- diffOutputs leftOuts rightOuts-- let leftPlatform = Nix.Derivation.platform leftDerivation- let rightPlatform = Nix.Derivation.platform rightDerivation- diffPlatform leftPlatform rightPlatform-- let leftBuilder = Nix.Derivation.builder leftDerivation- let rightBuilder = Nix.Derivation.builder rightDerivation- diffBuilder leftBuilder rightBuilder-- let leftArgs = Nix.Derivation.args leftDerivation- let rightArgs = Nix.Derivation.args rightDerivation- diffArgs leftArgs rightArgs-- let leftSrcs = Nix.Derivation.inputSrcs leftDerivation- let rightSrcs = Nix.Derivation.inputSrcs rightDerivation- diffSrcs leftSrcs rightSrcs-- let leftInputs = groupByName (Nix.Derivation.inputDrvs leftDerivation)- let rightInputs = groupByName (Nix.Derivation.inputDrvs rightDerivation)-- let leftNames = Data.Map.keysSet leftInputs- let rightNames = Data.Map.keysSet rightInputs- let leftExtraNames = Data.Set.difference leftNames rightNames- let rightExtraNames = Data.Set.difference rightNames leftNames-- Monad.when (leftNames /= rightNames) do- echo (explain "The set of input derivation names do not match:")- diffWith leftExtraNames rightExtraNames \(sign, names) -> do- forM_ names \name -> do- echo (" " <> sign name)-- let assocs = Data.Map.toList (innerJoin leftInputs rightInputs)- descended <- forM assocs \(inputName, (leftPaths, rightPaths)) -> do- let leftExtraPaths =- Data.Map.difference leftPaths rightPaths- let rightExtraPaths =- Data.Map.difference rightPaths leftPaths- case (Data.Map.toList leftExtraPaths, Data.Map.toList rightExtraPaths) of- _ | leftPaths == rightPaths -> do- return False- ([(leftPath', leftOutputs')], [(rightPath', rightOutputs')])- | leftOutputs' == rightOutputs' -> do- echo (explain ("The input derivation named `" <> inputName <> "` differs"))- indented 2 (diff False leftPath' leftOutputs' rightPath' rightOutputs')- return True- _ -> do- echo (explain ("The set of input derivations named `" <> inputName <> "` do not match"))- diffWith leftExtraPaths rightExtraPaths \(sign, extraPaths) -> do- forM_ (Data.Map.toList extraPaths) \(extraPath, outputs) -> do- echo (" " <> sign (Text.pack extraPath <> renderOutputs outputs))- return False-- Context { environment } <- ask-- if or descended && not environment- then do- echo (explain "Skipping environment comparison")- else do- let leftEnv = Nix.Derivation.env leftDerivation- let rightEnv = Nix.Derivation.env rightDerivation- let leftOutNames = Data.Map.keysSet leftOuts- let rightOutNames = Data.Map.keysSet rightOuts- diffEnv leftOutNames rightOutNames leftEnv rightEnv--main :: IO ()-main = do- GHC.IO.Encoding.setLocaleEncoding GHC.IO.Encoding.utf8-- Options { left, right, color, orientation, environment } <- Options.Applicative.execParser parserInfo-- tty <- case color of- Never -> do- return NotTTY- Always -> do- return IsTTY- Auto -> do- b <- System.Posix.Terminal.queryTerminal System.Posix.IO.stdOutput- return (if b then IsTTY else NotTTY)-- let indent = 0- let context = Context { tty, indent, orientation, environment }- let status = Status Data.Set.empty- let action = diff True left (Data.Set.singleton "out") right (Data.Set.singleton "out")- Control.Monad.State.evalStateT (Control.Monad.Reader.runReaderT (unDiff action) context) status
+ src/Nix/Diff.hs view
@@ -0,0 +1,518 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Nix.Diff where++import Control.Monad (forM)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Reader (MonadReader, ReaderT, ask)+import Control.Monad.State (MonadState, StateT, get, put)+import Data.Attoparsec.Text (IResult(..))+import Data.List.NonEmpty (NonEmpty(..))+import Data.Map (Map)+import Data.Maybe (catMaybes)+import Data.Set (Set)+import Data.Text (Text)+import Data.Vector (Vector)+import Nix.Derivation (Derivation, DerivationOutput)++import qualified Control.Monad.Reader+import qualified Data.Attoparsec.Text+import qualified Data.ByteString+import qualified Data.Char as Char+import qualified Data.List as List+import qualified Data.List.NonEmpty+import qualified Data.Map+import qualified Data.Set+import qualified Data.String as String+import qualified Data.Text as Text+import qualified Data.Text.Encoding+import qualified Data.Text.Encoding.Error+import qualified Data.Vector+import qualified Nix.Derivation+import qualified Patience+import qualified System.Directory as Directory+import qualified System.FilePath as FilePath+import qualified System.Process as Process++#if !MIN_VERSION_base(4,15,1)+import Control.Monad.Fail (MonadFail)+#endif++import Nix.Diff.Types++newtype Status = Status { visited :: Set Diffed }++data Diffed = Diffed+ { leftDerivation :: FilePath+ , leftOutput :: Set Text+ , rightDerivation :: FilePath+ , rightOutput :: Set Text+ } deriving (Eq, Ord)++newtype Diff a = Diff { unDiff :: ReaderT DiffContext (StateT Status IO) a }+ deriving+ ( Functor+ , Applicative+ , Monad+ , MonadReader DiffContext+ , MonadState Status+ , MonadIO+#if MIN_VERSION_base(4,9,0)+ , MonadFail+#endif+ )++data DiffContext = DiffContext+ { orientation :: Orientation+ , environment :: Bool+ }++data Orientation = Character | Word | Line++{-| Extract the name of a derivation (i.e. the part after the hash)++ This is used to guess which derivations are related to one another, even+ though their hash might differ++ Note that this assumes that the path name is:++ > /nix/store/${32_CHARACTER_HASH}-${NAME}.drv++ Nix technically does not require that the Nix store is actually stored+ underneath `/nix/store`, but this is the overwhelmingly common use case+-}+derivationName :: FilePath -> Text+derivationName = Text.dropEnd 4 . Text.drop 44 . Text.pack++-- | Group paths by their name+groupByName :: Map FilePath a -> Map Text (Map FilePath a)+groupByName m = Data.Map.fromList assocs+ where+ toAssoc key = (derivationName key, Data.Map.filterWithKey predicate m)+ where+ predicate key' _ = derivationName key == derivationName key'++ assocs = fmap toAssoc (Data.Map.keys m)++{-| Extract the name of a build product++ Similar to `derivationName`, this assumes that the path name is:++ > /nix/store/${32_CHARACTER_HASH}-${NAME}.drv+-}+buildProductName :: FilePath -> Text+buildProductName = Text.drop 44 . Text.pack++-- | Like `groupByName`, but for `Set`s+groupSetsByName :: Set FilePath -> Map Text (Set FilePath)+groupSetsByName s = Data.Map.fromList (fmap toAssoc (Data.Set.toList s))+ where+ toAssoc key = (buildProductName key, Data.Set.filter predicate s)+ where+ predicate key' = buildProductName key == buildProductName key'++-- | Read a file as utf-8 encoded string, replacing non-utf-8 characters+-- with the unicode replacement character.+-- This is necessary since derivations (and nix source code!) can in principle+-- contain arbitrary bytes, but `nix-derivation` can only parse from 'Text'.+readFileUtf8Lenient :: FilePath -> IO Text+readFileUtf8Lenient file =+ Data.Text.Encoding.decodeUtf8With Data.Text.Encoding.Error.lenientDecode+ <$> Data.ByteString.readFile file++-- | Read and parse a derivation from a file+readDerivation :: FilePath -> Diff (Derivation FilePath Text)+readDerivation path = do+ let string = path+ text <- liftIO (readFileUtf8Lenient string)+ case Data.Attoparsec.Text.parse Nix.Derivation.parseDerivation text of+ Done _ derivation -> do+ return derivation+ _ -> do+ fail ("Could not parse a derivation from this file: " ++ string)++-- | Read and parse a derivation from a store path that can be a derivation+-- (.drv) or a realized path, in which case the corresponding derivation is+-- queried.+readInput :: FilePath -> Diff (Derivation FilePath Text)+readInput pathAndMaybeOutput = do+ let (path, _) = List.break (== '!') pathAndMaybeOutput+ if FilePath.isExtensionOf ".drv" path+ then readDerivation path+ else do+ let string = path+ result <- liftIO (Process.readProcess "nix-store" [ "--query", "--deriver", string ] [])+ case String.lines result of+ [] -> fail ("Could not obtain the derivation of " ++ string)+ l : ls -> do+ let drv_path = Data.List.NonEmpty.last (l :| ls)+ readDerivation drv_path++{-| Join two `Map`s on shared keys, discarding keys which are not present in+ both `Map`s+-}+innerJoin :: Ord k => Map k a -> Map k b -> Map k (a, b)+innerJoin = Data.Map.mergeWithKey both left right+ where+ both _ a b = Just (a, b)++ left _ = Data.Map.empty++ right _ = Data.Map.empty++-- `getGroupedDiff` from `Diff` library, adapted for `patience`+getGroupedDiff :: Ord a => [a] -> [a] -> [Patience.Item [a]]+getGroupedDiff oldList newList = go $ Patience.diff oldList newList+ where+ go = \case+ Patience.Old x : xs ->+ let (fs, rest) = goOlds xs+ in Patience.Old (x : fs) : go rest+ Patience.New x : xs ->+ let (fs, rest) = goNews xs+ in Patience.New (x : fs) : go rest+ Patience.Both x y : xs ->+ let (fs, rest) = goBoth xs+ (fxs, fys) = unzip fs+ in Patience.Both (x : fxs) (y : fys) : go rest+ [] -> []++ goOlds = \case+ Patience.Old x : xs ->+ let (fs, rest) = goOlds xs+ in (x : fs, rest)+ xs -> ([], xs)++ goNews = \case+ Patience.New x : xs ->+ let (fs, rest) = goNews xs+ in (x : fs, rest)+ xs -> ([], xs)++ goBoth = \case+ Patience.Both x y : xs ->+ let (fs, rest) = goBoth xs+ in ((x, y) : fs, rest)+ xs -> ([], xs)++-- | Diff two outputs+diffOutput+ :: Text+ -- ^ Output name+ -> (DerivationOutput FilePath Text)+ -- ^ Left derivation outputs+ -> (DerivationOutput FilePath Text)+ -- ^ Right derivation outputs+ -> (Maybe OutputDiff)+diffOutput outputName leftOutput rightOutput = do+ -- We deliberately do not include output paths or hashes in the diff since+ -- we already expect them to differ if the inputs differ. Instead, we focus+ -- only displaying differing inputs.+ let leftHashAlgo = Nix.Derivation.hashAlgo leftOutput+ let rightHashAlgo = Nix.Derivation.hashAlgo rightOutput+ if leftHashAlgo == rightHashAlgo+ then Nothing+ else Just (OutputDiff outputName (Changed leftHashAlgo rightHashAlgo))++-- | Diff two sets of outputs+diffOutputs+ :: Map Text (DerivationOutput FilePath Text)+ -- ^ Left derivation outputs+ -> Map Text (DerivationOutput FilePath Text)+ -- ^ Right derivation outputs+ -> OutputsDiff+diffOutputs leftOutputs rightOutputs = do+ let leftExtraOutputs = Data.Map.difference leftOutputs rightOutputs+ let rightExtraOutputs = Data.Map.difference rightOutputs leftOutputs++ let bothOutputs = innerJoin leftOutputs rightOutputs++ let+ extraOutputs =+ if Data.Map.null leftExtraOutputs && Data.Map.null rightExtraOutputs+ then Nothing+ else Just (Changed leftExtraOutputs rightExtraOutputs)+ let+ outputDifference = flip map (Data.Map.toList bothOutputs) \(key, (leftOutput, rightOutput)) -> do+ if leftOutput == rightOutput+ then Nothing+ else Just (diffOutput key leftOutput rightOutput)++ OutputsDiff extraOutputs (catMaybes . catMaybes $ outputDifference)++{-| Split `Text` into spans of `Text` that alternatively fail and satisfy the+ given predicate++ The first span (if present) does not satisfy the predicate (even if the+ span is empty)++ >>> decomposeOn (== 'b') "aabbaa"+ ["aa","bb","aa"]+ >>> decomposeOn (== 'b') "bbaa"+ ["","bb","aa"]+ >>> decomposeOn (== 'b') ""+ []+-}+decomposeOn :: (Char -> Bool) -> Text -> [Text]+decomposeOn predicate = unsatisfy+ where+ unsatisfy text+ | Text.null text = []+ | otherwise = prefix : satisfy suffix+ where+ (prefix, suffix) = Text.break predicate text++ satisfy text+ | Text.null text = []+ | otherwise = prefix : unsatisfy suffix+ where+ (prefix, suffix) = Text.span predicate text++lineBoundary :: Char -> Bool+lineBoundary = ('\n' ==)++wordBoundary :: Char -> Bool+wordBoundary = Char.isSpace++-- | Diff two `Text` values+diffText+ :: Text+ -- ^ Left value to compare+ -> Text+ -- ^ Right value to compare+ -> Diff TextDiff+ -- ^ List of blocks of diffed text+diffText left right = do+ DiffContext{ orientation } <- ask++ let leftString = Text.unpack left+ let rightString = Text.unpack right++ let decomposeWords = decomposeOn wordBoundary++ let decomposeLines text = loop (decomposeOn lineBoundary text)+ where+ -- Groups each newline character with the preceding line+ loop (x : y : zs) = (x <> y) : loop zs+ loop zs = zs++ let leftWords = decomposeWords left+ let rightWords = decomposeWords right++ let leftLines = decomposeLines left+ let rightLines = decomposeLines right++ let chunks =+ case orientation of+ Character ->+ fmap (fmap Text.pack) (getGroupedDiff leftString rightString)+ Word ->+ Patience.diff leftWords rightWords+ Line ->+ Patience.diff leftLines rightLines++ return (TextDiff chunks)++-- | Diff two environments+diffEnv+ :: Set Text+ -- ^ Left derivation outputs+ -> Set Text+ -- ^ Right derivation outputs+ -> Map Text Text+ -- ^ Left environment to compare+ -> Map Text Text+ -- ^ Right environment to compare+ -> Diff EnvironmentDiff+diffEnv leftOutputs rightOutputs leftEnv rightEnv = do+ let leftExtraEnv = Data.Map.difference leftEnv rightEnv+ let rightExtraEnv = Data.Map.difference rightEnv leftEnv++ let bothEnv = innerJoin leftEnv rightEnv++ let predicate key (left, right) =+ left == right+ || ( Data.Set.member key leftOutputs+ && Data.Set.member key rightOutputs+ )+ || key == "builder"+ || key == "system"++ if Data.Map.null leftExtraEnv+ && Data.Map.null rightExtraEnv+ && Data.Map.null+ (Data.Map.filterWithKey (\k v -> not (predicate k v)) bothEnv)+ then return EnvironmentsAreEqual+ else do+ let extraEnvDiff = Changed leftExtraEnv rightExtraEnv+ envDiff <- forM (Data.Map.toList bothEnv) \(key, (leftValue, rightValue)) -> do+ if predicate key (leftValue, rightValue)+ then return Nothing+ else do+ valueDiff <- diffText leftValue rightValue+ pure (Just (EnvVarDiff key valueDiff))+ pure (EnvironmentDiff extraEnvDiff (catMaybes envDiff))+++-- | Diff input sources+diffSrcs+ :: Set FilePath+ -- ^ Left input sources+ -> Set FilePath+ -- ^ Right inputSources+ -> Diff SourcesDiff+diffSrcs leftSrcs rightSrcs = do+ let groupedLeftSrcs = groupSetsByName leftSrcs+ let groupedRightSrcs = groupSetsByName rightSrcs++ let leftNames = Data.Map.keysSet groupedLeftSrcs+ let rightNames = Data.Map.keysSet groupedRightSrcs++ let leftExtraNames = Data.Set.difference leftNames rightNames+ let rightExtraNames = Data.Set.difference rightNames leftNames++ let extraSrcNames = if (leftNames /= rightNames)+ then Just (Changed leftExtraNames rightExtraNames)+ else Nothing++ let assocs = Data.Map.toList (innerJoin groupedLeftSrcs groupedRightSrcs)++ srcFilesDiff <- forM assocs \(inputName, (leftPaths, rightPaths)) -> do+ let leftExtraPaths = Data.Set.difference leftPaths rightPaths+ let rightExtraPaths = Data.Set.difference rightPaths leftPaths+ case (Data.Set.toList leftExtraPaths, Data.Set.toList rightExtraPaths) of+ ([], []) -> return Nothing+ ([leftPath], [rightPath]) -> do+ leftExists <- liftIO (Directory.doesFileExist leftPath)+ rightExists <- liftIO (Directory.doesFileExist rightPath)+ srcContentDiff <- if leftExists && rightExists+ then do+ leftText <- liftIO (readFileUtf8Lenient leftPath)+ rightText <- liftIO (readFileUtf8Lenient rightPath)++ text <- diffText leftText rightText+ return (Just text)+ else do+ return Nothing+ return (Just (OneSourceFileDiff inputName srcContentDiff))+ (leftExtraPathsList, rightExtraPathsList) -> do+ return (Just (SomeSourceFileDiff inputName (Changed leftExtraPathsList rightExtraPathsList)))+ return (SourcesDiff extraSrcNames (catMaybes srcFilesDiff))++diffPlatform :: Text -> Text -> Maybe (Changed Platform)+diffPlatform leftPlatform rightPlatform = do+ if leftPlatform == rightPlatform+ then Nothing+ else Just (Changed leftPlatform rightPlatform)++diffBuilder :: Text -> Text -> Maybe (Changed Builder)+diffBuilder leftBuilder rightBuilder = do+ if leftBuilder == rightBuilder+ then Nothing+ else Just (Changed leftBuilder rightBuilder)++diffArgs :: Vector Text -> Vector Text -> Maybe ArgumentsDiff+diffArgs leftArgs rightArgs = fmap ArgumentsDiff do+ if leftArgs == rightArgs+ then Nothing+ else do+ let leftList = Data.Vector.toList leftArgs+ let rightList = Data.Vector.toList rightArgs+ Data.List.NonEmpty.nonEmpty (Patience.diff leftList rightList)++diff :: Bool -> FilePath -> Set Text -> FilePath -> Set Text -> Diff DerivationDiff+diff topLevel leftPath leftOutputs rightPath rightOutputs = do+ Status { visited } <- get+ let diffed = Diffed leftPath leftOutputs rightPath rightOutputs+ if leftPath == rightPath+ then return DerivationsAreTheSame+ else if Data.Set.member diffed visited+ then do+ pure AlreadyCompared+ else do+ put (Status (Data.Set.insert diffed visited))+ let+ outputStructure = Changed+ (OutputStructure leftPath leftOutputs)+ (OutputStructure rightPath rightOutputs)++ if derivationName leftPath /= derivationName rightPath && not topLevel+ then do+ pure (NamesDontMatch outputStructure)+ else if leftOutputs /= rightOutputs+ then do+ pure (OutputsDontMatch outputStructure)+ else do+ leftDerivation <- readInput leftPath+ rightDerivation <- readInput rightPath++ let leftOuts = Nix.Derivation.outputs leftDerivation+ let rightOuts = Nix.Derivation.outputs rightDerivation+ let outputsDiff = diffOutputs leftOuts rightOuts++ let leftPlatform = Nix.Derivation.platform leftDerivation+ let rightPlatform = Nix.Derivation.platform rightDerivation+ let platformDiff = diffPlatform leftPlatform rightPlatform++ let leftBuilder = Nix.Derivation.builder leftDerivation+ let rightBuilder = Nix.Derivation.builder rightDerivation+ let builderDiff = diffBuilder leftBuilder rightBuilder++ let leftArgs = Nix.Derivation.args leftDerivation+ let rightArgs = Nix.Derivation.args rightDerivation+ let argumentsDiff = diffArgs leftArgs rightArgs++ let leftSrcs = Nix.Derivation.inputSrcs leftDerivation+ let rightSrcs = Nix.Derivation.inputSrcs rightDerivation+ sourcesDiff <- diffSrcs leftSrcs rightSrcs++ let leftInputs = groupByName (Nix.Derivation.inputDrvs leftDerivation)+ let rightInputs = groupByName (Nix.Derivation.inputDrvs rightDerivation)++ let leftNames = Data.Map.keysSet leftInputs+ let rightNames = Data.Map.keysSet rightInputs+ let leftExtraNames = Data.Set.difference leftNames rightNames+ let rightExtraNames = Data.Set.difference rightNames leftNames++ let inputExtraNames = if (leftNames /= rightNames)+ then Just (Changed leftExtraNames rightExtraNames)+ else Nothing++ let assocs = Data.Map.toList (innerJoin leftInputs rightInputs)+ (descended, mInputsDiff) <- unzip <$> forM assocs \(inputName, (leftPaths, rightPaths)) -> do+ let leftExtraPaths =+ Data.Map.difference leftPaths rightPaths+ let rightExtraPaths =+ Data.Map.difference rightPaths leftPaths+ case (Data.Map.toList leftExtraPaths, Data.Map.toList rightExtraPaths) of+ _ | leftPaths == rightPaths -> do+ return (False, Nothing)+ ([(leftPath', leftOutputs')], [(rightPath', rightOutputs')])+ | leftOutputs' == rightOutputs' -> do+ drvDiff <- diff False leftPath' leftOutputs' rightPath' rightOutputs'+ return (True, Just (OneDerivationDiff inputName drvDiff))+ _ -> do+ let extraPartsDiff = Changed leftExtraPaths rightExtraPaths+ return (False, Just (SomeDerivationsDiff inputName extraPartsDiff))++ let inputDerivationDiffs = catMaybes mInputsDiff+ let inputsDiff = InputsDiff {..}++ DiffContext { environment } <- ask++ envDiff <- if or descended && not environment+ then return Nothing+ else do+ let leftEnv = Nix.Derivation.env leftDerivation+ let rightEnv = Nix.Derivation.env rightDerivation+ let leftOutNames = Data.Map.keysSet leftOuts+ let rightOutNames = Data.Map.keysSet rightOuts+ Just <$> diffEnv leftOutNames rightOutNames leftEnv rightEnv+ pure DerivationDiff{..}
+ src/Nix/Diff/Render/HumanReadable.hs view
@@ -0,0 +1,281 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Nix.Diff.Render.HumanReadable where++import Control.Monad (forM_)+import Control.Monad.Reader (MonadReader, ReaderT (runReaderT), ask, local)+import Control.Monad.Writer(MonadWriter, Writer, tell, runWriter)+import Data.Set (Set)+import Data.Text (Text)+import Numeric.Natural (Natural)++import qualified Control.Monad.Reader+import qualified Data.Map+import qualified Data.Set+import qualified Data.Text as Text+import qualified Patience++#if !MIN_VERSION_base(4,15,1)+import Control.Monad.Fail (MonadFail)+#endif++import Nix.Diff+import Nix.Diff.Types+++data RenderContext = RenderContext+ { orientation :: Orientation+ , tty :: TTY+ , indent :: Natural+ }++newtype Render a = Render { unRender :: ReaderT RenderContext (Writer Text) a}+ deriving+ ( Functor+ , Applicative+ , Monad+ , MonadReader RenderContext+ , MonadWriter Text+ )++runRender :: Render a -> RenderContext -> (a, Text)+runRender render rc = runWriter $ runReaderT (unRender render) rc++runRender' :: Render () -> RenderContext -> Text+runRender' render = snd . runRender render++echo :: Text -> Render ()+echo text = do+ RenderContext { indent } <- ask+ let n = fromIntegral indent+ tellLn (Text.replicate n " " <> text)+ where+ tellLn line = tell (line <> "\n")++indented :: Natural -> Render a -> Render a+indented n = local adapt+ where+ adapt context = context { indent = indent context + n }++data TTY = IsTTY | NotTTY++-- | Color text red+red :: TTY -> Text -> Text+red IsTTY text = "\ESC[1;31m" <> text <> "\ESC[0m"+red NotTTY text = text++-- | Color text background red+redBackground :: Orientation -> TTY -> Text -> Text+redBackground Line IsTTY text = "\ESC[41m" <> prefix <> "\ESC[0m" <> suffix+ where+ (prefix, suffix) = Text.break lineBoundary text+redBackground Word IsTTY text = "\ESC[41m" <> prefix <> "\ESC[0m" <> suffix+ where+ (prefix, suffix) = Text.break wordBoundary text+redBackground Character IsTTY text = "\ESC[41m" <> text <> "\ESC[0m"+redBackground Line NotTTY text = "- " <> text+redBackground _ NotTTY text = "←" <> text <> "←"++-- | Color text green+green :: TTY -> Text -> Text+green IsTTY text = "\ESC[1;32m" <> text <> "\ESC[0m"+green NotTTY text = text++-- | Color text background green+greenBackground :: Orientation -> TTY -> Text -> Text+greenBackground Line IsTTY text = "\ESC[42m" <> prefix <> "\ESC[0m" <> suffix+ where+ (prefix, suffix) = Text.break lineBoundary text+greenBackground Word IsTTY text = "\ESC[42m" <> prefix <> "\ESC[0m" <> suffix+ where+ (prefix, suffix) = Text.break wordBoundary text+greenBackground Character IsTTY text = "\ESC[42m" <> text <> "\ESC[0m"+greenBackground Line NotTTY text = "+ " <> text+greenBackground _ NotTTY text = "→" <> text <> "→"++-- | Color text grey+grey :: Orientation -> TTY -> Text -> Text+grey _ IsTTY text = "\ESC[1;2m" <> text <> "\ESC[0m"+grey Line NotTTY text = " " <> text+grey _ NotTTY text = text++-- | Format the left half of a diff+minus :: TTY -> Text -> Text+minus tty text = red tty ("- " <> text)++-- | Format the right half of a diff+plus :: TTY -> Text -> Text+plus tty text = green tty ("+ " <> text)++-- | Format text explaining a diff+explain :: Text -> Text+explain text = "• " <> text++{-| Utility to automate a common pattern of printing the two halves of a diff.+ This passes the correct formatting function to each half+-}+renderWith :: Changed a -> ((Text -> Text, a) -> Render ()) -> Render ()+renderWith Changed{..} k = do+ RenderContext { tty } <- ask+ k (minus tty, before)+ k (plus tty, now)++-- | Format the derivation outputs+renderOutputs :: Set Text -> Text+renderOutputs outputs =+ ":{" <> Text.intercalate "," (Data.Set.toList outputs) <> "}"++renderDiffHumanReadable :: DerivationDiff -> Render ()+renderDiffHumanReadable = \case+ DerivationsAreTheSame -> pure ()+ AlreadyCompared -> echo (explain "These two derivations have already been compared")+ OnlyAlreadyComparedBelow {..} -> do+ renderOutputStructure outputStructure+ echo (explain "Skipping because only derivations that have already been compared and shown in the diff are below")+ NamesDontMatch {..} -> do+ renderOutputStructure outputStructure+ echo (explain "The derivation names do not match")+ OutputsDontMatch {..} -> do+ renderOutputStructure outputStructure+ echo (explain "The requested outputs do not match")+ DerivationDiff {..} -> do+ renderOutputStructure outputStructure+ renderOutputsDiff outputsDiff+ renderPlatformDiff platformDiff+ renderBuilderDiff builderDiff+ renderArgsDiff argumentsDiff+ renderSrcDiff sourcesDiff+ renderInputsDiff inputsDiff+ renderEnvDiff envDiff++ where+ renderOutputStructure os =+ renderWith os \(sign, (OutputStructure path outputs)) -> do+ echo (sign (Text.pack path <> renderOutputs outputs))++ renderOutputsDiff OutputsDiff{..} = do+ ifExist extraOutputs \eo -> do+ echo (explain "The set of outputs do not match:")+ renderWith eo \(sign, extraOutputs') -> do+ forM_ (Data.Map.toList extraOutputs') \(key, _value) -> do+ echo (" " <> sign ("{" <> key <> "}"))+ mapM_ renderOutputHashDiff outputHashDiff++ renderOutputHashDiff OutputDiff{..} = do+ echo (explain ("{" <> outputName <> "}:"))+ echo (explain " Hash algorithm:")+ renderWith hashDifference \(sign, hashAlgo) -> do+ echo (" " <> sign hashAlgo)++ renderPlatformDiff mpd =+ ifExist mpd \pd -> do+ echo (explain "The platforms do not match")+ renderWith pd \(sign, platform) -> do+ echo (" " <> sign platform)++ renderBuilderDiff mbd =+ ifExist mbd \bd -> do+ echo (explain "The builders do not match")+ renderWith bd \(sign, builder) -> do+ echo (" " <> sign builder)++ renderArgsDiff mad =+ ifExist mad \(ArgumentsDiff ad) -> do+ RenderContext { tty } <- ask+ echo (explain "The arguments do not match")+ let renderDiff (Patience.Old arg) =+ echo (" " <> minus tty arg)+ renderDiff (Patience.New arg) =+ echo (" " <> plus tty arg)+ renderDiff (Patience.Both arg _) =+ echo (" " <> explain arg)+ mapM_ renderDiff ad++ renderSrcDiff SourcesDiff{..} = do+ ifExist extraSrcNames \esn -> do+ echo (explain "The set of input source names do not match:")+ renderWith esn \(sign, names) -> do+ forM_ names \name -> do+ echo (" " <> sign name)++ mapM_ renderSrcFileDiff srcFilesDiff++ renderSrcFileDiff OneSourceFileDiff{..} = do+ echo (explain ("The input source named `" <> srcName <> "` differs"))+ ifExist srcContentDiff \scd -> do+ text <- renderText scd+ echo (" " <> text)+ renderSrcFileDiff SomeSourceFileDiff{..} = do+ echo (explain ("The input sources named `" <> srcName <> "` differ"))+ renderWith srcFileDiff \(sign, paths) -> do+ forM_ paths \path -> do+ echo (" " <> sign (Text.pack path))++ renderInputsDiff InputsDiff{..} = do+ renderInputExtraNames inputExtraNames+ mapM_ renderInputDerivationsDiff inputDerivationDiffs++ renderInputExtraNames mien =+ ifExist mien \ien -> do+ echo (explain "The set of input derivation names do not match:")+ renderWith ien \(sign, names) -> do+ forM_ names \name -> do+ echo (" " <> sign name)++ renderInputDerivationsDiff OneDerivationDiff{..} = do+ echo (explain ("The input derivation named `" <> drvName <> "` differs"))+ indented 2 (renderDiffHumanReadable drvDiff)+ renderInputDerivationsDiff SomeDerivationsDiff{..} = do+ echo (explain ("The set of input derivations named `" <> drvName <> "` do not match"))+ renderWith extraPartsDiff \(sign, extraPaths) -> do+ forM_ (Data.Map.toList extraPaths) \(extraPath, outputs) -> do+ echo (" " <> sign (Text.pack extraPath <> renderOutputs outputs))++ renderEnvDiff Nothing =+ echo (explain "Skipping environment comparison")+ renderEnvDiff (Just EnvironmentsAreEqual) = pure ()+ renderEnvDiff (Just EnvironmentDiff{..}) = do+ echo (explain "The environments do not match:")+ renderWith extraEnvDiff \(sign, extraEnv) -> do+ forM_ (Data.Map.toList extraEnv) \(key, value) -> do+ echo (" " <> sign (key <> "=" <> value))+ forM_ envContentDiff \EnvVarDiff{..} -> do+ text <- renderText envValueDiff+ echo (" " <> envKey <> "=" <> text)++ renderText :: TextDiff -> Render Text+ renderText (TextDiff chunks) = do+ RenderContext{ indent, orientation, tty } <- ask++ let n = fromIntegral indent++ let prefix = Text.replicate n " "++ let format text =+ if 80 <= n + Text.length text+ then "''\n" <> indentedText <> prefix <> "''"+ else text+ where+ indentedText =+ (Text.unlines . fmap indentLine . Text.lines) text+ where+ indentLine line = prefix <> " " <> line++ let renderChunk (Patience.Old l ) =+ redBackground orientation tty l+ renderChunk (Patience.New r) =+ greenBackground orientation tty r+ renderChunk (Patience.Both l _) =+ grey orientation tty l++ return (format (Text.concat (fmap renderChunk chunks)))++ ifExist m l = maybe (pure ()) l m
+ src/Nix/Diff/Transformations.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE FlexibleContexts #-}+module Nix.Diff.Transformations where++import qualified Patience+import Data.Generics.Uniplate.Data ( transformBi )++import Nix.Diff.Types++{-| In large diffs there may be a lot of derivations+ that doesn't change at all, but changed some of+ its nested inputs, that was already compared.+ This case will produce "stairs" of useless reports:+ ```+ • The input derivation named `a` differs+ - /nix/store/j1jmbxd74kzianaywml2nw1ja31a00r5-a.drv:{out}+ + /nix/store/ww51c2dha7m5l5qjzh2rblicsamkrh62-a.drv:{out}+ • The input derivation named `b` differs+ - /nix/store/j1jmbxd74kzianaywml2nw1ja31a00r5-b.drv:{out}+ + /nix/store/ww51c2dha7m5l5qjzh2rblicsamkrh62-b.drv:{out}+ • The input derivation named `c` differs+ • These two derivations have already been compared+ ```+ This transformation will fold all these subtrees of diff+ into one OnlyAlreadComparedBelow.+-}+foldAlreadyComparedSubTrees :: DerivationDiff -> DerivationDiff+foldAlreadyComparedSubTrees dd = case dd of+ DerivationsAreTheSame -> dd+ AlreadyCompared -> dd+ OnlyAlreadyComparedBelow{} -> dd+ NamesDontMatch{} -> dd+ OutputsDontMatch{} -> dd+ DerivationDiff{..} -> if+ | OutputsDiff Nothing [] <- outputsDiff+ , Nothing <- platformDiff+ , Nothing <- builderDiff+ , Nothing <- argumentsDiff+ , SourcesDiff Nothing [] <- sourcesDiff+ , InputsDiff Nothing inputs <- inputsDiff'+ , all alreadyComparedBelow inputs+ , envSkippedOrUnchanged envDiff+ -> OnlyAlreadyComparedBelow outputStructure++ | otherwise -> DerivationDiff+ { outputStructure+ , outputsDiff+ , platformDiff+ , builderDiff+ , argumentsDiff+ , sourcesDiff+ , inputsDiff = inputsDiff'+ , envDiff+ }+ where+ inputsDiff' = transformNestedDerivationDiffs+ foldAlreadyComparedSubTrees+ inputsDiff++{-| This transformation is most useful for+ --json output, because it will sqash a lot of+ `{"content":" ","type":"Both"},{"content":"When","type":"Both"},{"content":" ","type":"Both"},{"content":"in","type":"Both"},{"content":" ","type":"Both"}`+ into one+ `{"content":" When in ","type":"Both"}`+ block.++ To understand this problem clearer, see `golden-tests/expected-outputs/json`+ and `golden-tests/expected-outputs/json-squashed`.++ _Warning_: this transformation can break some parts of printing in+ human readable mode.+-}+squashSourcesAndEnvsDiff :: DerivationDiff -> DerivationDiff+squashSourcesAndEnvsDiff = transformBi+ \(TextDiff x) -> TextDiff (squashDiff x)+ where+ squashDiff (Patience.Old a : Patience.Old b : xs) =+ squashDiff (Patience.Old (a <> b) : xs)+ squashDiff (Patience.New a : Patience.New b : xs) =+ squashDiff (Patience.New (a <> b) : xs)+ squashDiff (Patience.Both a _ : Patience.Both b _ : xs) =+ let ab = a <> b in squashDiff (Patience.Both ab ab : xs)+ squashDiff (x : xs) = x : squashDiff xs+ squashDiff [] = []++-- ** Helpers++transformNestedDerivationDiffs+ :: (DerivationDiff -> DerivationDiff)+ -> InputsDiff+ -> InputsDiff+transformNestedDerivationDiffs f InputsDiff{..} = InputsDiff+ { inputExtraNames+ , inputDerivationDiffs = map changeDerivation inputDerivationDiffs+ }+ where+ changeDerivation idd = case idd of+ OneDerivationDiff name dd ->+ OneDerivationDiff name (f dd)+ SomeDerivationsDiff {} -> idd++envSkippedOrUnchanged :: Maybe EnvironmentDiff -> Bool+envSkippedOrUnchanged = \case+ Nothing -> True+ Just EnvironmentsAreEqual -> True+ _ -> False++alreadyComparedBelow :: InputDerivationsDiff -> Bool+alreadyComparedBelow = \case+ OneDerivationDiff _ AlreadyCompared -> True+ OneDerivationDiff _ OnlyAlreadyComparedBelow{} -> True+ _ -> False++transformIf :: Bool -> (DerivationDiff -> DerivationDiff) -> DerivationDiff -> DerivationDiff+transformIf False _ = id+transformIf True f = f
+ src/Nix/Diff/Types.hs view
@@ -0,0 +1,308 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Nix.Diff.Types where++import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NonEmpty+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+import Data.Text (Text)+import Nix.Derivation (DerivationOutput (..))++import qualified Patience+import GHC.Generics (Generic)+import Data.Foldable+import Data.Aeson+import Data.Aeson.Types+import Test.QuickCheck+import Test.QuickCheck.Instances ()+import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..))+import Data.Data (Data)++{- ** NOTE: Lawless instances+ All the Arbitrary instances here are written to+ check if `decode . encode == id` rule was broken,+ so they don't respect to internal laws of these types,+ such as "Maps from `extraOutputs` must not have+ intersecting keys" and so on.+ If you want to test these invariants, you have to rewrite+ instances manually.+-}++data Changed a = Changed { before :: a, now :: a }+ deriving stock (Eq, Show, Functor, Foldable, Traversable, Generic, Data)++instance (Arbitrary a) => Arbitrary (Changed a) where+ arbitrary = Changed <$> arbitrary <*> arbitrary+ shrink = genericShrink++instance ToJSON a => ToJSON (Changed a) where+ toJSON = changedToJSON toJSON++instance FromJSON a => FromJSON (Changed a) where+ parseJSON = changedFromJSON parseJSON++newtype TextDiff = TextDiff {unTextDiff :: [Patience.Item Text]}+ deriving stock (Eq, Show, Data)++instance Arbitrary TextDiff where+ arbitrary = TextDiff <$> listOf arbitraryItem++instance ToJSON TextDiff where+ toJSON = listValue itemToJSON . unTextDiff++instance FromJSON TextDiff where+ parseJSON v = TextDiff <$> (traverse itemFromJSON =<< parseJSON v)++-- Helpfull aliases++type OutputHash = Text++type Platform = Text++type Builder = Text++type Argument = Text++-- Derivation diff++data DerivationDiff+ = DerivationsAreTheSame+ | AlreadyCompared+ | OnlyAlreadyComparedBelow { outputStructure :: Changed OutputStructure}+ | NamesDontMatch { outputStructure :: Changed OutputStructure}+ | OutputsDontMatch { outputStructure :: Changed OutputStructure}+ | DerivationDiff+ { outputStructure :: Changed OutputStructure+ , outputsDiff :: OutputsDiff+ , platformDiff :: Maybe (Changed Platform)+ -- ^ Will be Nothing, if Platform does not change+ , builderDiff :: Maybe (Changed Builder)+ -- ^ Will be Nothing, if Builder does not change+ , argumentsDiff :: Maybe ArgumentsDiff+ -- ^ Will be Nothing, if arguments are equal+ , sourcesDiff :: SourcesDiff+ , inputsDiff :: InputsDiff+ , envDiff :: Maybe EnvironmentDiff+ -- ^ Will be Nothing, if environment comparison is skipped+ }+ deriving stock (Eq, Show, Generic, Data)+ deriving anyclass (ToJSON, FromJSON)+ deriving Arbitrary via GenericArbitrary DerivationDiff++-- Output structure++data OutputStructure = OutputStructure+ { derivationPath :: FilePath+ , derivationOutputs :: Set Text+ }+ deriving stock (Eq, Show, Generic, Data)+ deriving anyclass (ToJSON, FromJSON)+ deriving Arbitrary via GenericArbitrary OutputStructure++-- ** Outputs diff++data OutputsDiff = OutputsDiff+ { extraOutputs :: Maybe (Changed (Map Text (DerivationOutput FilePath Text)))+ -- ^ Map from derivation name to its outputs.+ -- Will be Nothing, if `Data.Map.difference` gives+ -- empty Maps for both new and old outputs+ , outputHashDiff :: [OutputDiff]+ -- ^ Difference of outputs with the same name.+ -- Will be empty, if all outputs are equal.+ }+ deriving stock (Eq, Show, Data)++deriving instance Data (DerivationOutput FilePath Text)++instance Arbitrary OutputsDiff where+ arbitrary = OutputsDiff <$> arbitraryExtraOutputs <*> arbitrary+ where+ arbitraryExtraOutputs =+ oneof [pure Nothing, Just <$> arbitraryChangedMap]++ arbitraryChangedMap =+ Changed <$> arbitraryMap <*> arbitraryMap++ arbitraryMap = Map.fromList <$>+ listOf ((,) <$> arbitrary <*> arbitraryDerivationOutput)++instance ToJSON OutputsDiff where+ toJSON OutputsDiff{..} = object+ [ "extraOutputs" .= fmap (changedToJSON extraOutputsToJSON) extraOutputs+ , "outputHashDiff" .= outputHashDiff+ ]+ where+ extraOutputsToJSON :: Map Text (DerivationOutput FilePath Text) -> Value+ extraOutputsToJSON = toJSON . fmap derivationOutputToJSON++ derivationOutputToJSON :: DerivationOutput FilePath Text -> Value+ derivationOutputToJSON DerivationOutput{..} = object+ [ "path" .= path+ , "hashAlgo" .= hashAlgo+ , "hash" .= hash+ ]++instance FromJSON OutputsDiff where+ parseJSON = withObject "OutputsDiff" \o -> do+ extraOutputsWithoutParsingDerivationOutputs <- o .: "extraOutputs"+ ohd <- o .: "outputHashDiff"+ eo <- (traverse . traverse . traverse)+ derivationOutputFromJSON+ extraOutputsWithoutParsingDerivationOutputs+ pure $ OutputsDiff eo ohd+ where++ derivationOutputFromJSON :: Value -> Parser (DerivationOutput FilePath Text)+ derivationOutputFromJSON = withObject "DerivationOutput" \o ->+ DerivationOutput <$> o .: "path" <*> o .: "hashAlgo" <*> o .: "hash"++data OutputDiff = OutputDiff+ { outputName :: Text+ , hashDifference :: Changed OutputHash+ }+ deriving stock (Eq, Show, Generic, Data)+ deriving anyclass (ToJSON, FromJSON)+ deriving Arbitrary via GenericArbitrary OutputDiff++-- ** Arguments diff++newtype ArgumentsDiff = ArgumentsDiff+ { unArgumetsDiff :: NonEmpty (Patience.Item Argument)+ }+ deriving stock (Eq, Show, Data)++instance Arbitrary ArgumentsDiff where+ arbitrary = ArgumentsDiff . NonEmpty.fromList <$> listOf1 arbitraryItem++instance ToJSON ArgumentsDiff where+ toJSON = listValue itemToJSON . toList . unArgumetsDiff++instance FromJSON ArgumentsDiff where+ parseJSON v = ArgumentsDiff <$> (traverse itemFromJSON =<< parseJSON v)++-- ** Sources diff++data SourcesDiff = SourcesDiff+ { extraSrcNames :: Maybe (Changed (Set Text))+ -- ^ Will be Nothing, if there is no extra source names+ , srcFilesDiff :: [SourceFileDiff]+ }+ deriving stock (Eq, Show, Generic, Data)+ deriving anyclass (ToJSON, FromJSON)+ deriving Arbitrary via GenericArbitrary SourcesDiff++data SourceFileDiff+ = OneSourceFileDiff+ { srcName :: Text+ , srcContentDiff :: Maybe TextDiff+ -- ^ Will be Nothing, if any of source files not exists+ }+ | SomeSourceFileDiff+ { srcName :: Text+ , srcFileDiff :: Changed [FilePath]+ }+ deriving stock (Eq, Show, Generic, Data)+ deriving anyclass (ToJSON, FromJSON)+ deriving Arbitrary via GenericArbitrary SourceFileDiff++-- ** Inputs diff++data InputsDiff = InputsDiff+ { inputExtraNames :: Maybe (Changed (Set Text))+ -- ^ Will be Nothing, if there is no extra input names+ , inputDerivationDiffs :: [InputDerivationsDiff]+ }+ deriving stock (Eq, Show, Generic, Data)+ deriving anyclass (ToJSON, FromJSON)+ deriving Arbitrary via GenericArbitrary InputsDiff++data InputDerivationsDiff+ = OneDerivationDiff+ { drvName :: Text+ , drvDiff :: DerivationDiff+ }+ | SomeDerivationsDiff+ { drvName :: Text+ , extraPartsDiff :: Changed (Map FilePath (Set Text))+ }+ deriving stock (Eq, Show, Generic, Data)+ deriving anyclass (ToJSON, FromJSON)+ deriving Arbitrary via GenericArbitrary InputDerivationsDiff++-- ** Environment diff++data EnvironmentDiff+ = EnvironmentsAreEqual+ | EnvironmentDiff+ { extraEnvDiff :: Changed (Map Text Text)+ , envContentDiff :: [EnvVarDiff]+ }+ deriving stock (Eq, Show, Generic, Data)+ deriving anyclass (ToJSON, FromJSON)+ deriving Arbitrary via GenericArbitrary EnvironmentDiff++data EnvVarDiff = EnvVarDiff+ { envKey :: Text+ , envValueDiff :: TextDiff+ }+ deriving stock (Eq, Show, Generic, Data)+ deriving anyclass (ToJSON, FromJSON)+ deriving Arbitrary via GenericArbitrary EnvVarDiff++-- ** Helpers++changedToJSON :: (a -> Value) -> Changed a -> Value+changedToJSON converter Changed{..} = object+ [ "before" .= converter before+ , "now" .= converter now+ ]++changedFromJSON :: (Value -> Parser a) -> Value -> Parser (Changed a)+changedFromJSON innerParser = withObject "Changed" \o -> do+ b <- o .: "before"+ n <- o .: "now"+ Changed <$> innerParser b <*> innerParser n++itemToJSON :: ToJSON v => Patience.Item v -> Value+itemToJSON (Patience.Old a) = object+ [ "type" .= ("Old" :: Text), "content" .= a]+itemToJSON (Patience.New a) = object+ [ "type" .= ("New" :: Text), "content" .= a]+itemToJSON (Patience.Both a _) = object+ [ "type" .= ("Both" :: Text), "content" .= a]++itemFromJSON :: FromJSON v => Value -> Parser (Patience.Item v)+itemFromJSON = withObject "Item" \o -> do+ t <- o .: "type"+ c <- o .: "content"+ case t :: Text of+ "Old" -> pure $ Patience.Old c+ "New" -> pure $ Patience.New c+ "Both" -> pure $ Patience.Both c c+ _ -> fail "Item: unexpected type"++arbitraryItem :: Arbitrary a => Gen (Patience.Item a)+arbitraryItem = do+ t <- arbitrary+ ctr <- elements [old, new, both]+ pure (ctr t)+ where+ old = Patience.Old+ new = Patience.New+ both x = Patience.Both x x++arbitraryDerivationOutput :: (Arbitrary fp, Arbitrary txt) => Gen (DerivationOutput fp txt)+arbitraryDerivationOutput = DerivationOutput <$> arbitrary <*> arbitrary <*> arbitrary
+ test/Golden/Tests.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE OverloadedStrings #-}+module Golden.Tests where++import qualified Data.Aeson+import qualified Data.ByteString.Lazy.Char8 as BS+import Data.Text.Encoding+import Test.Tasty ( testGroup, TestTree )+import Test.Tasty.Silver (goldenVsAction)++import Nix.Diff+import Nix.Diff.Transformations+import Nix.Diff.Render.HumanReadable++import Golden.Utils ( TestableDerivations, makeDiffTree )++goldenTests :: TestableDerivations -> TestableDerivations -> TestTree+goldenTests simpleTd complexTd = testGroup "Golden tests"+ [ goldenVsAction "Human readable, environment"+ humanReadableExpected+ simple_env_words+ humanReadable_words++ , goldenVsAction "JSON, environment"+ jsonExpected (mkDTSimple (diffContextEnv Word)) toJson++ , goldenVsAction "Human readable, complex, skip already compared"+ skipAlreadyComparedExpected+ complex_words+ (humanReadable_words . foldAlreadyComparedSubTrees)+ + , goldenVsAction "JSON, squash text and envs"+ jsonSquashedExpected+ simple_words+ (toJson . squashSourcesAndEnvsDiff)+ ]+ where+ toJson drv = (<> "\n") . decodeUtf8 . BS.toStrict $ (Data.Aeson.encode drv)++ humanReadable_words = toHumanReadable (renderContext Word)+ toHumanReadable ctx drv = runRender' (renderDiffHumanReadable drv) ctx++ simple_env_words = mkDTSimple (diffContextEnv Word)+ simple_words = mkDTSimple (diffContext Word)+ complex_words = mkDTComplex (diffContext Word)++ mkDTSimple = makeDiffTree simpleTd+ mkDTComplex = makeDiffTree complexTd++ indent' = 0+ diffContextEnv orient = DiffContext orient True+ diffContext orient = DiffContext orient False+ renderContext orient = RenderContext orient NotTTY indent'++humanReadableExpected :: FilePath+humanReadableExpected = "./golden-tests/expected-outputs/human-readable"++jsonExpected :: FilePath+jsonExpected = "./golden-tests/expected-outputs/json"++skipAlreadyComparedExpected :: FilePath+skipAlreadyComparedExpected = "./golden-tests/expected-outputs/skip-already-compared"++jsonSquashedExpected :: FilePath+jsonSquashedExpected = "./golden-tests/expected-outputs/json-squashed"
+ test/Golden/Utils.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}++module Golden.Utils where++import qualified Data.ByteString.Lazy.Char8 as BS+import qualified Data.Set+import qualified Control.Monad.Reader+import qualified Control.Monad.State+import Control.Monad (unless)+import Control.Exception ( throwIO, ErrorCall(ErrorCall) )+import System.Process.Typed++import Nix.Diff ( diff, Diff(unDiff), DiffContext, Status(Status) )+import Nix.Diff.Types ( DerivationDiff )++data TestableDerivations = TestableDerivations+ { oldDerivation :: FilePath+ , newDerivation :: FilePath+ }+ deriving Show++initSimpleDerivations :: IO TestableDerivations+initSimpleDerivations = do+ (oExit, o) <- readProcessStdout (nixInstantiate "./golden-tests/derivations/simple/old/drv.nix")+ (nExit, n) <- readProcessStdout (nixInstantiate "./golden-tests/derivations/simple/new/drv.nix")+ unless (oExit == ExitSuccess || nExit == ExitSuccess)+ (throwIO (ErrorCall "Can't instantiate simple derivations"))+ pure (TestableDerivations (toFilePath o) (toFilePath n))+ where+ toFilePath = BS.unpack . BS.init -- drop new-line char++initComplexDerivations :: IO TestableDerivations+initComplexDerivations = do+ (oExit, o) <- readProcessStdout (nixPathInfo "./golden-tests/derivations/complex/old/")+ (nExit, n) <- readProcessStdout (nixPathInfo "./golden-tests/derivations/complex/new/")+ unless (oExit == ExitSuccess || nExit == ExitSuccess)+ (throwIO (ErrorCall "Can't instantiate complex derivations"))+ pure (TestableDerivations (toFilePath o) (toFilePath n))+ where+ toFilePath = BS.unpack . BS.init -- drop new-line char++nixInstantiate :: FilePath -> ProcessConfig () () ()+nixInstantiate fp = shell ("nix-instantiate " <> fp)++nixPathInfo :: FilePath -> ProcessConfig () () ()+nixPathInfo fp = shell ("nix path-info --experimental-features 'nix-command flakes' --derivation " <> fp)++makeDiffTree :: TestableDerivations -> DiffContext -> IO DerivationDiff+makeDiffTree TestableDerivations{..} diffContext = do+ let status = Status Data.Set.empty+ let action = diff True oldDerivation (Data.Set.singleton "out") newDerivation (Data.Set.singleton "out")+ Control.Monad.State.evalStateT (Control.Monad.Reader.runReaderT (unDiff action) diffContext) status
+ test/Main.hs view
@@ -0,0 +1,14 @@+module Main where++import Test.Tasty++import Golden.Utils (initSimpleDerivations, initComplexDerivations)+import Golden.Tests (goldenTests)+import Properties (properties)++main :: IO ()+main = do+ simpleTd <- initSimpleDerivations+ complexTd <- initComplexDerivations+ defaultMain $+ testGroup "Tests" [goldenTests simpleTd complexTd, properties]
+ test/Properties.hs view
@@ -0,0 +1,24 @@+module Properties where++import Test.Tasty+import Test.Tasty.QuickCheck+import Data.Aeson++import Nix.Diff.Types+import Nix.Diff.Transformations++properties :: TestTree+properties = testGroup "Properties"+ [ testProperty "decode . encode == id" prop_DecodeEncodeID+ , testProperty "squash . squash == squash" prop_SqashTextDiffs+ ]+ where+ prop_DecodeEncodeID :: DerivationDiff -> Bool+ prop_DecodeEncodeID dd = case decode (encode dd) of+ Nothing -> False+ Just dd' -> dd == dd'++ prop_SqashTextDiffs :: DerivationDiff -> Bool+ prop_SqashTextDiffs dd = (op . op $ dd) == (op dd)+ where+ op = squashSourcesAndEnvsDiff