Merge #862 Flipping demand

`demand` arguments got flipped into proper order. Result is - classical Haskell argument order. It is easier to read and work with. And `demand` got tail recursion and more specialization. Also the code becomes more straight-forward, but further work is needed to fold it after the unfold here.
haskell-nix · Feb 27, 2021 · 60a3a80 · 60a3a80
2 parents b0253e8 + de6327c
commit 60a3a80
Show file tree

Hide file tree

Showing 19 changed files with 846 additions and 636 deletions.
diff --git a/ChangeLog.md b/ChangeLog.md
@@ -17,6 +17,8 @@
       * `querryM`
       * `querryThunk`
 
+  * [(link)](https://github.com/haskell-nix/hnix/pull/862/files#diff-caa5d6592de00a0b23b2996143181d5cb60ebe00abcd0ba39b271caa764aa086) `Nix.Value.Monad`: `class MonadValue v m`: `demand` unflipped the arguments. All its implementations got more straigh-forward to use and `demand` now tail recurse.
+
   * [(link)](https://github.com/haskell-nix/hnix/pull/859/commits/8e043bcbda13ea4fd66d3eefd6da690bb3923edd) `Nix.Value.Equal`: `valueEqM`: freed from `RankNTypes: forall t f m .`.
 
   * [(link)](https://github.com/haskell-nix/hnix/pull/802/commits/529095deaf6bc6b102fe5a3ac7baccfbb8852e49#) `Nix.Strings`: all `hacky*` functions replaced with lawful implemetations, because of that all functions become lawful - dropped the `principled` suffix from functions:

diff --git a/main/Main.hs b/main/Main.hs
@@ -16,6 +16,7 @@ import           Control.Monad
 import           Control.Monad.Catch
 import           Control.Monad.Free
 import           Control.Monad.IO.Class
+import           Data.Bool                      ( bool )
 import qualified Data.HashMap.Lazy             as M
 import qualified Data.Map                      as Map
 import           Data.List                      ( sortOn )
@@ -48,44 +49,46 @@ main :: IO ()
 main = do
   time <- getCurrentTime
   opts <- execParser (nixOptionsInfo time)
-  runWithBasicEffectsIO opts $ case readFrom opts of
-    Just path -> do
-      let file = addExtension (dropExtension path) "nixc"
-      process opts (pure file) =<< liftIO (readCache path)
-    Nothing -> case expression opts of
-      Just s  -> handleResult opts mempty (parseNixTextLoc s)
-      Nothing -> case fromFile opts of
-        Just "-" -> mapM_ (processFile opts) . lines =<< liftIO getContents
-        Just path ->
-          mapM_ (processFile opts) . lines =<< liftIO (readFile path)
-        Nothing -> case filePaths opts of
-          [] -> withNixContext mempty Repl.main
-          ["-"] ->
-            handleResult opts mempty
-              .   parseNixTextLoc
-              =<< liftIO Text.getContents
-          paths -> mapM_ (processFile opts) paths
+  runWithBasicEffectsIO opts $
+    case readFrom opts of
+      Nothing -> case expression opts of
+        Nothing -> case fromFile opts of
+          Nothing -> case filePaths opts of
+            [] -> withNixContext mempty Repl.main
+            ["-"] ->
+              handleResult opts mempty
+                .   parseNixTextLoc
+                =<< liftIO Text.getContents
+            paths -> mapM_ (processFile opts) paths
+          Just "-" -> mapM_ (processFile opts) . lines =<< liftIO getContents
+          Just path ->
+            mapM_ (processFile opts) . lines =<< liftIO (readFile path)
+        Just s  -> handleResult opts mempty (parseNixTextLoc s)
+      Just path -> do
+        let file = addExtension (dropExtension path) "nixc"
+        process opts (pure file) =<< liftIO (readCache path)
  where
   processFile opts path = do
     eres <- parseNixFileLoc path
     handleResult opts (pure path) eres
 
   handleResult opts mpath = \case
     Failure err ->
-      (if ignoreErrors opts
-          then liftIO . hPutStrLn stderr
-          else errorWithoutStackTrace
-        )
-        $  "Parse failed: "
-        <> show err
+      bool
+        errorWithoutStackTrace
+        (liftIO . hPutStrLn stderr)
+        (ignoreErrors opts)
+        $ "Parse failed: " <> show err
 
     Success expr -> do
       when (check opts) $ do
         expr' <- liftIO (reduceExpr mpath expr)
-        case HM.inferTop Env.empty [("it", stripAnnotation expr')] of
-          Left  err -> errorWithoutStackTrace $ "Type error: " <> PS.ppShow err
-          Right ty  -> liftIO $ putStrLn $ "Type of expression: " <> PS.ppShow
-            (fromJust (Map.lookup "it" (Env.types ty)))
+        either
+          (\ err -> errorWithoutStackTrace $ "Type error: " <> PS.ppShow err)
+          (\ ty  -> liftIO $ putStrLn $ "Type of expression: " <> PS.ppShow
+            (fromJust $ Map.lookup "it" $ Env.types ty)
+          )
+          (HM.inferTop Env.empty [("it", stripAnnotation expr')])
 
           -- liftIO $ putStrLn $ runST $
           --     runLintM opts . renderSymbolic =<< lint opts expr
@@ -99,11 +102,14 @@ main = do
                   frames
 
       when (repl opts) $
-        if evaluate opts
-          then do
-            val <- Nix.nixEvalExprLoc mpath expr
-            withNixContext mempty (Repl.main' $ pure val)
-          else withNixContext mempty Repl.main
+        withNixContext mempty $
+          bool
+            Repl.main
+            (do
+              val <- Nix.nixEvalExprLoc mpath expr
+              Repl.main' $ pure val
+            )
+            (evaluate opts)
 
   process opts mpath expr
     | evaluate opts
@@ -161,30 +167,35 @@ main = do
       findAttrs
         :: AttrSet (StdValue (StandardT (StdIdT IO)))
         -> StandardT (StdIdT IO) ()
-      findAttrs = go ""
+      findAttrs = go mempty
        where
         go prefix s = do
-          xs <- forM (sortOn fst (M.toList s)) $ \(k, nv) -> case nv of
-            Free v -> pure (k, pure (Free v))
-            Pure (StdThunk (extract -> Thunk _ _ ref)) -> do
-              let path         = prefix <> Text.unpack k
-                  (_, descend) = filterEntry path k
-              val <- readVar @(StandardT (StdIdT IO)) ref
-              case val of
-                Computed _ -> pure (k, Nothing)
-                _ | descend   -> (k, ) <$> forceEntry path nv
-                  | otherwise -> pure (k, Nothing)
-
+          xs <- forM (sortOn fst (M.toList s)) $ \(k, nv) ->
+            free
+              (\ (StdThunk (extract -> Thunk _ _ ref)) -> do
+                let path         = prefix <> Text.unpack k
+                    (_, descend) = filterEntry path k
+                val <- readVar @(StandardT (StdIdT IO)) ref
+                case val of
+                  Computed _    -> pure (k, Nothing)
+                  _ | descend   -> (k,        ) <$> forceEntry path nv
+                    | otherwise -> pure (k, Nothing)
+              )
+              (\ v -> pure (k, pure (Free v)))
+              nv
           forM_ xs $ \(k, mv) -> do
             let path              = prefix <> Text.unpack k
                 (report, descend) = filterEntry path k
             when report $ do
               liftIO $ putStrLn path
-              when descend $ case mv of
-                Nothing -> pure ()
-                Just v  -> case v of
-                  NVSet s' _ -> go (path <> ".") s'
-                  _          -> pure ()
+              when descend $
+                maybe
+                  (pure ())
+                  (\case
+                    NVSet s' _ -> go (path <> ".") s'
+                    _          -> pure ()
+                  )
+                  mv
          where
           filterEntry path k = case (path, k) of
             ("stdenv", "stdenv"          ) -> (True, True)
@@ -204,7 +215,7 @@ main = do
             _                              -> (True, True)
 
           forceEntry k v =
-            catch (pure <$> demand v pure) $ \(NixException frames) -> do
+            catch (pure <$> demand pure v) $ \(NixException frames) -> do
               liftIO
                 .   putStrLn
                 .   ("Exception forcing " <>)
@@ -230,6 +241,7 @@ main = do
     liftIO $ do
       putStrLn $ "Wrote winnowed expression tree to " <> path
       writeFile path $ show $ prettyNix (stripAnnotation expr')
-    case eres of
-      Left  err -> throwM err
-      Right v   -> pure v
+    either
+      throwM
+      pure
+      eres
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                (demand)
+import           Nix.Value.Monad                ( demand )
 
 import qualified Data.List
 import qualified Data.Maybe
@@ -395,11 +395,10 @@ completeFunc reversedPrev word
               -- Stop on last subField (we care about the keys at this level)
               [_] -> pure $ keys m
               f:fs ->
-                case Data.HashMap.Lazy.lookup f m of
-                  Nothing -> pure mempty
-                  Just e ->
-                    demand e
-                      (\e' -> (fmap . fmap) (("." <> f) <>) $ algebraicComplete fs e')
+                maybe
+                  (pure mempty)
+                  (demand (\e' -> (fmap . fmap) (("." <> f) <>) $ algebraicComplete fs e'))
+                  (Data.HashMap.Lazy.lookup f m)
 
       in case val of
         NVSet xs _ -> withMap xs

diff --git a/src/Nix.hs b/src/Nix.hs
@@ -110,10 +110,14 @@ evaluateExpression mpath evaluator handler expr = do
   args <- traverse (traverse eval') $ fmap (second parseArg) (arg opts) <> fmap
     (second mkStr)
     (argstr opts)
-  evaluator mpath expr >>= \f -> demand f $ \f' ->
-    processResult handler =<< case f' of
-      NVClosure _ g -> g (argmap args)
-      _             -> pure f
+  evaluator mpath expr >>= \f ->
+    demand
+      (\f' ->
+        processResult handler =<< case f' of
+          NVClosure _ g -> g (argmap args)
+          _             -> pure f
+      )
+      f
  where
   parseArg s = case parseNixText s of
     Success x   -> x
@@ -137,29 +141,26 @@ processResult h val = do
  where
   go :: [Text.Text] -> NValue t f m -> m a
   go [] v = h v
-  go ((Text.decimal -> Right (n,"")) : ks) v = demand v $ \case
-    NVList xs -> case ks of
-      [] -> h (xs !! n)
-      _  -> go ks (xs !! n)
-    _ ->
-      errorWithoutStackTrace
-        $  "Expected a list for selector '"
-        <> show n
-        <> "', but got: "
-        <> show v
-  go (k : ks) v = demand v $ \case
-    NVSet xs _ -> case M.lookup k xs of
-      Nothing ->
-        errorWithoutStackTrace
-          $  "Set does not contain key '"
-          <> Text.unpack k
-          <> "'"
-      Just v' -> case ks of
-        [] -> h v'
-        _  -> go ks v'
-    _ ->
-      errorWithoutStackTrace
-        $  "Expected a set for selector '"
-        <> Text.unpack k
-        <> "', but got: "
-        <> show v
+  go ((Text.decimal -> Right (n,"")) : ks) v =
+    demand
+      (\case
+        NVList xs ->
+          case ks of
+            [] -> h (xs !! n)
+            _  -> go ks (xs !! n)
+        _ -> errorWithoutStackTrace $ "Expected a list for selector '" <> show n <> "', but got: " <> show v
+      )
+      v
+  go (k : ks) v =
+    demand
+      (\case
+        NVSet xs _ ->
+          maybe
+            (errorWithoutStackTrace $ "Set does not contain key '" <> Text.unpack k <> "'")
+            (case ks of
+              [] -> h
+              _  -> go ks)
+          (M.lookup k xs)
+        _ -> errorWithoutStackTrace $ "Expected a set for selector '" <> Text.unpack k <> "', but got: " <> show v
+      )
+      v