From 5d4af8819c0f59dffbc51b50567504e898db4b85 Mon Sep 17 00:00:00 2001
From: Anton-Latukha <anton.latukha@gmail.com>
Date: Thu, 4 Mar 2021 20:59:00 +0200
Subject: [PATCH 1/2] add class MonadValueF

---
 src/Nix/Lint.hs        |  9 +++++++++
 src/Nix/Standard.hs    | 35 ++++++++++++++++++++++++++++++++++-
 src/Nix/Type/Infer.hs  | 19 +++++++++++++++++++
 src/Nix/Value/Monad.hs |  9 +++++++++
 4 files changed, 71 insertions(+), 1 deletion(-)

diff --git a/src/Nix/Lint.hs b/src/Nix/Lint.hs
index c2028c2a3..054dc77bb 100644
--- a/src/Nix/Lint.hs
+++ b/src/Nix/Lint.hs
@@ -289,6 +289,15 @@ instance (MonadThunkId m, MonadAtomicRef m, MonadCatch m)
   demand f (ST v)= (demand f) =<< force v
   demand f (SV v)= f (SV v)
 
+
+instance (MonadThunkId m, MonadAtomicRef m, MonadCatch m)
+  => MonadValueF (Symbolic m) m where
+
+  demandF :: (Symbolic m -> m r) -> Symbolic m -> m r
+  demandF f (ST v)= (demandF f) =<< force v
+  demandF f (SV v)= f (SV v)
+
+
 instance MonadLint e m => MonadEval (Symbolic m) m where
   freeVariable var = symerr $ "Undefined variable '" <> Text.unpack var <> "'"
 
diff --git a/src/Nix/Standard.hs b/src/Nix/Standard.hs
index 86f75caa2..6c84a0857 100644
--- a/src/Nix/Standard.hs
+++ b/src/Nix/Standard.hs
@@ -219,7 +219,7 @@ instance
   furtherF k t = StdThunk . StdCited <$> furtherF k (_stdCited $ _stdThunk t)
 
 
