diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,12 @@ ## WIP +## [0.2.3] - 2020-11-06 + +- Implement filtering updates based on binding name +- Better error message output on parse failure +- Drop support for GHC 8.6 + ## [0.2.2] - 2020-11-03 - Require hnix version 0.11 with several important bugfixes diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,5 +1,8 @@ +{-# OPTIONS_GHC -Wno-orphans #-} -module Main where +module Main + ( main + ) where import Data.Foldable import qualified Data.Text.IO as T @@ -14,6 +17,7 @@ , readS_to_P , sepBy ) +import Text.Regex.TDFA import Update.Nix.FetchGit import Update.Nix.FetchGit.Types @@ -43,7 +47,8 @@ Normal -> sayErr Quiet -> sayErr updateLocations = [ (l, c) | Position l c <- location ] - in Env { .. } + attrPatterns = attribute + in Env { .. } ---------------------------------------------------------------- -- Options @@ -52,7 +57,9 @@ data Options w = Options { verbose :: w ::: Bool "False" , quiet :: w ::: Bool "False" - , location :: w ::: [Position] "Source location to limit updates to" + , location :: w ::: [Position] "Source location to limit updates to, Combined using inclusive or" + , attribute + :: w ::: [Regex] "Pattern (POSIX regex) to limit updates to expressions under matching names in attrsets and let bindings. Combined using inclusing or, if this isn't specified then no expressions will be filtered by attribute name" } deriving stock Generic @@ -70,7 +77,9 @@ versionOption <*> ( (,) <$> (unwrap <$> parseRecordWithModifiers defaultModifiers - { shortNameModifier = firstLetter + { shortNameModifier = \case + "attribute" -> Just 'A' + n -> firstLetter n } ) <*> many @@ -88,7 +97,6 @@ (long "version" <> help ("print " <> versionString)) instance ParseRecord (Options Wrapped) -deriving instance Show (Options Unwrapped) data Position = Position Int Int deriving Show @@ -101,3 +109,15 @@ instance ParseField Position where metavar _ = "LINE:COL" + +instance Read Regex where + readsPrec _ s = case makeRegexM s of + Nothing -> [] + Just r -> [(r, "")] + +instance ParseField Regex where + metavar _ = "REGEX" + readField = eitherReader makeRegexM + +instance (e ~ String) => MonadFail (Either e) where + fail = Left diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -1,10 +1,11 @@ name: update-nix-fetchgit -version: "0.2.2" +version: "0.2.3" synopsis: A program to update fetchgit values in Nix expressions description: | This command-line utility is meant to be used by people maintaining Nix expressions that fetch files from Git repositories. It automates the process of keeping such expressions up-to-date with the latest upstream sources. +category: Nix author: Joe Hermaszewski maintainer: Joe Hermaszewski copyright: 2020 Joe Hermaszewski @@ -28,9 +29,10 @@ source-dirs: app ghc-options: -threaded -rtsopts -with-rtsopts=-N dependencies: - - base + - base >= 4.13 - optparse-applicative - optparse-generic >= 1.4.2 + - regex-tdfa - say - text >= 1.2 - update-nix-fetchgit @@ -48,6 +50,7 @@ - monad-validate - mtl - process >= 1.2 + - regex-tdfa - syb - template-haskell - text >= 1.2 diff --git a/src/Update/Nix/FetchGit.hs b/src/Update/Nix/FetchGit.hs --- a/src/Update/Nix/FetchGit.hs +++ b/src/Update/Nix/FetchGit.hs @@ -7,8 +7,11 @@ ) where import Control.Monad ( when ) +import Control.Monad.Reader ( MonadReader(ask) ) +import Control.Monad.Validate ( MonadValidate(tolerate) ) import Data.Fix import Data.Foldable +import Data.Functor import Data.Maybe import Data.Text ( Text , pack @@ -21,13 +24,11 @@ import Nix.Expr import Nix.Match.Typed import System.Exit +import Text.Regex.TDFA import Update.Nix.FetchGit.Types import Update.Nix.FetchGit.Utils import Update.Nix.Updater import Update.Span -import Control.Monad.Validate ( MonadValidate(tolerate) ) -import Data.Functor -import Control.Monad.Reader ( MonadReader(ask) ) -------------------------------------------------------------------------------- -- Tying it all together @@ -57,7 +58,7 @@ tree <- do expr <- fromEither $ ourParseNixText t findUpdates (getComment nixLines) expr - us <- evalUpdates tree + us <- evalUpdates =<< filterUpdates tree case us of [] -> logVerbose "Made no updates" [_] -> logVerbose "Made 1 update" @@ -71,20 +72,54 @@ findUpdates :: (NExprLoc -> Maybe Comment) -> NExprLoc -> M FetchTree findUpdates getComment e = do Env {..} <- ask + -- First of all, if this expression doesn't enclose the requested position, + -- return an empty tree + -- Then check against all the updaters, if they match we have a leaf if not (null updateLocations || any (containsPosition e) updateLocations) then pure $ Node Nothing [] else - let updaters = ($ e) <$> fetchers getComment + let + updaters = ($ e) <$> fetchers getComment + bindingTrees = \case + NamedVar p e' _ | Just t <- pathText p -> + (: []) . (Just t, ) <$> findUpdates getComment e' + b -> + traverse (fmap (Nothing, ) . findUpdates getComment) . toList $ b in case asum updaters of Just u -> UpdaterNode <$> u Nothing -> case e of - [matchNixLoc|{ _version = ^version; }|] -> - Node version - <$> traverse (findUpdates getComment) (toList (unFix e)) - _ -> Node Nothing - <$> traverse (findUpdates getComment) (toList (unFix e)) + [matchNixLoc|{ _version = ^version; }|] | NSet_ _ _ bs <- unFix e -> + Node version . concat <$> traverse bindingTrees bs + [matchNixLoc|let _version = ^version; in ^x|] + | NLet_ _ bs _ <- unFix e -> do + bs' <- concat <$> traverse bindingTrees bs + x' <- findUpdates getComment x + pure $ Node version ((Nothing, x') : bs') + _ -> Node Nothing <$> traverse + (fmap (Nothing, ) . findUpdates getComment) + (toList (unFix e)) +filterUpdates :: FetchTree -> M FetchTree +filterUpdates t = do + Env {..} <- ask + let matches s = any (`match` s) attrPatterns + -- If we're in a branch, include any bindings which match unconditionally, + -- otherwise recurse + -- If we reach a leaf, return empty because it hasn't been included by a + -- binding yet + let go = \case + Node v cs -> Node + v + [ (n, c') + | (n, c) <- cs + , let c' = if maybe False matches n then c else go c + ] + UpdaterNode _ -> Node Nothing [] + -- If there are no patterns, don't do any filtering + pure $ if null attrPatterns then t else go t + + evalUpdates :: FetchTree -> M [SpanUpdate] evalUpdates = fmap snd . go where @@ -92,7 +127,7 @@ go = \case UpdaterNode (Updater u) -> u Node versionExpr cs -> do - (ds, ss) <- unzip . catMaybes <$> traverse (tolerate . go) cs + (ds, ss) <- unzip . catMaybes <$> traverse (tolerate . go . snd) cs -- Update version string with the maximum of versions in the children let latestDate = maximumMay (catMaybes ds) pure @@ -101,7 +136,7 @@ | Just d <- pure latestDate , Just v <- pure versionExpr ] - <> concat ss + <> concat ss ) ---------------------------------------------------------------- diff --git a/src/Update/Nix/FetchGit/Types.hs b/src/Update/Nix/FetchGit/Types.hs --- a/src/Update/Nix/FetchGit/Types.hs +++ b/src/Update/Nix/FetchGit/Types.hs @@ -11,6 +11,7 @@ import Data.Text ( Text ) import Data.Time ( Day ) import Nix.Expr ( NExprLoc ) +import Text.Regex.TDFA ( Regex ) import Update.Nix.FetchGit.Warning import Update.Span @@ -28,8 +29,9 @@ Right (MNothing, a) -> (mempty, Just a) data Env = Env - { sayLog :: Verbosity -> Text -> IO () + { sayLog :: Verbosity -> Text -> IO () , updateLocations :: [(Int, Int)] + , attrPatterns :: [Regex] } data Verbosity @@ -45,7 +47,7 @@ -- parsing, but which only contains the information we care about. data FetchTree = Node { nodeVersionExpr :: Maybe NExprLoc - , nodeChildren :: [FetchTree] + , nodeChildren :: [(Maybe Text, FetchTree)] } | UpdaterNode Updater diff --git a/src/Update/Nix/FetchGit/Utils.hs b/src/Update/Nix/FetchGit/Utils.hs --- a/src/Update/Nix/FetchGit/Utils.hs +++ b/src/Update/Nix/FetchGit/Utils.hs @@ -7,6 +7,7 @@ , prettyRepoLocation , quoteString , extractFuncName + , pathText , exprText , exprBool , exprSpan @@ -101,6 +102,30 @@ extractFuncName (AnnE _ (NSelect _ (NE.last -> StaticKey name) _)) = Just name extractFuncName _ = Nothing +pathText :: NAttrPath r -> Maybe Text +pathText = fmap (T.concat . toList) . traverse e + where + e :: NKeyName r -> Maybe Text + e = \case + StaticKey s -> Just s + DynamicKey (Plain s) -> t s + DynamicKey EscapedNewline -> Just "\n" + DynamicKey (Antiquoted _) -> Nothing + t :: NString r -> Maybe Text + t = + fmap T.concat + . traverse a + . (\case + DoubleQuoted as -> as + Indented _ as -> as + ) + a :: Antiquoted Text r -> Maybe Text + a = \case + Plain s -> pure s + EscapedNewline -> pure "\n" + Antiquoted _ -> Nothing + + -- Takes an ISO 8601 date and returns just the day portion. parseISO8601DateToDay :: Text -> Either Warning Day parseISO8601DateToDay t = @@ -110,7 +135,7 @@ (parseTimeM False defaultTimeLocale "%Y-%m-%d" justDate) formatWarning :: Warning -> Text -formatWarning (CouldNotParseInput doc) = tShow doc +formatWarning (CouldNotParseInput doc) = doc formatWarning (MissingAttr attrName) = "Error: The \"" <> attrName <> "\" attribute is missing." formatWarning (DuplicateAttrs attrName) = diff --git a/src/Update/Nix/FetchGit/Warning.hs b/src/Update/Nix/FetchGit/Warning.hs --- a/src/Update/Nix/FetchGit/Warning.hs +++ b/src/Update/Nix/FetchGit/Warning.hs @@ -4,7 +4,6 @@ import Data.Text import Nix.Expr -import Data.Void data Warning = CouldNotParseInput Text | MissingAttr Text diff --git a/tests/Samples.hs b/tests/Samples.hs --- a/tests/Samples.hs +++ b/tests/Samples.hs @@ -5,7 +5,6 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.Golden (goldenVsFile) import System.FilePath (()) -import Data.Bool (bool) import Data.Maybe (mapMaybe) import qualified Data.List @@ -30,6 +29,7 @@ -- * perform update -- * adjust @url@ to point to the expected one -- * copy file back to @tests/test_rec_sets.out.nix@ so it be compared to @expected.nix@ +runTest :: String -> IO () runTest f = System.IO.Temp.withSystemTempDirectory "test-update-nix-fetchgit" $ \dir -> System.IO.Temp.withSystemTempDirectory "test-update-nix-fetchgit-store" $ \storeDir -> do @@ -60,15 +60,15 @@ (System.Process.shell ("nix-store --init")) mempty - let env = Env (const (Data.Text.IO.hPutStrLn System.IO.stderr)) [] + let env = Env (const (Data.Text.IO.hPutStrLn System.IO.stderr)) [] [] Update.Nix.FetchGit.processFile env (dir inBase) replaceFile (dir inBase) (Data.Text.pack dir) "/tmp/nix-update-fetchgit-test" System.Directory.copyFile (dir inBase) f where - replaceFile f what with = - Data.Text.IO.readFile f >>= Data.Text.IO.writeFile f . Data.Text.replace what with + replaceFile f' what with = + Data.Text.IO.readFile f' >>= Data.Text.IO.writeFile f' . Data.Text.replace what with test_derivation :: IO TestTree test_derivation = do diff --git a/update-nix-fetchgit.cabal b/update-nix-fetchgit.cabal --- a/update-nix-fetchgit.cabal +++ b/update-nix-fetchgit.cabal @@ -5,11 +5,12 @@ -- see: https://github.com/sol/hpack name: update-nix-fetchgit -version: 0.2.2 +version: 0.2.3 synopsis: A program to update fetchgit values in Nix expressions description: This command-line utility is meant to be used by people maintaining Nix expressions that fetch files from Git repositories. It automates the process of keeping such expressions up-to-date with the latest upstream sources. +category: Nix homepage: https://github.com/expipiplus1/update-nix-fetchgit#readme bug-reports: https://github.com/expipiplus1/update-nix-fetchgit/issues author: Joe Hermaszewski @@ -86,6 +87,7 @@ , monad-validate , mtl , process >=1.2 + , regex-tdfa , syb , template-haskell , text >=1.2 @@ -103,9 +105,10 @@ default-extensions: DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveGeneric DerivingStrategies FlexibleContexts FlexibleInstances GADTs LambdaCase MultiParamTypeClasses OverloadedStrings PolyKinds RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskellQuotes TupleSections TypeApplications TypeFamilies TypeOperators ViewPatterns ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: - base + base >=4.13 , optparse-applicative , optparse-generic >=1.4.2 + , regex-tdfa , say , text >=1.2 , update-nix-fetchgit