Skip to content

Commit

Permalink
hlint refactor (#403)
Browse files Browse the repository at this point in the history
Was perfomed using `find -name '*.hs' -exec hlint -i "Missing NOINLINE
pragma" -i "Use uncurry" -i "Use const"  --refactor
--refactor-options="--inplace" {} \;`
  • Loading branch information
flandweber authored May 23, 2024
1 parent 84fed67 commit f7c5388
Show file tree
Hide file tree
Showing 10 changed files with 61 additions and 72 deletions.
53 changes: 24 additions & 29 deletions src/Niv/Cli.hs
Original file line number Diff line number Diff line change
Expand Up @@ -2,7 +2,6 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

Expand Down Expand Up @@ -56,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
Expand Down Expand Up @@ -115,7 +113,7 @@ parsePackageName =
<$> Opts.argument Opts.str (Opts.metavar "PACKAGE")

parsePackage :: Opts.Parser (PackageName, PackageSpec)
parsePackage = (,) <$> parsePackageName <*> (parsePackageSpec githubCmd)
parsePackage = (,) <$> parsePackageName <*> parsePackageSpec githubCmd

-------------------------------------------------------------------------------
-- INIT
Expand Down Expand Up @@ -158,22 +156,20 @@ parseNixpkgs = parseNixpkgsFast <|> parseNixpkgsLatest <|> parseNixpkgsCustom <|
<> Opts.help "Pull the latest unstable nixpkgs from NixOS/nixpkgs."
)
parseNixpkgsCustom =
(flip NixpkgsCustom)
<$> ( Opts.option
customNixpkgsReader
( Opts.long "nixpkgs"
<> Opts.showDefault
<> Opts.help "Use a custom nixpkgs repository from GitHub."
<> Opts.metavar "OWNER/REPO"
)
)
<*> ( Opts.strOption
( Opts.long "nixpkgs-branch"
<> Opts.short 'b'
<> Opts.help "The nixpkgs branch when using --nixpkgs ...."
<> Opts.showDefault
)
)
flip NixpkgsCustom
<$> Opts.option
customNixpkgsReader
( Opts.long "nixpkgs"
<> Opts.showDefault
<> Opts.help "Use a custom nixpkgs repository from GitHub."
<> Opts.metavar "OWNER/REPO"
)
<*> Opts.strOption
( Opts.long "nixpkgs-branch"
<> Opts.short 'b'
<> Opts.help "The nixpkgs branch when using --nixpkgs ...."
<> Opts.showDefault
)
parseNoNixpkgs =
Opts.flag'
NoNixpkgs
Expand Down Expand Up @@ -285,15 +281,15 @@ parseCmdAdd :: Opts.ParserInfo (NIO ())
parseCmdAdd =
Opts.info
((parseCommands <|> parseShortcuts) <**> Opts.helper)
$ (description githubCmd)
$ description githubCmd
where
-- XXX: this should parse many shortcuts (github, git). Right now we only
-- parse GitHub because the git interface is still experimental. note to
-- implementer: it'll be tricky to have the correct arguments show up
-- without repeating "PACKAGE PACKAGE PACKAGE" for every package type.
parseShortcuts = parseShortcut githubCmd
parseShortcut cmd = uncurry (cmdAdd cmd) <$> (parseShortcutArgs cmd)
parseCmd cmd = uncurry (cmdAdd cmd) <$> (parseCmdArgs cmd)
parseShortcut cmd = uncurry (cmdAdd cmd) <$> parseShortcutArgs cmd
parseCmd cmd = uncurry (cmdAdd cmd) <$> parseCmdArgs cmd
parseCmdAddGit =
Opts.info (parseCmd gitCmd <**> Opts.helper) (description gitCmd)
parseCmdAddLocal =
Expand Down Expand Up @@ -376,7 +372,7 @@ cmdAdd cmd packageName attrs = do
case eFinalSpec of
Left e -> li (abortUpdateFailed [(packageName, e)])
Right finalSpec -> do
say $ "Writing new sources file"
say "Writing new sources file"
li $
setSources fsj $
Sources $
Expand Down Expand Up @@ -404,7 +400,7 @@ cmdShow = \case
Nothing -> do
fsj <- getFindSourcesJson
sources <- unSources <$> li (getSources fsj)
forWithKeyM_ sources $ showPackage
forWithKeyM_ sources showPackage

