diff --git a/src/Niv/Cli.hs b/src/Niv/Cli.hs index c16ecf0..6fc37f7 100644 --- a/src/Niv/Cli.hs +++ b/src/Niv/Cli.hs @@ -55,8 +55,7 @@ li = liftIO cli :: IO () cli = do ((fsj, colors), nio) <- - execParserPure' Opts.defaultPrefs opts <$> getArgs - >>= Opts.handleParseResult + getArgs >>= Opts.handleParseResult . execParserPure' Opts.defaultPrefs opts setColors colors runReaderT (runNIO nio) fsj where @@ -471,8 +470,7 @@ cmdUpdate = \case Just "git" -> gitCmd Just "local" -> localCmd _ -> githubCmd - finalSpec <- fmap attrsToSpec <$> li (doUpdate initialSpec cmd) - pure finalSpec + fmap attrsToSpec <$> li (doUpdate initialSpec cmd) let (failed, sources') = partitionEithersHMS esources' unless (HMS.null failed) $ li $ @@ -578,7 +576,7 @@ cmdDrop packageName = \case tsay $ "Dropping package: " <> unPackageName packageName fsj <- getFindSourcesJson sources <- unSources <$> li (getSources fsj) - when (not $ HMS.member packageName sources) $ + unless (HMS.member packageName sources) $ li $ abortCannotDropNoSuchPackage packageName li $ diff --git a/src/Niv/Git/Cmd.hs b/src/Niv/Git/Cmd.hs index 7a86eea..78a1444 100644 --- a/src/Niv/Git/Cmd.hs +++ b/src/Niv/Git/Cmd.hs @@ -15,6 +15,7 @@ import qualified Data.ByteString.Char8 as B8 import qualified Data.HashMap.Strict as HMS import Data.Maybe import qualified Data.Text as T +import Data.Char (isDigit) import Data.Text.Extended as T import Niv.Cmd import Niv.Logger @@ -52,7 +53,7 @@ gitExtraLogs attrs = noteRef <> warnRefBranch <> warnRefTag mkWarn "Your source contains both a `ref` and a `tag`. The `ref` will be used by Nix to fetch the repo." member x = HMS.member x attrs - textIf cond txt = if cond then [txt] else [] + textIf cond txt = [txt | cond] parseGitShortcut :: T.Text -> Maybe (PackageName, Aeson.Object) parseGitShortcut txt'@(T.dropWhileEnd (== '/') -> txt) = @@ -179,7 +180,7 @@ latestRev repo branch = do sout <- runGit gitArgs case sout of ls@(_ : _ : _) -> abortTooMuchOutput gitArgs ls - (l1 : []) -> parseRev gitArgs l1 + [l1] -> parseRev gitArgs l1 [] -> abortNoOutput gitArgs where parseRev args l = maybe (abortNoRev args l) pure $ do @@ -241,7 +242,7 @@ runGit args = do isRev :: T.Text -> Bool isRev t = -- commit hashes are comprised of abcdef0123456789 - T.all (\c -> (c >= 'a' && c <= 'f') || (c >= '0' && c <= '9')) t + T.all (\c -> (c >= 'a' && c <= 'f') || isDigit c) t && -- commit _should_ be 40 chars long, but to be sure we pick 7 T.length t >= 7 diff --git a/src/Niv/Git/Test.hs b/src/Niv/Git/Test.hs index 8a0f9d0..36f105e 100644 --- a/src/Niv/Git/Test.hs +++ b/src/Niv/Git/Test.hs @@ -59,7 +59,7 @@ test_gitUpdateRev :: IO () test_gitUpdateRev = do interState <- evalUpdate initialState $ proc () -> gitUpdate (error "should be def") defaultBranchAndHEAD' -< () - let interState' = HMS.map (first (\_ -> Free)) interState + let interState' = HMS.map (first (const Free)) interState actualState <- evalUpdate interState' $ proc () -> gitUpdate latestRev' (error "should update") -< () unless ((snd <$> actualState) == expectedState) $ @@ -109,7 +109,7 @@ test_gitCalledOnce = do latestRev'' <- once2 latestRev' interState <- evalUpdate initialState $ proc () -> gitUpdate (error "should be def") defaultBranchAndHEAD'' -< () - let interState' = HMS.map (first (\_ -> Free)) interState + let interState' = HMS.map (first (const Free)) interState actualState <- evalUpdate interState' $ proc () -> gitUpdate latestRev'' (error "should update") -< () unless ((snd <$> actualState) == expectedState) $ diff --git a/src/Niv/GitHub.hs b/src/Niv/GitHub.hs index fdb2918..2291e8a 100644 --- a/src/Niv/GitHub.hs +++ b/src/Niv/GitHub.hs @@ -35,14 +35,14 @@ githubUpdate prefetch latestRev ghRepo = proc () -> do let isTarGuess = (\u -> "tar.gz" `T.isSuffixOf` u || ".tgz" `T.isSuffixOf` u) <$> url type' <- useOrSet "type" -< bool "file" "tarball" <$> isTarGuess :: Box T.Text let doUnpack = (== "tarball") <$> type' - _sha256 <- update "sha256" <<< run (\(up, u) -> prefetch up u) -< (,) <$> doUnpack <*> url + _sha256 <- update "sha256" <<< run (uncurry prefetch) -< (,) <$> doUnpack <*> url returnA -< () where completeSpec :: Update () (Box T.Text) completeSpec = proc () -> do owner <- load "owner" -< () repo <- load "repo" -< () - repoInfo <- run (\(a, b) -> ghRepo a b) -< (,) <$> owner <*> repo + repoInfo <- run (uncurry ghRepo) -< (,) <$> owner <*> repo branch <- useOrSet "branch" <<< arr (fmap $ fromMaybe "master") -< diff --git a/src/Niv/GitHub/API.hs b/src/Niv/GitHub/API.hs index c79f89e..18e6294 100644 --- a/src/Niv/GitHub/API.hs +++ b/src/Niv/GitHub/API.hs @@ -81,9 +81,8 @@ defaultRequest (map T.encodeUtf8 -> parts) = do let path = T.encodeUtf8 githubPath <> BS8.intercalate "/" parts mtoken <- lookupEnv' "GITHUB_TOKEN" pure - $ ( flip (maybe id) mtoken $ \token -> - HTTP.addRequestHeader "authorization" ("token " <> BS8.pack token) - ) + $ maybe id (\token -> + HTTP.addRequestHeader "authorization" ("token " <> BS8.pack token)) mtoken $ HTTP.setRequestPath path $ HTTP.addRequestHeader "user-agent" "niv" $ HTTP.addRequestHeader "accept" "application/vnd.github.v3+json" @@ -140,18 +139,21 @@ lookupEnv' vn = Nothing -> lookupEnv ("NIV_" <> vn) githubHost :: T.Text +{-# NOINLINE githubHost #-} githubHost = unsafePerformIO $ do lookupEnv' "GITHUB_HOST" >>= \case Just (T.pack -> x) -> pure x Nothing -> pure "github.com" githubApiPort :: Int +{-# NOINLINE githubApiPort #-} githubApiPort = unsafePerformIO $ do lookupEnv' "GITHUB_API_PORT" >>= \case Just (readMaybe -> Just x) -> pure x _ -> pure $ if githubSecure then 443 else 80 githubApiHost :: T.Text +{-# NOINLINE githubApiHost #-} githubApiHost = unsafePerformIO $ do lookupEnv' "GITHUB_API_HOST" >>= \case Just (T.pack -> x) -> pure x @@ -162,6 +164,7 @@ githubApiHost = unsafePerformIO $ do -- https://github.com/nmattia/niv/issues/280 githubSecure :: Bool +{-# NOINLINE githubSecure #-} githubSecure = unsafePerformIO $ do lookupEnv "NIV_GITHUB_INSECURE" >>= \case Just "" -> pure True @@ -169,6 +172,7 @@ githubSecure = unsafePerformIO $ do Nothing -> pure True githubPath :: T.Text +{-# NOINLINE githubPath #-} githubPath = unsafePerformIO $ do lookupEnv "NIV_GITHUB_PATH" >>= \case Just (T.pack -> x) -> pure $ fromMaybe x (T.stripSuffix "/" x) <> "/" diff --git a/src/Niv/GitHub/Cmd.hs b/src/Niv/GitHub/Cmd.hs index 00bbe0a..7dfde16 100644 --- a/src/Niv/GitHub/Cmd.hs +++ b/src/Niv/GitHub/Cmd.hs @@ -96,9 +96,7 @@ parseGitHubPackageSpec = -- Shortcuts for common attributes shortcutAttributes :: Opts.Parser (K.Key, Aeson.Value) shortcutAttributes = - foldr (<|>) empty $ - mkShortcutAttribute - <$> ["branch", "owner", "rev", "version"] + foldr ((<|>) . mkShortcutAttribute) empty ["branch", "owner", "rev", "version"] -- TODO: infer those shortcuts from 'Update' keys mkShortcutAttribute :: T.Text -> Opts.Parser (K.Key, Aeson.Value) mkShortcutAttribute = \case @@ -165,7 +163,7 @@ nixPrefetchURL unpack turl@(T.unpack -> url) = do (ExitSuccess, l : _) -> pure $ T.pack l _ -> abortNixPrefetchExpectedOutput (T.pack <$> args) (T.pack sout) (T.pack serr) where - args = (if unpack then ["--unpack"] else []) <> [url, "--name", sanitizeName basename] + args = (["--unpack" | unpack]) <> [url, "--name", sanitizeName basename] runNixPrefetch = readProcessWithExitCode "nix-prefetch-url" args "" sanitizeName = T.unpack . T.filter isOk basename = last $ T.splitOn "/" turl @@ -173,7 +171,7 @@ nixPrefetchURL unpack turl@(T.unpack -> url) = do -- Path names are alphanumeric and can include the symbols +-._?= and must -- not begin with a period. -- (note: we assume they don't begin with a period) - isOk = \c -> isAlphaNum c || T.any (c ==) "+-._?=" + isOk c = isAlphaNum c || T.any (c ==) "+-._?=" abortNixPrefetchExpectedOutput :: [T.Text] -> T.Text -> T.Text -> IO a abortNixPrefetchExpectedOutput args sout serr = diff --git a/src/Niv/GitHub/Test.hs b/src/Niv/GitHub/Test.hs index 438ef3c..fa65876 100644 --- a/src/Niv/GitHub/Test.hs +++ b/src/Niv/GitHub/Test.hs @@ -165,7 +165,7 @@ test_githubUpdatesOnce = do error $ "State mismatch: " <> show tmpState -- Set everything free - let tmpState' = HMS.map (first (\_ -> Free)) tmpState + let tmpState' = HMS.map (first (const Free)) tmpState actualState <- evalUpdate tmpState' $ proc () -> githubUpdate (prefetch ioref) latestRev ghRepo -< () unless ((snd <$> actualState) == expectedState) $ diff --git a/src/Niv/Logger.hs b/src/Niv/Logger.hs index 97f23be..883570c 100644 --- a/src/Niv/Logger.hs +++ b/src/Niv/Logger.hs @@ -55,7 +55,8 @@ setColors :: Colors -> IO () setColors = writeIORef colors useColors :: Bool -useColors = unsafePerformIO $ (\c -> c == Always) <$> readIORef colors +{-# NOINLINE useColors #-} +useColors = unsafePerformIO $ (== Always) <$> readIORef colors type S = String -> String @@ -83,6 +84,7 @@ jobStackSize :: (MonadIO io) => io Int jobStackSize = readIORef jobStack jobStack :: IORef Int +{-# NOINLINE jobStack #-} jobStack = unsafePerformIO $ newIORef 0 {-# NOINLINE jobStackSize #-} diff --git a/src/Niv/Sources.hs b/src/Niv/Sources.hs index ac7b453..afe8690 100644 --- a/src/Niv/Sources.hs +++ b/src/Niv/Sources.hs @@ -62,13 +62,12 @@ getSourcesEither fsj = do valueToSources :: Aeson.Value -> Maybe Sources valueToSources = \case Aeson.Object obj -> - fmap (Sources . mapKeys PackageName . KM.toHashMapText) $ - traverse + (Sources . mapKeys PackageName . KM.toHashMapText <$> traverse ( \case Aeson.Object obj' -> Just (PackageSpec obj') _ -> Nothing ) - obj + obj) _ -> Nothing mapKeys :: (Eq k2, Hashable k2) => (k1 -> k2) -> HMS.HashMap k1 v -> HMS.HashMap k2 v mapKeys f = HMS.fromList . map (first f) . HMS.toList @@ -86,7 +85,7 @@ getSources fsj = do pure setSources :: FindSourcesJson -> Sources -> IO () -setSources fsj sources = Aeson.encodeFilePretty (pathNixSourcesJson fsj) sources +setSources fsj = Aeson.encodeFilePretty (pathNixSourcesJson fsj) newtype PackageName = PackageName {unPackageName :: T.Text} deriving newtype (Eq, Hashable, FromJSONKey, ToJSONKey, Show) diff --git a/src/Niv/Update.hs b/src/Niv/Update.hs index b8d2ed4..2bcddbf 100644 --- a/src/Niv/Update.hs +++ b/src/Niv/Update.hs @@ -276,7 +276,7 @@ runUpdate' attrs = \case v' <- runBox v case renderTemplate ( \k -> - (decodeBox $ "When rendering template " <> v') . snd + decodeBox ("When rendering template " <> v') . snd <$> HMS.lookup k attrs ) v' of