Migrating code to new demand implementation

ChangeLog.md

@@ -43,13 +43,19 @@
  furtherF :: (m a -> m a) -> t -> m t
  ```
 
- * [(link)](https://github.com/haskell-nix/hnix/pull/862/files) [(link)](https://github.com/haskell-nix/hnix/pull/870/files) `Nix.Value.Monad`: `class MonadValue v m`: unflipped the arguments of methods into a classical order. As a result, `demand` now tail recurse.
+ * [(link)](https://github.com/haskell-nix/hnix/pull/862/files) [(link)](https://github.com/haskell-nix/hnix/pull/870/files) [(link)](https://github.com/haskell-nix/hnix/pull/871/files) [(link)](https://github.com/haskell-nix/hnix/pull/872/files) [(link)](https://github.com/haskell-nix/hnix/pull/873/files) `Nix.Value.Monad`: `class MonadValue v m`: instances became specialized, Kleisli versions unflipped the arguments of methods into a classical order and moved to the `class MonadValueF`. As a result, `demand` now gets optimized by GHC and also tail recurse. Please, use `f =<< demand t`, or just use `demandF`, while `demandF` in fact just `kleisli =<< demand t`.
 
  ```haskell
- demand :: (v -> m r) -> v -> m r
- -- was :: v -> (v -> m r) -> m r
- inform :: (m v -> m v) -> v -> m v
- -- was :: v -> (m v -> m v) -> m v
+ class MonadValue v m where
+
+ demand :: v -> m v
+ -- was :: v -> (v -> m r) -> m r
+
+ class MonadValueF v m where
+ demandF :: (v -> m r) -> v -> m r
+ -- was :: v -> (v -> m r) -> m r
+ informF :: (m v -> m v) -> v -> m v
+ -- was :: v -> (m v -> m v) -> m v
  ```
 
  * [(link)](https://github.com/haskell-nix/hnix/pull/863/files) `Nix.Normal`: `normalizeValue` removed first functional argument that was passing the function that did the thunk forcing. Now function provides the thunk forcing. Now to normalize simply use `normalizeValue v`.

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

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,69 +340,74 @@ 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
  -> String
  -> (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
 

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