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.
haskell-nix · Mar 5, 2021 · 5933d46 · 5933d46
1 parent 7712fc4
commit 5933d46
Show file tree

Hide file tree

Showing 11 changed files with 434 additions and 509 deletions.
diff --git 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
@@ -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
 

diff --git 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