showPackage :: (MonadIO io) => PackageName -> PackageSpec -> io ()
showPackage (PackageName pname) (PackageSpec spec) = do
Expand Down Expand Up @@ -483,8 +479,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 $
Expand All @@ -494,7 +489,7 @@ cmdUpdate = \case
-- | pretty much tryEvalUpdate but we might issue some warnings first
doUpdate :: Attrs -> Cmd -> IO (Either SomeException Attrs)
doUpdate attrs cmd = do
forM_ (extraLogs cmd attrs) $ tsay
forM_ (extraLogs cmd attrs) tsay
tryEvalUpdate attrs (updateCmd cmd)

partitionEithersHMS ::
Expand Down Expand Up @@ -590,7 +585,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 $
Expand Down
10 changes: 5 additions & 5 deletions src/Niv/Git/Cmd.hs
Original file line number Diff line number Diff line change
@@ -1,6 +1,5 @@
{-# LANGUAGE Arrows #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
Expand All @@ -13,6 +12,7 @@ import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Key as K
import qualified Data.Aeson.KeyMap as KM
import qualified Data.ByteString.Char8 as B8
import Data.Char (isDigit)
import qualified Data.HashMap.Strict as HMS
import Data.Maybe
import qualified Data.Text as T
Expand Down Expand Up @@ -53,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) =
Expand All @@ -76,7 +76,7 @@ parseGitShortcut txt'@(T.dropWhileEnd (== '/') -> txt) =