--- * @instance MonadValue@
+-- * @instance MonadValue (StdValue m) m@
 
 instance ( MonadAtomicRef m
          , MonadCatch m
@@ -256,6 +256,39 @@ instance ( MonadAtomicRef m
   inform f (Free v) = Free <$> bindNValue' id (inform f) v
 
 
+-- * @instance MonadValueF (StdValue m) m@
+
+instance ( MonadAtomicRef m
+         , MonadCatch m
+         , Typeable m
+         , MonadReader (Context m (StdValue m)) m
+         , MonadThunkId m
+         )
+  => MonadValueF (StdValue m) m where
+
+  demandF
+    :: ( StdValue m
+      -> m r
+      )
+    -> StdValue m
+    -> m r
+  demandF f v =
+    free
+      ((demandF f) <=< force)
+      (const $ f v)
+      v
+
+  informF
+    :: ( m (StdValue m)
+      -> m (StdValue m)
+      )
+    -> StdValue m
+    -> m (StdValue m)
+  --  2021-02-27: NOTE: When swapping, switch to `further`.
+  informF f (Pure t) = Pure <$> furtherF f t
+  informF f (Free v) = Free <$> bindNValue' id (informF f) v
+
+
 {------------------------------------------------------------------------}
 
 -- jww (2019-03-22): NYI
diff --git a/src/Nix/Type/Infer.hs b/src/Nix/Type/Infer.hs
index 63bf21b97..634bd41be 100644
--- a/src/Nix/Type/Infer.hs
+++ b/src/Nix/Type/Infer.hs
@@ -421,6 +421,25 @@ instance Monad m => MonadValue (Judgment s) (InferT s m) where
     -> InferT s m (Judgment s)
   inform f j = f (pure j)
 
+
+--  2021-02-22: NOTE: Seems like suporflous instance
+instance Monad m => MonadValueF (Judgment s) (InferT s m) where
+
+  demandF
+    :: ( Judgment s
+      -> InferT s m r)
+    -> Judgment s
+    -> InferT s m r
+  demandF = ($)
+
+  informF
+    :: ( InferT s m (Judgment s)
+      -> InferT s m (Judgment s)
+      )
+    -> Judgment s
+    -> InferT s m (Judgment s)
+  informF f j = f (pure j)
+
 {-
 instance MonadInfer m
   => MonadThunk (JThunkT s m) (InferT s m) (Judgment s) where
diff --git a/src/Nix/Value/Monad.hs b/src/Nix/Value/Monad.hs
index f4cfed717..8efa25b2f 100644
--- a/src/Nix/Value/Monad.hs
+++ b/src/Nix/Value/Monad.hs
@@ -2,6 +2,8 @@
 
 module Nix.Value.Monad where
 
+-- * @MonadValue@ - a main implementation class
+
 class MonadValue v m where
   defer :: m v -> m v
   demand :: (v -> m r) -> v -> m r
@@ -9,3 +11,10 @@ class MonadValue v m where
   --   performed by the thunk, perhaps by enriching it with scope info, for
   --   example.
   inform :: (m v -> m v) -> v -> m v
+
+
+-- * @MonadValueF@ - a Kleisli-able customization class
+
+class MonadValueF v m where
+  demandF :: (v -> m r) -> v -> m r
+  informF :: (m v -> m v) -> v -> m v

From fc15ee61bc513c0dc5b214fdc69ee13eba067b34 Mon Sep 17 00:00:00 2001
From: Anton-Latukha <anton.latukha@gmail.com>
Date: Thu, 4 Mar 2021 20:59:39 +0200
Subject: [PATCH 2/2] Lint: m refactor

---
 src/Nix/Lint.hs | 24 ++++++++++--------------
 1 file changed, 10 insertions(+), 14 deletions(-)

diff --git a/src/Nix/Lint.hs b/src/Nix/Lint.hs
index 054dc77bb..1157852a4 100644
--- a/src/Nix/Lint.hs
+++ b/src/Nix/Lint.hs
@@ -203,7 +203,12 @@ merge context = go
         )
         (pure <$> l)
         (pure <$> r)
-      if M.null m then go xs ys else (TSet (pure m) :) <$> go xs ys
+      bool
+        id
+        ((TSet (pure m) :) <$>)
+        (not $ M.null m)
+        (go xs ys)
+
     (TClosure{}, TClosure{}) ->
       throwError $ ErrorCall "Cannot unify functions"
     (TBuiltin _ _, TBuiltin _ _) ->
@@ -301,19 +306,9 @@ instance (MonadThunkId m, MonadAtomicRef m, MonadCatch m)
 instance MonadLint e m => MonadEval (Symbolic m) m where
   freeVariable var = symerr $ "Undefined variable '" <> Text.unpack var <> "'"
 
-  attrMissing ks Nothing =
-    evalError @(Symbolic m)
-      $  ErrorCall
-      $  "Inheriting unknown attribute: "
-      <> intercalate "." (fmap Text.unpack (NE.toList ks))
+  attrMissing ks Nothing = evalError @(Symbolic m) $ ErrorCall $ "Inheriting unknown attribute: " <> intercalate "." (fmap Text.unpack (NE.toList ks))
 
-  attrMissing ks (Just s) =
-    evalError @(Symbolic m)
-      $  ErrorCall
-      $  "Could not look up attribute "
-      <> intercalate "." (fmap Text.unpack (NE.toList ks))
-      <> " in "
-      <> show s
+  attrMissing ks (Just s) = evalError @(Symbolic m) $ ErrorCall $ "Could not look up attribute " <> intercalate "." (fmap Text.unpack (NE.toList ks)) <> " in " <> show s
 
   evalCurPos = do
     f <- mkSymbolic [TPath]
@@ -353,7 +348,8 @@ instance MonadLint e m => MonadEval (Symbolic m) m where
         (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")
+          _ -> throwError $ ErrorCall "scope must be a set in with statement"
+        )
         s
 
   evalIf cond t f = do