treewide: switch to new demand WIP

Builtins left, it is 44 uses.

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

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,16 +218,14 @@ fetchTarball = demandF $ \case
  fetch uri Nothing =
  nixInstantiateExpr $ "builtins.fetchTarball \"" <> Text.unpack uri <> "\""
  fetch url (Just t) =
- demandF
  (\nv -> do
  nsSha <- fromValue nv
 
  let sha = stringIgnoreContext nsSha
 
  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

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

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
 

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