Form MonadValueF

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 _ _) ->
@@ -289,22 +294,21 @@ 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 <> "'"
 
-  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]
@@ -344,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

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

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

src/Nix/Value/Monad.hs

@@ -2,10 +2,19 @@
 
 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
   -- | If 'v' is a thunk, 'inform' allows us to modify the action to be
   --   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