From 5933d46bf127e9c3a9312b19ec2dc07ad7031440 Mon Sep 17 00:00:00 2001 From: Anton-Latukha Date: Fri, 5 Mar 2021 00:02:30 +0200 Subject: [PATCH] treewide: switch to new demand all remained cases Builtins, it is 44 uses. Other also. Some refactor in the process. Couple of monadic binds become functors. After this change the code allows more refactors - move `demand`s into `do` blocks and fold the `do` blocks. --- main/Main.hs | 23 +- main/Repl.hs | 91 ++++--- src/Nix.hs | 56 ++-- src/Nix/Builtins.hs | 489 +++++++++++++++------------------- src/Nix/Effects/Basic.hs | 83 +++--- src/Nix/Effects/Derivation.hs | 2 +- src/Nix/Exec.hs | 64 +++-- src/Nix/Json.hs | 38 +-- src/Nix/Lint.hs | 42 ++- src/Nix/Standard.hs | 2 +- src/Nix/String/Coerce.hs | 53 ++-- 11 files changed, 434 insertions(+), 509 deletions(-) diff --git a/main/Main.hs b/main/Main.hs index 6905fb713..e1353cf83 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -214,17 +214,18 @@ main = do _ -> (True, True) forceEntry k v = - catch (pure <$> demandF pure v) $ \(NixException frames) -> do - liftIO - . putStrLn - . ("Exception forcing " <>) - . (k <>) - . (": " <>) - . show - =<< renderFrames @(StdValue (StandardT (StdIdT IO))) - @(StdThunk (StandardT (StdIdT IO))) - frames - pure Nothing + catch (pure <$> (pure =<< demand v)) $ \(NixException frames) -> + do + liftIO + . putStrLn + . ("Exception forcing " <>) + . (k <>) + . (": " <>) + . show + =<< renderFrames @(StdValue (StandardT (StdIdT IO))) + @(StdThunk (StandardT (StdIdT IO))) + frames + pure Nothing reduction path mp x = do eres <- Nix.withNixContext mp diff --git a/main/Repl.hs b/main/Repl.hs index 9549f0dd7..1dc1b23e0 100644 --- a/main/Repl.hs +++ b/main/Repl.hs @@ -27,7 +27,7 @@ import Nix hiding ( exec ) import Nix.Scope import Nix.Utils -import Nix.Value.Monad ( demandF ) +import Nix.Value.Monad ( demand ) import qualified Data.List import qualified Data.Maybe @@ -340,7 +340,7 @@ completion = System.Console.Repline.Prefix -- | Main completion function -- -- Heavily inspired by Dhall Repl, with `algebraicComplete` --- adjusted to monadic variant able to `demandF` thunks. +-- adjusted to monadic variant able to `demand` thunks. completeFunc :: forall e t f m . (MonadNix e t f m, MonadIO m) => String @@ -348,61 +348,66 @@ completeFunc -> (StateT (IState t f m) m) [Completion] completeFunc reversedPrev word -- Commands - | reversedPrev == ":" - = pure . listCompletion + | reversedPrev == ":" = + pure . listCompletion $ fmap helpOptionName (helpOptions :: HelpOptions e t f m) -- Files - | any (`Data.List.isPrefixOf` word) [ "/", "./", "../", "~/" ] - = listFiles word + | any (`Data.List.isPrefixOf` word) [ "/", "./", "../", "~/" ] = + listFiles word -- Attributes of sets in REPL context - | var : subFields <- Data.Text.split (== '.') (Data.Text.pack word) - , not $ null subFields - = do - s <- get - case Data.HashMap.Lazy.lookup var (replCtx s) of - Nothing -> pure mempty - Just binding -> do - candidates <- lift $ algebraicComplete subFields binding - pure $ notFinished <$> listCompletion (Data.Text.unpack . (var <>) <$> candidates) + | var : subFields <- Data.Text.split (== '.') (Data.Text.pack word) , not $ null subFields = + do + s <- get + maybe + (pure mempty) + (\ binding -> + do + candidates <- lift $ algebraicComplete subFields binding + pure $ notFinished <$> listCompletion (Data.Text.unpack . (var <>) <$> candidates) + ) + (Data.HashMap.Lazy.lookup var (replCtx s)) -- Builtins, context variables - | otherwise - = do - s <- get - let contextKeys = Data.HashMap.Lazy.keys (replCtx s) - (Just (NVSet builtins _)) = Data.HashMap.Lazy.lookup "builtins" (replCtx s) - shortBuiltins = Data.HashMap.Lazy.keys builtins - - pure $ listCompletion - $ ["__includes"] - <> (Data.Text.unpack <$> contextKeys) - <> (Data.Text.unpack <$> shortBuiltins) + | otherwise = + do + s <- get + let contextKeys = Data.HashMap.Lazy.keys (replCtx s) + (Just (NVSet builtins _)) = Data.HashMap.Lazy.lookup "builtins" (replCtx s) + shortBuiltins = Data.HashMap.Lazy.keys builtins + + pure $ listCompletion + $ ["__includes"] + <> (Data.Text.unpack <$> contextKeys) + <> (Data.Text.unpack <$> shortBuiltins) where listCompletion = fmap simpleCompletion . filter (word `Data.List.isPrefixOf`) notFinished x = x { isFinished = False } - algebraicComplete :: (MonadNix e t f m) - => [Text] - -> NValue t f m - -> m [Text] + algebraicComplete + :: (MonadNix e t f m) + => [Text] + -> NValue t f m + -> m [Text] algebraicComplete subFields val = - let keys = fmap ("." <>) . Data.HashMap.Lazy.keys - withMap m = - case subFields of - [] -> pure $ keys m - -- Stop on last subField (we care about the keys at this level) - [_] -> pure $ keys m - f:fs -> - maybe - (pure mempty) - (demandF (\e' -> (fmap . fmap) (("." <> f) <>) $ algebraicComplete fs e')) - (Data.HashMap.Lazy.lookup f m) - - in case val of + let + keys = fmap ("." <>) . Data.HashMap.Lazy.keys + + withMap m = + case subFields of + [] -> pure $ keys m + -- Stop on last subField (we care about the keys at this level) + [_] -> pure $ keys m + f:fs -> + maybe + (pure mempty) + (((fmap . fmap) (("." <> f) <>) . algebraicComplete fs) <=< demand) + (Data.HashMap.Lazy.lookup f m) + in + case val of NVSet xs _ -> withMap xs _ -> pure mempty diff --git a/src/Nix.hs b/src/Nix.hs index 0ccd3d274..dadaf3470 100644 --- a/src/Nix.hs +++ b/src/Nix.hs @@ -115,14 +115,12 @@ evaluateExpression mpath evaluator handler expr = do (second mkStr) (argstr opts) evaluator mpath expr >>= \f -> - demandF - (\f' -> - processResult handler =<< - case f' of - NVClosure _ g -> g (argmap args) - _ -> pure f - ) - f + (\f' -> + processResult handler =<< + case f' of + NVClosure _ g -> g (argmap args) + _ -> pure f + ) =<< demand f where parseArg s = case parseNixText s of @@ -149,29 +147,25 @@ processResult h val = do go :: [Text.Text] -> NValue t f m -> m a go [] v = h v go ((Text.decimal -> Right (n,"")) : ks) v = - demandF - (\case - NVList xs -> - list + (\case + NVList xs -> + list + h + go + ks + (xs !! n) + _ -> errorWithoutStackTrace $ "Expected a list for selector '" <> show n <> "', but got: " <> show v + ) =<< demand v + go (k : ks) v = + (\case + NVSet xs _ -> + maybe + (errorWithoutStackTrace $ "Set does not contain key '" <> Text.unpack k <> "'") + (list h go ks - (xs !! n) - _ -> errorWithoutStackTrace $ "Expected a list for selector '" <> show n <> "', but got: " <> show v - ) - v - go (k : ks) v = - demandF - (\case - NVSet xs _ -> - maybe - (errorWithoutStackTrace $ "Set does not contain key '" <> Text.unpack k <> "'") - (list - h - go - ks - ) - (M.lookup k xs) - _ -> errorWithoutStackTrace $ "Expected a set for selector '" <> Text.unpack k <> "', but got: " <> show v - ) - v + ) + (M.lookup k xs) + _ -> errorWithoutStackTrace $ "Expected a set for selector '" <> Text.unpack k <> "', but got: " <> show v + ) =<< demand v diff --git a/src/Nix/Builtins.hs b/src/Nix/Builtins.hs index a4dda4fdc..6a0746490 100644 --- a/src/Nix/Builtins.hs +++ b/src/Nix/Builtins.hs @@ -360,7 +360,7 @@ foldNixPath f z = do dirs <- maybe (pure mempty) - (demandF (fromValue . Deeper)) + ((fromValue . Deeper) <=< demand) mres mPath <- getEnvVar "NIX_PATH" mDataDir <- getEnvVar "NIX_DATA_DIR" @@ -449,20 +449,16 @@ unsafeGetAttrPos -> NValue t f m -> m (NValue t f m) unsafeGetAttrPos x y = - demandF - (\x' -> - demandF - (\y' -> case (x', y') of - (NVStr ns, NVSet _ apos) -> - maybe - (pure $ nvConstant NNull) - toValue - (M.lookup (stringIgnoreContext ns) apos) - (x, y) -> throwError $ ErrorCall $ "Invalid types for builtins.unsafeGetAttrPos: " <> show (x, y) - ) - y - ) - x + (\x' -> + (\y' -> case (x', y') of + (NVStr ns, NVSet _ apos) -> + maybe + (pure $ nvConstant NNull) + toValue + (M.lookup (stringIgnoreContext ns) apos) + (x, y) -> throwError $ ErrorCall $ "Invalid types for builtins.unsafeGetAttrPos: " <> show (x, y) + ) =<< demand y + ) =<< demand x -- This function is a bit special in that it doesn't care about the contents -- of the list. @@ -476,20 +472,16 @@ add_ -> NValue t f m -> m (NValue t f m) add_ x y = - demandF - (\x' -> - demandF - (\y' -> - case (x', y') of - (NVConstant (NInt x), NVConstant (NInt y)) -> toValue (x + y :: Integer) - (NVConstant (NFloat x), NVConstant (NInt y)) -> toValue (x + fromInteger y) - (NVConstant (NInt x), NVConstant (NFloat y)) -> toValue (fromInteger x + y) - (NVConstant (NFloat x), NVConstant (NFloat y)) -> toValue (x + y) - (_ , _ ) -> throwError $ Addition x' y' - ) - y - ) - x + (\x' -> + (\y' -> + case (x', y') of + (NVConstant (NInt x), NVConstant (NInt y)) -> toValue (x + y :: Integer) + (NVConstant (NFloat x), NVConstant (NInt y)) -> toValue (x + fromInteger y) + (NVConstant (NInt x), NVConstant (NFloat y)) -> toValue (fromInteger x + y) + (NVConstant (NFloat x), NVConstant (NFloat y)) -> toValue (x + y) + (_ , _ ) -> throwError $ Addition x' y' + ) =<< demand y + ) =<< demand x mul_ :: MonadNix e t f m @@ -497,20 +489,16 @@ mul_ -> NValue t f m -> m (NValue t f m) mul_ x y = - demandF - (\x' -> - demandF - (\y' -> - case (x', y') of - (NVConstant (NInt x), NVConstant (NInt y) ) -> toValue (x * y :: Integer) - (NVConstant (NFloat x), NVConstant (NInt y) ) -> toValue (x * fromInteger y) - (NVConstant (NInt x), NVConstant (NFloat y)) -> toValue (fromInteger x * y) - (NVConstant (NFloat x), NVConstant (NFloat y)) -> toValue (x * y) - (_, _) -> throwError $ Multiplication x' y' - ) - y - ) - x + (\x' -> + (\y' -> + case (x', y') of + (NVConstant (NInt x), NVConstant (NInt y) ) -> toValue (x * y :: Integer) + (NVConstant (NFloat x), NVConstant (NInt y) ) -> toValue (x * fromInteger y) + (NVConstant (NInt x), NVConstant (NFloat y)) -> toValue (fromInteger x * y) + (NVConstant (NFloat x), NVConstant (NFloat y)) -> toValue (x * y) + (_, _) -> throwError $ Multiplication x' y' + ) =<< demand y + ) =<< demand x div_ :: MonadNix e t f m @@ -518,20 +506,16 @@ div_ -> NValue t f m -> m (NValue t f m) div_ x y = - demandF - (\x' -> - demandF - (\y' -> - case (x', y') of - (NVConstant (NInt x), NVConstant (NInt y)) | y /= 0 -> toValue $ (floor (fromInteger x / fromInteger y :: Double) :: Integer) - (NVConstant (NFloat x), NVConstant (NInt y)) | y /= 0 -> toValue $ x / fromInteger y - (NVConstant (NInt x), NVConstant (NFloat y)) | y /= 0 -> toValue $ fromInteger x / y - (NVConstant (NFloat x), NVConstant (NFloat y)) | y /= 0 -> toValue $ x / y - (x' , y' ) -> throwError $ Division x' y' - ) - y - ) - x + (\x' -> + (\y' -> + case (x', y') of + (NVConstant (NInt x), NVConstant (NInt y)) | y /= 0 -> toValue $ (floor (fromInteger x / fromInteger y :: Double) :: Integer) + (NVConstant (NFloat x), NVConstant (NInt y)) | y /= 0 -> toValue $ x / fromInteger y + (NVConstant (NInt x), NVConstant (NFloat y)) | y /= 0 -> toValue $ fromInteger x / y + (NVConstant (NFloat x), NVConstant (NFloat y)) | y /= 0 -> toValue $ x / y + (x' , y' ) -> throwError $ Division x' y' + ) =<< demand y + ) =<< demand x anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool anyM _ [] = pure False @@ -895,7 +879,7 @@ catAttrs attrName xs = fmap (nvList . catMaybes) $ forM l $ - fmap (M.lookup n) . demandF fromValue + fmap (M.lookup n) . fromValue <=< demand baseNameOf :: MonadNix e t f m => NValue t f m -> m (NValue t f m) baseNameOf x = do @@ -950,12 +934,11 @@ builtinsBuiltin = throwError $ ErrorCall "HNix does not provide builtins.builtin dirOf :: MonadNix e t f m => NValue t f m -> m (NValue t f m) dirOf = - demandF - (\case - NVStr ns -> pure $ nvStr $ modifyNixContents (Text.pack . takeDirectory . Text.unpack) ns - NVPath path -> pure $ nvPath $ takeDirectory path - v -> throwError $ ErrorCall $ "dirOf: expected string or path, got " <> show v - ) + (\case + NVStr ns -> pure $ nvStr $ modifyNixContents (Text.pack . takeDirectory . Text.unpack) ns + NVPath path -> pure $ nvPath $ takeDirectory path + v -> throwError $ ErrorCall $ "dirOf: expected string or path, got " <> show v + ) <=< demand -- jww (2018-04-28): This should only be a string argument, and not coerced? unsafeDiscardStringContext @@ -969,7 +952,7 @@ seq_ => NValue t f m -> NValue t f m -> m (NValue t f m) -seq_ a b = demandF (const $ pure b) a +seq_ a b = const (pure b) =<< demand a -- | We evaluate 'a' only for its effects, so data cycles are ignored. deepSeq @@ -1057,15 +1040,11 @@ genericClosure = fromValue @(AttrSet (NValue t f m)) >=> \s -> (Nothing , Just _ ) -> throwError $ ErrorCall "builtins.genericClosure: Attribute 'startSet' required" (Just _ , Nothing ) -> throwError $ ErrorCall "builtins.genericClosure: Attribute 'operator' required" (Just startSet, Just operator) -> - demandF - (fromValue @[NValue t f m] >=> - (\ss -> - demandF - (\op -> toValue @[NValue t f m] =<< snd <$> go op S.empty ss) - operator - ) + (fromValue @[NValue t f m] >=> + (\ss -> + (\op -> toValue @[NValue t f m] =<< snd <$> go op S.empty ss) =<< demand operator ) - startSet + ) =<< demand startSet where go :: NValue t f m @@ -1074,30 +1053,26 @@ genericClosure = fromValue @(AttrSet (NValue t f m)) >=> \s -> -> m (Set (WValue t f m), [NValue t f m]) go _ ks [] = pure (ks, mempty) go op ks (t : ts) = - demandF - (\v -> - (do - s <- fromValue @(AttrSet (NValue t f m)) v - k <- attrsetGet "key" s - demandF - (\k' -> do - bool - (do - ys <- fromValue @[NValue t f m] =<< callFunc op v - checkComparable k' - (case S.toList ks of - [] -> k' - WValue j : _ -> j - ) - fmap (t :) <$> go op (S.insert (WValue k') ks) (ts <> ys) + (\v -> + (do + s <- fromValue @(AttrSet (NValue t f m)) v + k <- attrsetGet "key" s + (\k' -> do + bool + (do + ys <- fromValue @[NValue t f m] =<< callFunc op v + checkComparable k' + (case S.toList ks of + [] -> k' + WValue j : _ -> j ) - (go op ks ts) - (S.member (WValue k') ks) - ) - k - ) + fmap (t :) <$> go op (S.insert (WValue k') ks) (ts <> ys) + ) + (go op ks ts) + (S.member (WValue k') ks) + ) =<< demand k ) - t + ) =<< demand t -- | Takes: -- 1. List of strings to match. @@ -1221,16 +1196,14 @@ intersectAttrs set1 set2 = functionArgs :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) functionArgs fun = - demandF - (\case - NVClosure p _ -> - toValue @(AttrSet (NValue t f m)) $ nvConstant . NBool <$> - case p of - Param name -> M.singleton name False - ParamSet s _ _ -> isJust <$> M.fromList s - v -> throwError $ ErrorCall $ "builtins.functionArgs: expected function, got " <> show v - ) - fun + (\case + NVClosure p _ -> + toValue @(AttrSet (NValue t f m)) $ nvConstant . NBool <$> + case p of + Param name -> M.singleton name False + ParamSet s _ _ -> isJust <$> M.fromList s + v -> throwError $ ErrorCall $ "builtins.functionArgs: expected function, got " <> show v + ) =<< demand fun toFile :: MonadNix e t f m @@ -1251,13 +1224,12 @@ toPath = fromValue @Path >=> toValue @Path pathExists_ :: MonadNix e t f m => NValue t f m -> m (NValue t f m) pathExists_ = - demandF - ( - \case - NVPath p -> toValue =<< pathExists p - NVStr ns -> toValue =<< pathExists (Text.unpack $ stringIgnoreContext ns) - v -> throwError $ ErrorCall $ "builtins.pathExists: expected path, got " <> show v - ) + ( + \case + NVPath p -> toValue =<< pathExists p + NVStr ns -> toValue =<< pathExists (Text.unpack $ stringIgnoreContext ns) + v -> throwError $ ErrorCall $ "builtins.pathExists: expected path, got " <> show v + ) <=< demand hasKind :: forall a e t f m @@ -1295,19 +1267,17 @@ isNull = hasKind @() -- isString cannot use `hasKind` because it coerces derivations to strings. isString :: MonadNix e t f m => NValue t f m -> m (NValue t f m) isString = - demandF - (toValue . \case - NVStr{} -> True - _ -> False - ) + (toValue . \case + NVStr{} -> True + _ -> False + ) <=< demand isFunction :: MonadNix e t f m => NValue t f m -> m (NValue t f m) isFunction = - demandF - (toValue . \case - NVClosure{} -> True - _ -> False - ) + (toValue . \case + NVClosure{} -> True + _ -> False + ) <=< demand throw_ :: MonadNix e t f m => NValue t f m -> m (NValue t f m) throw_ mnv = do @@ -1337,13 +1307,13 @@ scopedImport asetArg pathArg = traceM "No known current directory" pure path ) - (demandF - (\ pp -> - do - (Path p') <- fromValue pp - traceM $ "Current file being evaluated is: " <> show p' - pure $ takeDirectory p' path - ) + ( + (\ pp -> + do + (Path p') <- fromValue pp + traceM $ "Current file being evaluated is: " <> show p' + pure $ takeDirectory p' path + ) <=< demand ) mres @@ -1390,29 +1360,25 @@ lessThan -> NValue t f m -> m (NValue t f m) lessThan ta tb = - demandF - (\va -> - demandF - (\vb -> - do - let - badType = throwError $ ErrorCall $ "builtins.lessThan: expected two numbers or two strings, " <> "got " <> show va <> " and " <> show vb - - nvConstant . NBool <$> - case (va, vb) of - (NVConstant ca, NVConstant cb) -> - case (ca, cb) of - (NInt a, NInt b ) -> pure $ a < b - (NFloat a, NInt b ) -> pure $ a < fromInteger b - (NInt a, NFloat b) -> pure $ fromInteger a < b - (NFloat a, NFloat b) -> pure $ a < b - _ -> badType - (NVStr a, NVStr b) -> pure $ stringIgnoreContext a < stringIgnoreContext b - _ -> badType - ) - tb - ) - ta + (\va -> + (\vb -> + do + let + badType = throwError $ ErrorCall $ "builtins.lessThan: expected two numbers or two strings, " <> "got " <> show va <> " and " <> show vb + + nvConstant . NBool <$> + case (va, vb) of + (NVConstant ca, NVConstant cb) -> + case (ca, cb) of + (NInt a, NInt b ) -> pure $ a < b + (NFloat a, NInt b ) -> pure $ a < fromInteger b + (NInt a, NFloat b) -> pure $ fromInteger a < b + (NFloat a, NFloat b) -> pure $ a < b + _ -> badType + (NVStr a, NVStr b) -> pure $ stringIgnoreContext a < stringIgnoreContext b + _ -> badType + ) =<< demand tb + ) =<< demand ta concatLists :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) @@ -1420,7 +1386,7 @@ concatLists = toValue . concat <=< mapM (pure <=< - demandF $ fromValue @[NValue t f m] + (fromValue @[NValue t f m]) <=< demand ) <=< fromValue @[NValue t f m] @@ -1447,21 +1413,15 @@ listToAttrs lst = fmap ((`nvSet` M.empty) . M.fromList . reverse) (forM l $ - demandF - (\ nvattrset -> - do - a <- fromValue @(AttrSet (NValue t f m)) nvattrset - t <- attrsetGet "name" a - demandF - (\ nvstr -> - do - n <- fromValue nvstr - name <- fromStringNoContext n - val <- attrsetGet "value" a - pure (name, val) - ) - t - ) + (\ nvattrset -> + do + a <- fromValue @(AttrSet (NValue t f m)) nvattrset + n <- fromValue =<< demand =<< attrsetGet "name" a + name <- fromStringNoContext n + val <- attrsetGet "value" a + + pure (name, val) + ) <=< demand ) -- prim_hashString from nix/src/libexpr/primops.cc @@ -1531,7 +1491,7 @@ absolutePathFromValue = v -> throwError $ ErrorCall $ "expected a path, got " <> show v readFile_ :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -readFile_ = demandF (toValue <=< Nix.Render.readFile <=< absolutePathFromValue) +readFile_ = (toValue <=< Nix.Render.readFile <=< absolutePathFromValue) <=< demand findFile_ :: forall e t f m @@ -1540,21 +1500,17 @@ findFile_ -> NValue t f m -> m (NValue t f m) findFile_ aset filePath = - demandF - (\aset' -> - demandF - (\filePath' -> - case (aset', filePath') of - (NVList x, NVStr ns) -> do - mres <- findPath @t @f @m x (Text.unpack (stringIgnoreContext ns)) - pure $ nvPath mres - (NVList _, y) -> throwError $ ErrorCall $ "expected a string, got " <> show y - (x, NVStr _) -> throwError $ ErrorCall $ "expected a list, got " <> show x - (x, y) -> throwError $ ErrorCall $ "Invalid types for builtins.findFile: " <> show (x, y) - ) - filePath - ) - aset + (\aset' -> + (\filePath' -> + case (aset', filePath') of + (NVList x, NVStr ns) -> do + mres <- findPath @t @f @m x (Text.unpack (stringIgnoreContext ns)) + pure $ nvPath mres + (NVList _, y) -> throwError $ ErrorCall $ "expected a string, got " <> show y + (x, NVStr _) -> throwError $ ErrorCall $ "expected a list, got " <> show x + (x, y) -> throwError $ ErrorCall $ "Invalid types for builtins.findFile: " <> show (x, y) + ) =<< demand filePath + ) =<< demand aset data FileType = FileTypeRegular @@ -1573,32 +1529,30 @@ instance Convertible e t f m => ToValue FileType m (NValue t f m) where readDir_ :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) readDir_ = - demandF - (\path' -> do - path <- absolutePathFromValue path' - items <- listDirectory path - itemsWithTypes <- forM items $ \item -> do - s <- getSymbolicLinkStatus $ path item - let t = if - | isRegularFile s -> FileTypeRegular - | isDirectory s -> FileTypeDirectory - | isSymbolicLink s -> FileTypeSymlink - | otherwise -> FileTypeUnknown - pure (Text.pack item, t) - getDeeper <$> toValue (M.fromList itemsWithTypes)) + (\path' -> do + path <- absolutePathFromValue path' + items <- listDirectory path + itemsWithTypes <- forM items $ \item -> do + s <- getSymbolicLinkStatus $ path item + let t = if + | isRegularFile s -> FileTypeRegular + | isDirectory s -> FileTypeDirectory + | isSymbolicLink s -> FileTypeSymlink + | otherwise -> FileTypeUnknown + pure (Text.pack item, t) + getDeeper <$> toValue (M.fromList itemsWithTypes)) <=< demand fromJSON :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) fromJSON = - demandF - (\ j -> - do - encoded <- fromStringNoContext =<< fromValue j - either - (\ jsonError -> throwError $ ErrorCall $ "builtins.fromJSON: " <> jsonError) - jsonToNValue - (A.eitherDecodeStrict' @A.Value $ encodeUtf8 encoded) - ) + (\ j -> + do + encoded <- fromStringNoContext =<< fromValue j + either + (\ jsonError -> throwError $ ErrorCall $ "builtins.fromJSON: " <> jsonError) + jsonToNValue + (A.eitherDecodeStrict' @A.Value $ encodeUtf8 encoded) + ) <=< demand where jsonToNValue = \case A.Object m -> (`nvSet` M.empty) <$> traverse jsonToNValue m @@ -1615,13 +1569,13 @@ fromJSON = A.Null -> pure $ nvConstant NNull prim_toJSON :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -prim_toJSON = demandF (fmap nvStr . nvalueToJSONNixString) +prim_toJSON = (fmap nvStr . nvalueToJSONNixString) <=< demand toXML_ :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -toXML_ = demandF (fmap (nvStr . toXML) . normalForm) +toXML_ = (fmap (nvStr . toXML) . normalForm) <=< demand typeOf :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -typeOf = demandF +typeOf = (toValue . makeNixStringWithoutContext . \case NVConstant a -> case a of NURI _ -> "string" @@ -1636,11 +1590,11 @@ typeOf = demandF NVPath _ -> "path" NVBuiltin _ _ -> "lambda" _ -> error "Pattern synonyms obscure complete patterns" - ) + ) <=< demand tryEval :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -tryEval e = catch (demandF (pure . onSuccess) e) (pure . onError) +tryEval e = catch (onSuccess <$> demand e) (pure . onError) where onSuccess v = flip nvSet M.empty $ M.fromList [("success", nvConstant (NBool True)), ("value", v)] @@ -1684,12 +1638,11 @@ exec_ xs = do fetchurl :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) fetchurl = - demandF - (\case - NVSet s _ -> demandF (go (M.lookup "sha256" s)) =<< attrsetGet "url" s - v@NVStr{} -> go Nothing v - v -> throwError $ ErrorCall $ "builtins.fetchurl: Expected URI or set, got " <> show v - ) + (\case + NVSet s _ -> go (M.lookup "sha256" s) =<< demand =<< attrsetGet "url" s + v@NVStr{} -> go Nothing v + v -> throwError $ ErrorCall $ "builtins.fetchurl: Expected URI or set, got " <> show v + ) <=< demand where go :: Maybe (NValue t f m) -> NValue t f m -> m (NValue t f m) go _msha = @@ -1748,13 +1701,12 @@ getRecursiveSize = fmap (nvConstant . NInt . fromIntegral) . recursiveSize getContext :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) getContext = - demandF - (\case - (NVStr ns) -> do - let context = getNixLikeContext $ toNixLikeContext $ NixString.getContext ns - valued :: M.HashMap Text (NValue t f m) <- sequenceA $ M.map toValue context - pure $ nvSet valued M.empty - x -> throwError $ ErrorCall $ "Invalid type for builtins.getContext: " <> show x) + (\case + (NVStr ns) -> do + let context = getNixLikeContext $ toNixLikeContext $ NixString.getContext ns + valued :: M.HashMap Text (NValue t f m) <- sequenceA $ M.map toValue context + pure $ nvSet valued M.empty + x -> throwError $ ErrorCall $ "Invalid type for builtins.getContext: " <> show x) <=< demand appendContext :: forall e t f m @@ -1763,54 +1715,49 @@ appendContext -> NValue t f m -> m (NValue t f m) appendContext x y = - demandF - (\x' -> - demandF - (\y' -> - (case (x', y') of - (NVStr ns, NVSet attrs _) -> do - newContextValues <- forM attrs $ - demandF - (\case - NVSet attrs _ -> do - -- TODO: Fail for unexpected keys. - path <- - maybe - (pure False) - (demandF fromValue) - (M.lookup "path" attrs) - allOutputs <- - maybe - (pure False) - (demandF fromValue) - (M.lookup "allOutputs" attrs) - outputs <- - maybe - (pure mempty) - (demandF - (\case - NVList vs -> forM vs $ fmap stringIgnoreContext . fromValue - x -> throwError $ ErrorCall $ "Invalid types for context value outputs in builtins.appendContext: " <> show x - ) - ) - (M.lookup "outputs" attrs) - pure $ NixLikeContextValue path allOutputs outputs - x -> throwError $ ErrorCall $ "Invalid types for context value in builtins.appendContext: " <> show x + (\x' -> + (\y' -> + (case (x', y') of + (NVStr ns, NVSet attrs _) -> do + newContextValues <- forM attrs $ + (\case + NVSet attrs _ -> do + -- TODO: Fail for unexpected keys. + path <- + maybe + (pure False) + (fromValue <=< demand) + (M.lookup "path" attrs) + allOutputs <- + maybe + (pure False) + (fromValue <=< demand) + (M.lookup "allOutputs" attrs) + outputs <- + maybe + (pure mempty) + ( + (\case + NVList vs -> forM vs $ fmap stringIgnoreContext . fromValue + x -> throwError $ ErrorCall $ "Invalid types for context value outputs in builtins.appendContext: " <> show x + ) <=< demand ) - toValue - $ makeNixString (stringIgnoreContext ns) - $ fromNixLikeContext - $ NixLikeContext - $ M.unionWith (<>) newContextValues - $ getNixLikeContext - $ toNixLikeContext - $ NixString.getContext ns - (x, y) -> throwError $ ErrorCall $ "Invalid types for builtins.appendContext: " <> show (x, y) - ) - ) - y - ) - x + (M.lookup "outputs" attrs) + pure $ NixLikeContextValue path allOutputs outputs + x -> throwError $ ErrorCall $ "Invalid types for context value in builtins.appendContext: " <> show x + ) <=< demand + toValue + $ makeNixString (stringIgnoreContext ns) + $ fromNixLikeContext + $ NixLikeContext + $ M.unionWith (<>) newContextValues + $ getNixLikeContext + $ toNixLikeContext + $ NixString.getContext ns + (x, y) -> throwError $ ErrorCall $ "Invalid types for builtins.appendContext: " <> show (x, y) + ) + ) =<< demand y + ) =<< demand x newtype Prim m a = Prim { runPrim :: m a } diff --git a/src/Nix/Effects/Basic.hs b/src/Nix/Effects/Basic.hs index 228695e52..919b53aa6 100644 --- a/src/Nix/Effects/Basic.hs +++ b/src/Nix/Effects/Basic.hs @@ -53,11 +53,11 @@ defaultMakeAbsolutePath origPath = do mres <- lookupVar "__cur_file" maybe getCurrentDirectory - (demandF + ( (\case NVPath s -> pure $ takeDirectory s val -> throwError $ ErrorCall $ "when resolving relative path, __cur_file is in scope, but is not a path; it is: " <> show val - ) + ) <=< demand ) mres pure $ cwd origPathExpanded @@ -99,12 +99,12 @@ findEnvPathM name = do maybe (error "impossible") - (demandF + ( (\ nv -> do (l :: [NValue t f m]) <- fromValue nv findPathBy nixFilePath l name - ) + ) <=< demand ) mres @@ -142,38 +142,29 @@ findPathBy finder ls name = do go :: Maybe FilePath -> NValue t f m -> m (Maybe FilePath) go mp = maybe - (demandF - (\ nvhmt -> - do - (s :: HashMap Text (NValue t f m)) <- fromValue nvhmt - p <- resolvePath s - - demandF - (\ nvpath -> - do - (Path path) <- fromValue nvpath + (\ nv -> + do + (s :: HashMap Text (NValue t f m)) <- fromValue =<< demand nv + p <- resolvePath s + nvpath <- demand p + (Path path) <- fromValue nvpath - maybe - (tryPath path mempty) - (demandF - (\ nvmns -> - do - mns <- fromValueMay nvmns - tryPath path $ - case mns of - Just (nsPfx :: NixString) -> - let pfx = stringIgnoreContext nsPfx in - bool - mempty - (pure (Text.unpack pfx)) - (not $ Text.null pfx) - _ -> mempty - ) - ) - (M.lookup "prefix" s) - ) - p - ) + maybe + (tryPath path mempty) + (\ nv' -> + do + mns <- fromValueMay =<< demand nv' + tryPath path $ + case mns of + Just (nsPfx :: NixString) -> + let pfx = stringIgnoreContext nsPfx in + bool + mempty + (pure (Text.unpack pfx)) + (not $ Text.null pfx) + _ -> mempty + ) + (M.lookup "prefix" s) ) (const . pure . pure) mp @@ -195,14 +186,16 @@ findPathBy finder ls name = do fetchTarball :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -fetchTarball = demandF $ \case - NVSet s _ -> - maybe - (throwError $ ErrorCall "builtins.fetchTarball: Missing url attribute") - (demandF (go (M.lookup "sha256" s))) - (M.lookup "url" s) - v@NVStr{} -> go Nothing v - v -> throwError $ ErrorCall $ "builtins.fetchTarball: Expected URI or set, got " <> show v +fetchTarball = + \case + NVSet s _ -> + maybe + (throwError $ ErrorCall "builtins.fetchTarball: Missing url attribute") + (go (M.lookup "sha256" s) <=< demand) + (M.lookup "url" s) + v@NVStr{} -> go Nothing v + v -> throwError $ ErrorCall $ "builtins.fetchTarball: Expected URI or set, got " <> show v + <=< demand where go :: Maybe (NValue t f m) -> NValue t f m -> m (NValue t f m) go msha = \case @@ -225,7 +218,6 @@ fetchTarball = demandF $ \case fetch uri Nothing = nixInstantiateExpr $ "builtins.fetchTarball \"" <> Text.unpack uri <> "\"" fetch url (Just t) = - demandF (\nv -> do nsSha <- fromValue nv @@ -233,8 +225,7 @@ fetchTarball = demandF $ \case nixInstantiateExpr $ "builtins.fetchTarball { " <> "url = \"" <> Text.unpack url <> "\"; " <> "sha256 = \"" <> Text.unpack sha <> "\"; }" - ) - t + ) =<< demand t defaultFindPath :: MonadNix e t f m => [NValue t f m] -> FilePath -> m FilePath defaultFindPath = findPathM diff --git a/src/Nix/Effects/Derivation.hs b/src/Nix/Effects/Derivation.hs index da0c865f8..d062d68ec 100644 --- a/src/Nix/Effects/Derivation.hs +++ b/src/Nix/Effects/Derivation.hs @@ -351,7 +351,7 @@ buildDerivationWithContext drvAttrs = do -- common functions, lifted to WithStringContextT demandF' :: (NValue t f m -> WithStringContextT m a) -> NValue t f m -> WithStringContextT m a - demandF' f v = join $ lift $ demandF (pure . f) v + demandF' f v = join $ lift $ f <$> demand v fromValue' :: (FromValue a m (NValue' t f m (NValue t f m)), MonadNix e t f m) => NValue t f m -> WithStringContextT m a fromValue' = lift . fromValue diff --git a/src/Nix/Exec.hs b/src/Nix/Exec.hs index b2c374464..c7a68ca32 100644 --- a/src/Nix/Exec.hs +++ b/src/Nix/Exec.hs @@ -138,7 +138,6 @@ type MonadNix e t f m , MonadEffects t f m , MonadCitedThunks t f m , MonadValue (NValue t f m) m - , MonadValueF (NValue t f m) m ) data ExecFrame t f m = Assertion SrcSpan (NValue t f m) @@ -297,21 +296,19 @@ callFunc -> NValue t f m -> m (NValue t f m) callFunc fun arg = - demandF - (\fun' -> do - frames :: Frames <- asks (view hasLens) - when (length frames > 2000) $ throwError $ ErrorCall "Function call stack exhausted" - case fun' of - NVClosure _params f -> do - f arg - NVBuiltin name f -> do - span <- currentPos - withFrame Info (Calling @m @(NValue t f m) name span) (f arg) - s@(NVSet m _) | Just f <- M.lookup "__functor" m -> do - demandF ((`callFunc` s) >=> (`callFunc` arg)) f - x -> throwError $ ErrorCall $ "Attempt to call non-function: " <> show x - ) - fun + (\fun' -> do + frames :: Frames <- asks (view hasLens) + when (length frames > 2000) $ throwError $ ErrorCall "Function call stack exhausted" + case fun' of + NVClosure _params f -> do + f arg + NVBuiltin name f -> do + span <- currentPos + withFrame Info (Calling @m @(NValue t f m) name span) (f arg) + s@(NVSet m _) | Just f <- M.lookup "__functor" m -> do + ((`callFunc` arg) <=< (`callFunc` s)) =<< demand f + x -> throwError $ ErrorCall $ "Attempt to call non-function: " <> show x + ) =<< demand fun execUnaryOp :: (Framed e m, MonadCited t f m, Show t) @@ -350,24 +347,23 @@ execBinaryOp -> m (NValue t f m) -> m (NValue t f m) -- 2021-02-25: NOTE: These are do blocks. Currently in the middle of the big rewrite, can not check their refactor. Please help. -execBinaryOp scope span op lval rarg = case op of - NEq -> helperEq id - NNEq -> helperEq not - NOr -> - helperLogic flip True - NAnd -> - helperLogic id False - NImpl -> - helperLogic id True - _ -> rarg >>= - (\rval -> - demandF - (\rval' -> - demandF - (\lval' -> execBinaryOpForced scope span op lval' rval') - lval - ) - rval) +execBinaryOp scope span op lval rarg = + case op of + NEq -> helperEq id + NNEq -> helperEq not + NOr -> + helperLogic flip True + NAnd -> + helperLogic id False + NImpl -> + helperLogic id True + _ -> + do + rval <- rarg + rval' <- demand rval + lval' <- demand lval + + execBinaryOpForced scope span op lval' rval' where diff --git a/src/Nix/Json.hs b/src/Nix/Json.hs index 6394b8d26..00ab3ebb9 100644 --- a/src/Nix/Json.hs +++ b/src/Nix/Json.hs @@ -24,14 +24,15 @@ import Nix.Value.Monad nvalueToJSONNixString :: MonadNix e t f m => NValue t f m -> m NixString nvalueToJSONNixString = - runWithStringContextT - . fmap - ( TL.toStrict - . TL.decodeUtf8 - . A.encodingToLazyByteString - . toEncodingSorted - ) - . nvalueToJSON + runWithStringContextT . + fmap + ( TL.toStrict + . TL.decodeUtf8 + . A.encodingToLazyByteString + . toEncodingSorted + ) + + . nvalueToJSON nvalueToJSON :: MonadNix e t f m => NValue t f m -> WithStringContextT m A.Value nvalueToJSON = \case @@ -40,17 +41,18 @@ nvalueToJSON = \case NVConstant (NBool b) -> pure $ A.toJSON b NVConstant NNull -> pure A.Null NVStr ns -> A.toJSON <$> extractNixString ns - NVList l -> - A.Array - . V.fromList - <$> traverse (join . lift . demandF (pure . nvalueToJSON)) l + NVList l -> A.Array . V.fromList <$> traverse intoJson l NVSet m _ -> maybe - (A.Object <$> traverse (join . lift . demandF (pure . nvalueToJSON)) m) - (join . lift . demandF (pure . nvalueToJSON)) + (A.Object <$> traverse intoJson m) + intoJson (HM.lookup "outPath" m) - NVPath p -> do - fp <- lift $ unStorePath <$> addPath p - addSingletonStringContext $ StringContext (Text.pack fp) DirectPath - pure $ A.toJSON fp + NVPath p -> + do + fp <- lift $ unStorePath <$> addPath p + addSingletonStringContext $ StringContext (Text.pack fp) DirectPath + pure $ A.toJSON fp v -> lift $ throwError $ CoercionToJson v + + where + intoJson nv = join $ lift $ nvalueToJSON <$> demand nv diff --git a/src/Nix/Lint.hs b/src/Nix/Lint.hs index 05ee94801..b2e56ca00 100644 --- a/src/Nix/Lint.hs +++ b/src/Nix/Lint.hs @@ -115,7 +115,7 @@ unpackSymbolic :: (MonadVar m, MonadThunkId m, MonadCatch m) => Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m))) -unpackSymbolic = demandF $ readVar . getSV +unpackSymbolic = readVar . getSV <=< demand type MonadLint e m = ( Scoped (Symbolic m) m @@ -139,11 +139,11 @@ renderSymbolic = unpackSymbolic >=> \case TNull -> "null" TStr -> pure "string" TList r -> do - x <- demandF renderSymbolic r + x <- renderSymbolic =<< demand r pure $ "[" <> x <> "]" TSet Nothing -> pure "" TSet (Just s) -> do - x <- traverse (demandF renderSymbolic) s + x <- traverse (renderSymbolic <=< demand) s pure $ "{" <> show x <> "}" f@(TClosure p) -> do (args, sym) <- do @@ -177,29 +177,21 @@ merge context = go (TConstant ls, TConstant rs) -> (TConstant (ls `intersect` rs) :) <$> go xs ys (TList l, TList r) -> - demandF - (\l' -> - demandF - (\r' -> do - m <- defer $ unify context l' r' - (TList m :) <$> go xs ys - ) - r - ) - l + (\l' -> + (\r' -> do + m <- defer $ unify context l' r' + (TList m :) <$> go xs ys + ) =<< demand r + ) =<< demand l (TSet x , TSet Nothing ) -> (TSet x :) <$> go xs ys (TSet Nothing , TSet x ) -> (TSet x :) <$> go xs ys (TSet (Just l), TSet (Just r)) -> do m <- sequenceA $ M.intersectionWith (\i j -> i >>= \i' -> j >>= \j' -> - demandF (\i'' -> - demandF - (defer . unify context i'') - j' - ) - i' + (defer . unify context i'') =<< demand j' + ) =<< demand i' ) (pure <$> l) (pure <$> r) @@ -345,13 +337,11 @@ instance MonadLint e m => MonadEval (Symbolic m) m where evalWith scope body = do s <- defer scope pushWeakScope ?? body $ - demandF - (unpackSymbolic >=> \case - NMany [TSet (Just s')] -> pure s' - NMany [TSet Nothing] -> error "NYI: with unknown" - _ -> throwError $ ErrorCall "scope must be a set in with statement" - ) - s + (unpackSymbolic >=> \case + NMany [TSet (Just s')] -> pure s' + NMany [TSet Nothing] -> error "NYI: with unknown" + _ -> throwError $ ErrorCall "scope must be a set in with statement" + ) =<< demand s evalIf cond t f = do t' <- t diff --git a/src/Nix/Standard.hs b/src/Nix/Standard.hs index 1e1dd7a22..de1992061 100644 --- a/src/Nix/Standard.hs +++ b/src/Nix/Standard.hs @@ -273,7 +273,7 @@ instance -> m r demandF f v = free - ((demandF f) <=< force) + (f <=< demand <=< force) (const $ f v) v diff --git a/src/Nix/String/Coerce.hs b/src/Nix/String/Coerce.hs index cd4847b19..7eabc9805 100644 --- a/src/Nix/String/Coerce.hs +++ b/src/Nix/String/Coerce.hs @@ -43,7 +43,7 @@ coerceToString , MonadStore m , MonadThrow m , MonadDataErrorContext t f m - , MonadValueF (NValue t f m) m + , MonadValue (NValue t f m) m ) => (NValue t f m -> NValue t f m -> m (NValue t f m)) -> CopyToStoreMode @@ -53,35 +53,34 @@ coerceToString coerceToString call ctsm clevel = go where go x = - demandF - (\case - NVConstant (NBool b) - | - -- TODO Return a singleton for "" and "1" - b && clevel == CoerceAny -> pure - $ makeNixStringWithoutContext "1" - | clevel == CoerceAny -> pure $ makeNixStringWithoutContext "" - NVConstant (NInt n) | clevel == CoerceAny -> - pure $ makeNixStringWithoutContext $ Text.pack $ show n - NVConstant (NFloat n) | clevel == CoerceAny -> - pure $ makeNixStringWithoutContext $ Text.pack $ show n - NVConstant NNull | clevel == CoerceAny -> - pure $ makeNixStringWithoutContext "" - NVStr ns -> pure ns - NVPath p - | ctsm == CopyToStore -> storePathToNixString <$> addPath p - | otherwise -> pure $ makeNixStringWithoutContext $ Text.pack p - NVList l | clevel == CoerceAny -> - nixStringUnwords <$> traverse (demandF go) l + (\case + NVConstant (NBool b) + | + -- TODO Return a singleton for "" and "1" + b && clevel == CoerceAny -> pure + $ makeNixStringWithoutContext "1" + | clevel == CoerceAny -> pure $ makeNixStringWithoutContext "" + NVConstant (NInt n) | clevel == CoerceAny -> + pure $ makeNixStringWithoutContext $ Text.pack $ show n + NVConstant (NFloat n) | clevel == CoerceAny -> + pure $ makeNixStringWithoutContext $ Text.pack $ show n + NVConstant NNull | clevel == CoerceAny -> + pure $ makeNixStringWithoutContext "" + NVStr ns -> pure ns + NVPath p + | ctsm == CopyToStore -> storePathToNixString <$> addPath p + | otherwise -> pure $ makeNixStringWithoutContext $ Text.pack p + NVList l | clevel == CoerceAny -> + nixStringUnwords <$> traverse (go <=< demand) l - v@(NVSet s _) | Just p <- M.lookup "__toString" s -> - demandF ((`call` v) >=> go) p + v@(NVSet s _) | Just p <- M.lookup "__toString" s -> + (go <=< (`call` v)) =<< demand p - NVSet s _ | Just p <- M.lookup "outPath" s -> demandF go p + NVSet s _ | Just p <- M.lookup "outPath" s -> go =<< demand p + + v -> throwError $ ErrorCall $ "Expected a string, but saw: " <> show v + ) =<< demand x - v -> throwError $ ErrorCall $ "Expected a string, but saw: " <> show v - ) - x nixStringUnwords = intercalateNixString (makeNixStringWithoutContext " ") storePathToNixString :: StorePath -> NixString