mirror of
https://github.com/nmattia/niv.git
synced 2024-10-06 12:27:35 +03:00
hlint refactor (#403)
Was perfomed using `find -name '*.hs' -exec hlint -i "Missing NOINLINE pragma" -i "Use uncurry" -i "Use const" --refactor --refactor-options="--inplace" {} \;`
This commit is contained in:
parent
84fed676e4
commit
f7c5388378
@ -2,7 +2,6 @@
|
|||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
|
||||||
{-# LANGUAGE TupleSections #-}
|
{-# LANGUAGE TupleSections #-}
|
||||||
{-# LANGUAGE ViewPatterns #-}
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
|
||||||
@ -56,8 +55,7 @@ li = liftIO
|
|||||||
cli :: IO ()
|
cli :: IO ()
|
||||||
cli = do
|
cli = do
|
||||||
((fsj, colors), nio) <-
|
((fsj, colors), nio) <-
|
||||||
execParserPure' Opts.defaultPrefs opts <$> getArgs
|
getArgs >>= Opts.handleParseResult . execParserPure' Opts.defaultPrefs opts
|
||||||
>>= Opts.handleParseResult
|
|
||||||
setColors colors
|
setColors colors
|
||||||
runReaderT (runNIO nio) fsj
|
runReaderT (runNIO nio) fsj
|
||||||
where
|
where
|
||||||
@ -115,7 +113,7 @@ parsePackageName =
|
|||||||
<$> Opts.argument Opts.str (Opts.metavar "PACKAGE")
|
<$> Opts.argument Opts.str (Opts.metavar "PACKAGE")
|
||||||
|
|
||||||
parsePackage :: Opts.Parser (PackageName, PackageSpec)
|
parsePackage :: Opts.Parser (PackageName, PackageSpec)
|
||||||
parsePackage = (,) <$> parsePackageName <*> (parsePackageSpec githubCmd)
|
parsePackage = (,) <$> parsePackageName <*> parsePackageSpec githubCmd
|
||||||
|
|
||||||
-------------------------------------------------------------------------------
|
-------------------------------------------------------------------------------
|
||||||
-- INIT
|
-- INIT
|
||||||
@ -158,22 +156,20 @@ parseNixpkgs = parseNixpkgsFast <|> parseNixpkgsLatest <|> parseNixpkgsCustom <|
|
|||||||
<> Opts.help "Pull the latest unstable nixpkgs from NixOS/nixpkgs."
|
<> Opts.help "Pull the latest unstable nixpkgs from NixOS/nixpkgs."
|
||||||
)
|
)
|
||||||
parseNixpkgsCustom =
|
parseNixpkgsCustom =
|
||||||
(flip NixpkgsCustom)
|
flip NixpkgsCustom
|
||||||
<$> ( Opts.option
|
<$> Opts.option
|
||||||
customNixpkgsReader
|
customNixpkgsReader
|
||||||
( Opts.long "nixpkgs"
|
( Opts.long "nixpkgs"
|
||||||
<> Opts.showDefault
|
<> Opts.showDefault
|
||||||
<> Opts.help "Use a custom nixpkgs repository from GitHub."
|
<> Opts.help "Use a custom nixpkgs repository from GitHub."
|
||||||
<> Opts.metavar "OWNER/REPO"
|
<> Opts.metavar "OWNER/REPO"
|
||||||
)
|
)
|
||||||
)
|
<*> Opts.strOption
|
||||||
<*> ( Opts.strOption
|
( Opts.long "nixpkgs-branch"
|
||||||
( Opts.long "nixpkgs-branch"
|
<> Opts.short 'b'
|
||||||
<> Opts.short 'b'
|
<> Opts.help "The nixpkgs branch when using --nixpkgs ...."
|
||||||
<> Opts.help "The nixpkgs branch when using --nixpkgs ...."
|
<> Opts.showDefault
|
||||||
<> Opts.showDefault
|
)
|
||||||
)
|
|
||||||
)
|
|
||||||
parseNoNixpkgs =
|
parseNoNixpkgs =
|
||||||
Opts.flag'
|
Opts.flag'
|
||||||
NoNixpkgs
|
NoNixpkgs
|
||||||
@ -285,15 +281,15 @@ parseCmdAdd :: Opts.ParserInfo (NIO ())
|
|||||||
parseCmdAdd =
|
parseCmdAdd =
|
||||||
Opts.info
|
Opts.info
|
||||||
((parseCommands <|> parseShortcuts) <**> Opts.helper)
|
((parseCommands <|> parseShortcuts) <**> Opts.helper)
|
||||||
$ (description githubCmd)
|
$ description githubCmd
|
||||||
where
|
where
|
||||||
-- XXX: this should parse many shortcuts (github, git). Right now we only
|
-- XXX: this should parse many shortcuts (github, git). Right now we only
|
||||||
-- parse GitHub because the git interface is still experimental. note to
|
-- parse GitHub because the git interface is still experimental. note to
|
||||||
-- implementer: it'll be tricky to have the correct arguments show up
|
-- implementer: it'll be tricky to have the correct arguments show up
|
||||||
-- without repeating "PACKAGE PACKAGE PACKAGE" for every package type.
|
-- without repeating "PACKAGE PACKAGE PACKAGE" for every package type.
|
||||||
parseShortcuts = parseShortcut githubCmd
|
parseShortcuts = parseShortcut githubCmd
|
||||||
parseShortcut cmd = uncurry (cmdAdd cmd) <$> (parseShortcutArgs cmd)
|
parseShortcut cmd = uncurry (cmdAdd cmd) <$> parseShortcutArgs cmd
|
||||||
parseCmd cmd = uncurry (cmdAdd cmd) <$> (parseCmdArgs cmd)
|
parseCmd cmd = uncurry (cmdAdd cmd) <$> parseCmdArgs cmd
|
||||||
parseCmdAddGit =
|
parseCmdAddGit =
|
||||||
Opts.info (parseCmd gitCmd <**> Opts.helper) (description gitCmd)
|
Opts.info (parseCmd gitCmd <**> Opts.helper) (description gitCmd)
|
||||||
parseCmdAddLocal =
|
parseCmdAddLocal =
|
||||||
@ -376,7 +372,7 @@ cmdAdd cmd packageName attrs = do
|
|||||||
case eFinalSpec of
|
case eFinalSpec of
|
||||||
Left e -> li (abortUpdateFailed [(packageName, e)])
|
Left e -> li (abortUpdateFailed [(packageName, e)])
|
||||||
Right finalSpec -> do
|
Right finalSpec -> do
|
||||||
say $ "Writing new sources file"
|
say "Writing new sources file"
|
||||||
li $
|
li $
|
||||||
setSources fsj $
|
setSources fsj $
|
||||||
Sources $
|
Sources $
|
||||||
@ -404,7 +400,7 @@ cmdShow = \case
|
|||||||
Nothing -> do
|
Nothing -> do
|
||||||
fsj <- getFindSourcesJson
|
fsj <- getFindSourcesJson
|
||||||
sources <- unSources <$> li (getSources fsj)
|
sources <- unSources <$> li (getSources fsj)
|
||||||
forWithKeyM_ sources $ showPackage
|
forWithKeyM_ sources showPackage
|
||||||
|
|
||||||
showPackage :: (MonadIO io) => PackageName -> PackageSpec -> io ()
|
showPackage :: (MonadIO io) => PackageName -> PackageSpec -> io ()
|
||||||
showPackage (PackageName pname) (PackageSpec spec) = do
|
showPackage (PackageName pname) (PackageSpec spec) = do
|
||||||
@ -483,8 +479,7 @@ cmdUpdate = \case
|
|||||||
Just "git" -> gitCmd
|
Just "git" -> gitCmd
|
||||||
Just "local" -> localCmd
|
Just "local" -> localCmd
|
||||||
_ -> githubCmd
|
_ -> githubCmd
|
||||||
finalSpec <- fmap attrsToSpec <$> li (doUpdate initialSpec cmd)
|
fmap attrsToSpec <$> li (doUpdate initialSpec cmd)
|
||||||
pure finalSpec
|
|
||||||
let (failed, sources') = partitionEithersHMS esources'
|
let (failed, sources') = partitionEithersHMS esources'
|
||||||
unless (HMS.null failed) $
|
unless (HMS.null failed) $
|
||||||
li $
|
li $
|
||||||
@ -494,7 +489,7 @@ cmdUpdate = \case
|
|||||||
-- | pretty much tryEvalUpdate but we might issue some warnings first
|
-- | pretty much tryEvalUpdate but we might issue some warnings first
|
||||||
doUpdate :: Attrs -> Cmd -> IO (Either SomeException Attrs)
|
doUpdate :: Attrs -> Cmd -> IO (Either SomeException Attrs)
|
||||||
doUpdate attrs cmd = do
|
doUpdate attrs cmd = do
|
||||||
forM_ (extraLogs cmd attrs) $ tsay
|
forM_ (extraLogs cmd attrs) tsay
|
||||||
tryEvalUpdate attrs (updateCmd cmd)
|
tryEvalUpdate attrs (updateCmd cmd)
|
||||||
|
|
||||||
partitionEithersHMS ::
|
partitionEithersHMS ::
|
||||||
@ -590,7 +585,7 @@ cmdDrop packageName = \case
|
|||||||
tsay $ "Dropping package: " <> unPackageName packageName
|
tsay $ "Dropping package: " <> unPackageName packageName
|
||||||
fsj <- getFindSourcesJson
|
fsj <- getFindSourcesJson
|
||||||
sources <- unSources <$> li (getSources fsj)
|
sources <- unSources <$> li (getSources fsj)
|
||||||
when (not $ HMS.member packageName sources) $
|
unless (HMS.member packageName sources) $
|
||||||
li $
|
li $
|
||||||
abortCannotDropNoSuchPackage packageName
|
abortCannotDropNoSuchPackage packageName
|
||||||
li $
|
li $
|
||||||
|
@ -1,6 +1,5 @@
|
|||||||
{-# LANGUAGE Arrows #-}
|
{-# LANGUAGE Arrows #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE TupleSections #-}
|
{-# LANGUAGE TupleSections #-}
|
||||||
{-# LANGUAGE ViewPatterns #-}
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
@ -13,6 +12,7 @@ import qualified Data.Aeson as Aeson
|
|||||||
import qualified Data.Aeson.Key as K
|
import qualified Data.Aeson.Key as K
|
||||||
import qualified Data.Aeson.KeyMap as KM
|
import qualified Data.Aeson.KeyMap as KM
|
||||||
import qualified Data.ByteString.Char8 as B8
|
import qualified Data.ByteString.Char8 as B8
|
||||||
|
import Data.Char (isDigit)
|
||||||
import qualified Data.HashMap.Strict as HMS
|
import qualified Data.HashMap.Strict as HMS
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
@ -53,7 +53,7 @@ gitExtraLogs attrs = noteRef <> warnRefBranch <> warnRefTag
|
|||||||
mkWarn
|
mkWarn
|
||||||
"Your source contains both a `ref` and a `tag`. The `ref` will be used by Nix to fetch the repo."
|
"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
|
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 :: T.Text -> Maybe (PackageName, Aeson.Object)
|
||||||
parseGitShortcut txt'@(T.dropWhileEnd (== '/') -> txt) =
|
parseGitShortcut txt'@(T.dropWhileEnd (== '/') -> txt) =
|
||||||
@ -76,7 +76,7 @@ parseGitShortcut txt'@(T.dropWhileEnd (== '/') -> txt) =
|
|||||||
|
|
||||||
parseGitPackageSpec :: Opts.Parser PackageSpec
|
parseGitPackageSpec :: Opts.Parser PackageSpec
|
||||||
parseGitPackageSpec =
|
parseGitPackageSpec =
|
||||||
(PackageSpec . KM.fromList)
|
PackageSpec . KM.fromList
|
||||||
<$> many (parseRepo <|> parseBranch <|> parseRev <|> parseAttr <|> parseSAttr)
|
<$> many (parseRepo <|> parseBranch <|> parseRev <|> parseAttr <|> parseSAttr)
|
||||||
where
|
where
|
||||||
parseRepo =
|
parseRepo =
|
||||||
@ -180,7 +180,7 @@ latestRev repo branch = do
|
|||||||
sout <- runGit gitArgs
|
sout <- runGit gitArgs
|
||||||
case sout of
|
case sout of
|
||||||
ls@(_ : _ : _) -> abortTooMuchOutput gitArgs ls
|
ls@(_ : _ : _) -> abortTooMuchOutput gitArgs ls
|
||||||
(l1 : []) -> parseRev gitArgs l1
|
[l1] -> parseRev gitArgs l1
|
||||||
[] -> abortNoOutput gitArgs
|
[] -> abortNoOutput gitArgs
|
||||||
where
|
where
|
||||||
parseRev args l = maybe (abortNoRev args l) pure $ do
|
parseRev args l = maybe (abortNoRev args l) pure $ do
|
||||||
@ -242,7 +242,7 @@ runGit args = do
|
|||||||
isRev :: T.Text -> Bool
|
isRev :: T.Text -> Bool
|
||||||
isRev t =
|
isRev t =
|
||||||
-- commit hashes are comprised of abcdef0123456789
|
-- 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
|
-- commit _should_ be 40 chars long, but to be sure we pick 7
|
||||||
T.length t >= 7
|
T.length t >= 7
|
||||||
|
@ -1,9 +1,6 @@
|
|||||||
{-# LANGUAGE Arrows #-}
|
{-# LANGUAGE Arrows #-}
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE LambdaCase #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
|
||||||
{-# LANGUAGE ViewPatterns #-}
|
|
||||||
|
|
||||||
module Niv.GitHub where
|
module Niv.GitHub where
|
||||||
|
|
||||||
@ -31,7 +28,7 @@ githubUpdate ::
|
|||||||
githubUpdate prefetch latestRev ghRepo = proc () -> do
|
githubUpdate prefetch latestRev ghRepo = proc () -> do
|
||||||
urlTemplate <-
|
urlTemplate <-
|
||||||
template
|
template
|
||||||
<<< (useOrSet "url_template" <<< completeSpec) <+> (load "url_template")
|
<<< (useOrSet "url_template" <<< completeSpec) <+> load "url_template"
|
||||||
-<
|
-<
|
||||||
()
|
()
|
||||||
url <- update "url" -< urlTemplate
|
url <- update "url" -< urlTemplate
|
||||||
|
@ -78,19 +78,21 @@ Make sure the repository exists.
|
|||||||
|
|
||||||
defaultRequest :: [T.Text] -> IO HTTP.Request
|
defaultRequest :: [T.Text] -> IO HTTP.Request
|
||||||
defaultRequest (map T.encodeUtf8 -> parts) = do
|
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"
|
mtoken <- lookupEnv' "GITHUB_TOKEN"
|
||||||
pure
|
pure
|
||||||
$ ( flip (maybe id) mtoken $ \token ->
|
$ maybe
|
||||||
|
id
|
||||||
|
( \token ->
|
||||||
HTTP.addRequestHeader "authorization" ("token " <> BS8.pack token)
|
HTTP.addRequestHeader "authorization" ("token " <> BS8.pack token)
|
||||||
)
|
)
|
||||||
|
mtoken
|
||||||
$ HTTP.setRequestPath path
|
$ HTTP.setRequestPath path
|
||||||
$ HTTP.addRequestHeader "user-agent" "niv"
|
$ HTTP.addRequestHeader "user-agent" "niv"
|
||||||
$ HTTP.addRequestHeader "accept" "application/vnd.github.v3+json"
|
$ HTTP.addRequestHeader "accept" "application/vnd.github.v3+json"
|
||||||
$ HTTP.setRequestSecure githubSecure
|
$ HTTP.setRequestSecure githubSecure
|
||||||
$ HTTP.setRequestHost (T.encodeUtf8 githubApiHost)
|
$ HTTP.setRequestHost (T.encodeUtf8 githubApiHost)
|
||||||
$ HTTP.setRequestPort githubApiPort
|
$ HTTP.setRequestPort githubApiPort HTTP.defaultRequest
|
||||||
$ HTTP.defaultRequest
|
|
||||||
|
|
||||||
-- | Get the latest revision for owner, repo and branch.
|
-- | Get the latest revision for owner, repo and branch.
|
||||||
-- TODO: explain no error handling
|
-- TODO: explain no error handling
|
||||||
|
@ -46,7 +46,7 @@ githubCmd =
|
|||||||
|
|
||||||
parseGitHubPackageSpec :: Opts.Parser PackageSpec
|
parseGitHubPackageSpec :: Opts.Parser PackageSpec
|
||||||
parseGitHubPackageSpec =
|
parseGitHubPackageSpec =
|
||||||
(PackageSpec . KM.fromList)
|
PackageSpec . KM.fromList
|
||||||
<$> many parseAttribute
|
<$> many parseAttribute
|
||||||
where
|
where
|
||||||
parseAttribute :: Opts.Parser (K.Key, Aeson.Value)
|
parseAttribute :: Opts.Parser (K.Key, Aeson.Value)
|
||||||
@ -66,7 +66,7 @@ parseGitHubPackageSpec =
|
|||||||
<> Opts.help "Set the package spec attribute <KEY> to <VAL>."
|
<> Opts.help "Set the package spec attribute <KEY> to <VAL>."
|
||||||
)
|
)
|
||||||
<|> shortcutAttributes
|
<|> shortcutAttributes
|
||||||
<|> ( (("url_template",) . Aeson.String)
|
<|> ( ("url_template",) . Aeson.String
|
||||||
<$> Opts.strOption
|
<$> Opts.strOption
|
||||||
( Opts.long "template"
|
( Opts.long "template"
|
||||||
<> Opts.short 't'
|
<> Opts.short 't'
|
||||||
@ -74,7 +74,7 @@ parseGitHubPackageSpec =
|
|||||||
<> Opts.help "Used during 'update' when building URL. Occurrences of <foo> are replaced with attribute 'foo'."
|
<> 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.strOption
|
||||||
( Opts.long "type"
|
( Opts.long "type"
|
||||||
<> Opts.short 'T'
|
<> Opts.short 'T'
|
||||||
@ -96,9 +96,7 @@ parseGitHubPackageSpec =
|
|||||||
-- Shortcuts for common attributes
|
-- Shortcuts for common attributes
|
||||||
shortcutAttributes :: Opts.Parser (K.Key, Aeson.Value)
|
shortcutAttributes :: Opts.Parser (K.Key, Aeson.Value)
|
||||||
shortcutAttributes =
|
shortcutAttributes =
|
||||||
foldr (<|>) empty $
|
foldr ((<|>) . mkShortcutAttribute) empty ["branch", "owner", "rev", "version"]
|
||||||
mkShortcutAttribute
|
|
||||||
<$> ["branch", "owner", "rev", "version"]
|
|
||||||
-- TODO: infer those shortcuts from 'Update' keys
|
-- TODO: infer those shortcuts from 'Update' keys
|
||||||
mkShortcutAttribute :: T.Text -> Opts.Parser (K.Key, Aeson.Value)
|
mkShortcutAttribute :: T.Text -> Opts.Parser (K.Key, Aeson.Value)
|
||||||
mkShortcutAttribute = \case
|
mkShortcutAttribute = \case
|
||||||
@ -114,7 +112,7 @@ parseGitHubPackageSpec =
|
|||||||
"Equivalent to --attribute "
|
"Equivalent to --attribute "
|
||||||
<> attr
|
<> attr
|
||||||
<> "=<"
|
<> "=<"
|
||||||
<> (T.toUpper attr)
|
<> T.toUpper attr
|
||||||
<> ">"
|
<> ">"
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
@ -165,7 +163,7 @@ nixPrefetchURL unpack turl@(T.unpack -> url) = do
|
|||||||
(ExitSuccess, l : _) -> pure $ T.pack l
|
(ExitSuccess, l : _) -> pure $ T.pack l
|
||||||
_ -> abortNixPrefetchExpectedOutput (T.pack <$> args) (T.pack sout) (T.pack serr)
|
_ -> abortNixPrefetchExpectedOutput (T.pack <$> args) (T.pack sout) (T.pack serr)
|
||||||
where
|
where
|
||||||
args = (if unpack then ["--unpack"] else []) <> [url, "--name", sanitizeName basename]
|
args = (["--unpack" | unpack]) <> [url, "--name", sanitizeName basename]
|
||||||
runNixPrefetch = readProcessWithExitCode "nix-prefetch-url" args ""
|
runNixPrefetch = readProcessWithExitCode "nix-prefetch-url" args ""
|
||||||
sanitizeName = T.unpack . T.filter isOk
|
sanitizeName = T.unpack . T.filter isOk
|
||||||
basename = last $ T.splitOn "/" turl
|
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
|
-- Path names are alphanumeric and can include the symbols +-._?= and must
|
||||||
-- not begin with a period.
|
-- not begin with a period.
|
||||||
-- (note: we assume they don't 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 :: [T.Text] -> T.Text -> T.Text -> IO a
|
||||||
abortNixPrefetchExpectedOutput args sout serr =
|
abortNixPrefetchExpectedOutput args sout serr =
|
||||||
|
@ -1,10 +1,7 @@
|
|||||||
{-# LANGUAGE Arrows #-}
|
{-# LANGUAGE Arrows #-}
|
||||||
{-# LANGUAGE LambdaCase #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE TupleSections #-}
|
{-# LANGUAGE TupleSections #-}
|
||||||
{-# LANGUAGE ViewPatterns #-}
|
|
||||||
|
|
||||||
module Niv.Local.Cmd where
|
module Niv.Local.Cmd where
|
||||||
|
|
||||||
@ -34,7 +31,7 @@ localCmd =
|
|||||||
|
|
||||||
parseLocalShortcut :: T.Text -> Maybe (PackageName, Aeson.Object)
|
parseLocalShortcut :: T.Text -> Maybe (PackageName, Aeson.Object)
|
||||||
parseLocalShortcut txt =
|
parseLocalShortcut txt =
|
||||||
if (T.isPrefixOf "./" txt || T.isPrefixOf "/" txt)
|
if T.isPrefixOf "./" txt || T.isPrefixOf "/" txt
|
||||||
then do
|
then do
|
||||||
let n = last $ T.splitOn "/" txt
|
let n = last $ T.splitOn "/" txt
|
||||||
Just (PackageName n, KM.fromList [("path", Aeson.String txt)])
|
Just (PackageName n, KM.fromList [("path", Aeson.String txt)])
|
||||||
|
@ -1,5 +1,4 @@
|
|||||||
{-# LANGUAGE DerivingStrategies #-}
|
{-# LANGUAGE DerivingStrategies #-}
|
||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
@ -56,7 +55,7 @@ setColors :: Colors -> IO ()
|
|||||||
setColors = writeIORef colors
|
setColors = writeIORef colors
|
||||||
|
|
||||||
useColors :: Bool
|
useColors :: Bool
|
||||||
useColors = unsafePerformIO $ (\c -> c == Always) <$> readIORef colors
|
useColors = unsafePerformIO $ (== Always) <$> readIORef colors
|
||||||
|
|
||||||
type S = String -> String
|
type S = String -> String
|
||||||
|
|
||||||
|
@ -62,13 +62,14 @@ getSourcesEither fsj = do
|
|||||||
valueToSources :: Aeson.Value -> Maybe Sources
|
valueToSources :: Aeson.Value -> Maybe Sources
|
||||||
valueToSources = \case
|
valueToSources = \case
|
||||||
Aeson.Object obj ->
|
Aeson.Object obj ->
|
||||||
fmap (Sources . mapKeys PackageName . KM.toHashMapText) $
|
( Sources . mapKeys PackageName . KM.toHashMapText
|
||||||
traverse
|
<$> traverse
|
||||||
( \case
|
( \case
|
||||||
Aeson.Object obj' -> Just (PackageSpec obj')
|
Aeson.Object obj' -> Just (PackageSpec obj')
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
)
|
)
|
||||||
obj
|
obj
|
||||||
|
)
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
mapKeys :: (Eq k2, Hashable k2) => (k1 -> k2) -> HMS.HashMap k1 v -> HMS.HashMap k2 v
|
mapKeys :: (Eq k2, Hashable k2) => (k1 -> k2) -> HMS.HashMap k1 v -> HMS.HashMap k2 v
|
||||||
mapKeys f = HMS.fromList . map (first f) . HMS.toList
|
mapKeys f = HMS.fromList . map (first f) . HMS.toList
|
||||||
@ -86,7 +87,7 @@ getSources fsj = do
|
|||||||
pure
|
pure
|
||||||
|
|
||||||
setSources :: FindSourcesJson -> Sources -> IO ()
|
setSources :: FindSourcesJson -> Sources -> IO ()
|
||||||
setSources fsj sources = Aeson.encodeFilePretty (pathNixSourcesJson fsj) sources
|
setSources fsj = Aeson.encodeFilePretty (pathNixSourcesJson fsj)
|
||||||
|
|
||||||
newtype PackageName = PackageName {unPackageName :: T.Text}
|
newtype PackageName = PackageName {unPackageName :: T.Text}
|
||||||
deriving newtype (Eq, Hashable, FromJSONKey, ToJSONKey, Show)
|
deriving newtype (Eq, Hashable, FromJSONKey, ToJSONKey, Show)
|
||||||
|
@ -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.
|
-- | Run an 'Update' and return the new attributes and result.
|
||||||
runUpdate :: Attrs -> Update () a -> IO (Attrs, a)
|
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
|
where
|
||||||
feed = \case
|
feed = \case
|
||||||
UpdateReady res -> hndl res
|
UpdateReady res -> hndl res
|
||||||
UpdateNeedMore next -> next (()) >>= hndl
|
UpdateNeedMore next -> next () >>= hndl
|
||||||
hndl = \case
|
hndl = \case
|
||||||
UpdateSuccess f v -> (,v) <$> unboxAttrs f
|
UpdateSuccess f v -> (,v) <$> unboxAttrs f
|
||||||
UpdateFailed e -> error $ "Update failed: " <> T.unpack (prettyFail e)
|
UpdateFailed e -> error $ "Update failed: " <> T.unpack (prettyFail e)
|
||||||
@ -239,7 +239,7 @@ runUpdate' attrs = \case
|
|||||||
Update k -> pure $ case HMS.lookup k attrs of
|
Update k -> pure $ case HMS.lookup k attrs of
|
||||||
Just (Locked, v) -> UpdateReady $ UpdateSuccess attrs v
|
Just (Locked, v) -> UpdateReady $ UpdateSuccess attrs v
|
||||||
Just (Free, v) -> UpdateNeedMore $ \gtt -> do
|
Just (Free, v) -> UpdateNeedMore $ \gtt -> do
|
||||||
if (boxNew gtt)
|
if boxNew gtt
|
||||||
then do
|
then do
|
||||||
v' <- boxOp v
|
v' <- boxOp v
|
||||||
gtt' <- boxOp gtt
|
gtt' <- boxOp gtt
|
||||||
@ -276,7 +276,7 @@ runUpdate' attrs = \case
|
|||||||
v' <- runBox v
|
v' <- runBox v
|
||||||
case renderTemplate
|
case renderTemplate
|
||||||
( \k ->
|
( \k ->
|
||||||
((decodeBox $ "When rendering template " <> v') . snd)
|
decodeBox ("When rendering template " <> v') . snd
|
||||||
<$> HMS.lookup k attrs
|
<$> HMS.lookup k attrs
|
||||||
)
|
)
|
||||||
v' of
|
v' of
|
||||||
@ -302,7 +302,7 @@ renderTemplate vals tpl = case T.uncons tpl of
|
|||||||
case T.span (/= '>') str of
|
case T.span (/= '>') str of
|
||||||
(key, T.uncons -> Just ('>', rest)) -> do
|
(key, T.uncons -> Just ('>', rest)) -> do
|
||||||
let v = vals key
|
let v = vals key
|
||||||
(liftA2 (<>) v) (renderTemplate vals rest)
|
liftA2 (<>) v (renderTemplate vals rest)
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
Just (c, str) -> fmap (T.cons c) <$> renderTemplate vals str
|
Just (c, str) -> fmap (T.cons c) <$> renderTemplate vals str
|
||||||
Nothing -> Just $ pure T.empty
|
Nothing -> Just $ pure T.empty
|
||||||
|
@ -68,8 +68,8 @@ isNotTooEager = do
|
|||||||
let f1 = proc () -> do
|
let f1 = proc () -> do
|
||||||
run (const $ error "IO is too eager (f1)") -< pure ()
|
run (const $ error "IO is too eager (f1)") -< pure ()
|
||||||
useOrSet "foo" -< "foo"
|
useOrSet "foo" -< "foo"
|
||||||
void $ (execUpdate attrs f :: IO (Box T.Text))
|
void (execUpdate attrs f :: IO (Box T.Text))
|
||||||
void $ (execUpdate attrs f1 :: IO (Box T.Text))
|
void (execUpdate attrs f1 :: IO (Box T.Text))
|
||||||
where
|
where
|
||||||
attrs = HMS.singleton "foo" (Locked, "right")
|
attrs = HMS.singleton "foo" (Locked, "right")
|
||||||
|
|
||||||
|
Loading…
Reference in New Issue
Block a user