1
1
mirror of https://github.com/nmattia/niv.git synced 2024-10-04 03:17:21 +03:00

hlint refactor

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:
Finn Landweber 2024-05-21 19:10:52 +02:00
parent 0ca27c51ab
commit d454504c2c
No known key found for this signature in database
10 changed files with 61 additions and 72 deletions

View File

@ -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
@ -276,15 +272,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 =
@ -367,7 +363,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 $
@ -395,7 +391,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
@ -474,8 +470,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 $
@ -485,7 +480,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 ::
@ -581,7 +576,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 $

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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 =

View File

@ -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)])

View File

@ -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

View File

@ -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)

View File

@ -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

View File

@ -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")