parseGitPackageSpec :: Opts.Parser PackageSpec
parseGitPackageSpec =
(PackageSpec . KM.fromList)
PackageSpec . KM.fromList
<$> many (parseRepo <|> parseBranch <|> parseRev <|> parseAttr <|> parseSAttr)
where
parseRepo =
Expand Down Expand Up @@ -180,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
Expand Down Expand Up @@ -242,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
Expand Down
5 changes: 1 addition & 4 deletions src/Niv/GitHub.hs
Original file line number Diff line number Diff line change
@@ -1,9 +1,6 @@
{-# LANGUAGE Arrows #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}

module Niv.GitHub where

Expand Down Expand Up @@ -31,7 +28,7 @@ githubUpdate ::
githubUpdate prefetch latestRev ghRepo = proc () -> do
urlTemplate <-
template
<<< (useOrSet "url_template" <<< completeSpec) <+> (load "url_template")
<<< (useOrSet "url_template" <<< completeSpec) <+> load "url_template"
-<
()
url <- update "url" -< urlTemplate
Expand Down
10 changes: 6 additions & 4 deletions src/Niv/GitHub/API.hs
Original file line number Diff line number Diff line change
Expand Up @@ -78,19 +78,21 @@ Make sure the repository exists.

defaultRequest :: [T.Text] -> IO HTTP.Request
defaultRequest (map T.encodeUtf8 -> parts) = do
let path = T.encodeUtf8 githubPath <> BS8.intercalate "/" (parts)
let path = T.encodeUtf8 githubPath <> BS8.intercalate "/" parts
mtoken <- lookupEnv' "GITHUB_TOKEN"
pure
$ ( flip (maybe id) mtoken $ \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"
$ HTTP.setRequestSecure githubSecure
$ HTTP.setRequestHost (T.encodeUtf8 githubApiHost)
$ HTTP.setRequestPort githubApiPort
$ HTTP.defaultRequest
$ HTTP.setRequestPort githubApiPort HTTP.defaultRequest

-- | Get the latest revision for owner, repo and branch.
-- TODO: explain no error handling
Expand Down
16 changes: 7 additions & 9 deletions src/Niv/GitHub/Cmd.hs
Original file line number Diff line number Diff line change
Expand Up @@ -46,7 +46,7 @@ githubCmd =

parseGitHubPackageSpec :: Opts.Parser PackageSpec
parseGitHubPackageSpec =
(PackageSpec . KM.fromList)
PackageSpec . KM.fromList
<$> many parseAttribute
where
parseAttribute :: Opts.Parser (K.Key, Aeson.Value)
Expand All @@ -66,15 +66,15 @@ parseGitHubPackageSpec =
<> Opts.help "Set the package spec attribute <KEY> to <VAL>."
)
<|> shortcutAttributes
<|> ( (("url_template",) . Aeson.String)
<|> ( ("url_template",) . Aeson.String
<$> Opts.strOption
( Opts.long "template"
<> Opts.short 't'
<> Opts.metavar "URL"
<> Opts.help "Used during 'update' when building URL. Occurrences of <foo> are replaced with attribute 'foo'."
)
)
<|> ( (("type",) . Aeson.String)
<|> ( ("type",) . Aeson.String
<$> Opts.strOption
( Opts.long "type"
<> Opts.short 'T'
Expand All @@ -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
Expand All @@ -114,7 +112,7 @@ parseGitHubPackageSpec =
"Equivalent to --attribute "
<> attr
<> "=<"
<> (T.toUpper attr)
<> T.toUpper attr
<> ">"
)
)
Expand Down Expand Up @@ -165,15 +163,15 @@ 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
-- From the nix-prefetch-url documentation:
-- 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 =
Expand Down
5 changes: 1 addition & 4 deletions src/Niv/Local/Cmd.hs
Original file line number Diff line number Diff line change
@@ -1,10 +1,7 @@
{-# LANGUAGE Arrows #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

module Niv.Local.Cmd where

Expand Down Expand Up @@ -34,7 +31,7 @@ localCmd =

parseLocalShortcut :: T.Text -> Maybe (PackageName, Aeson.Object)
parseLocalShortcut txt =
if (T.isPrefixOf "./" txt || T.isPrefixOf "/" txt)
if T.isPrefixOf "./" txt || T.isPrefixOf "/" txt
then do
let n = last $ T.splitOn "/" txt
Just (PackageName n, KM.fromList [("path", Aeson.String txt)])
Expand Down
3 changes: 1 addition & 2 deletions src/Niv/Logger.hs
Original file line number Diff line number Diff line change
@@ -1,5 +1,4 @@
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

Expand Down Expand Up @@ -56,7 +55,7 @@ setColors :: Colors -> IO ()
setColors = writeIORef colors

useColors :: Bool
useColors = unsafePerformIO $ (\c -> c == Always) <$> readIORef colors
useColors = unsafePerformIO $ (== Always) <$> readIORef colors

type S = String -> String

Expand Down
17 changes: 9 additions & 8 deletions src/Niv/Sources.hs
Original file line number Diff line number Diff line change
Expand Up @@ -62,13 +62,14 @@ getSourcesEither fsj = do
valueToSources :: Aeson.Value -> Maybe Sources
valueToSources = \case
Aeson.Object obj ->
fmap (Sources . mapKeys PackageName . KM.toHashMapText) $
traverse
( \case
Aeson.Object obj' -> Just (PackageSpec obj')
_ -> Nothing
)
obj
( Sources . mapKeys PackageName . KM.toHashMapText
<$> traverse
( \case
Aeson.Object obj' -> Just (PackageSpec obj')
_ -> Nothing
)
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
Expand All @@ -86,7 +87,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)
Expand Down
10 changes: 5 additions & 5 deletions src/Niv/Update.hs
Original file line number Diff line number Diff line change
Expand Up @@ -70,11 +70,11 @@ data Compose a c = forall b. Compose' (Update b c) (Update a b)

-- | Run an 'Update' and return the new attributes and result.
runUpdate :: Attrs -> Update () a -> IO (Attrs, a)
runUpdate (attrs) a = boxAttrs attrs >>= flip runUpdate' a >>= feed
runUpdate attrs a = boxAttrs attrs >>= flip runUpdate' a >>= feed
where
feed = \case
UpdateReady res -> hndl res
UpdateNeedMore next -> next (()) >>= hndl
UpdateNeedMore next -> next () >>= hndl
hndl = \case
UpdateSuccess f v -> (,v) <$> unboxAttrs f
UpdateFailed e -> error $ "Update failed: " <> T.unpack (prettyFail e)
Expand Down Expand Up @@ -239,7 +239,7 @@ runUpdate' attrs = \case
Update k -> pure $ case HMS.lookup k attrs of
Just (Locked, v) -> UpdateReady $ UpdateSuccess attrs v
Just (Free, v) -> UpdateNeedMore $ \gtt -> do
if (boxNew gtt)
if boxNew gtt
then do
v' <- boxOp v
gtt' <- boxOp gtt
Expand Down Expand Up @@ -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
Expand All @@ -302,7 +302,7 @@ renderTemplate vals tpl = case T.uncons tpl of
case T.span (/= '>') str of
(key, T.uncons -> Just ('>', rest)) -> do
let v = vals key
(liftA2 (<>) v) (renderTemplate vals rest)
liftA2 (<>) v (renderTemplate vals rest)
_ -> Nothing
Just (c, str) -> fmap (T.cons c) <$> renderTemplate vals str
Nothing -> Just $ pure T.empty
Expand Down
Loading

0 comments on commit f7c5388

Please sign in to comment.