add class MonadValueF

Author: Anton-Latukha

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 <> "'"
 

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