Add an 'inform' method to MonadValue

src/Nix/Eval.hs

@@ -41,11 +41,6 @@ import           Nix.Strings                    ( runAntiquoted )
 import           Nix.Utils
 import           Nix.Value.Monad
 
--- instance MonadThunk t m (NValue t f m) => MonadValue (NValue t f m) m where
---   defer = fmap Pure . thunk
---   demand (Pure t) f = force t f
---   demand v@(Free _) f = f v
-
 class (Show v, Monad m) => MonadEval v m where
   freeVariable    :: Text -> m v
   synHole         :: Text -> m v
@@ -119,8 +114,11 @@ eval :: forall v m . MonadNixEval v m => NExprF (m v) -> m v
 
 eval (NSym "__curPos") = evalCurPos
 
-eval (NSym var       ) = (lookupVar var :: m (Maybe v))
-  >>= maybe (freeVariable var) (demand ?? evaledSym var)
+eval (NSym var       ) = do
+  mres <- lookupVar var
+  case mres of
+    Just x  -> demand x $ evaledSym var
+    Nothing -> freeVariable var
 
 eval (NConstant    x      ) = evalConstant x
 eval (NStr         str    ) = evalString str
@@ -158,14 +156,14 @@ eval (NWith   scope  body) = evalWith scope body
 eval (NAssert cond   body) = cond >>= evalAssert ?? body
 
 eval (NAbs    params body) = do
-    -- It is the environment at the definition site, not the call site, that
-    -- needs to be used when evaluating the body and default arguments, hence
-    -- we defer here so the present scope is restored when the parameters and
-    -- body are forced during application.
+  -- It is the environment at the definition site, not the call site, that
+  -- needs to be used when evaluating the body and default arguments, hence we
+  -- defer here so the present scope is restored when the parameters and body
+  -- are forced during application.
   scope <- currentScopes :: m (Scopes m v)
   evalAbs params $ \arg k -> withScopes scope $ do
     args <- buildArgument params arg
-    pushScope args (k (M.map (`demand` pure) args) body)
+    pushScope args (k (fmap (inform ?? withScopes scope) args) body)
 
 eval (NSynHole name) = synHole name
 
@@ -173,17 +171,14 @@ eval (NSynHole name) = synHole name
 --   this implementation may be used as an implementation for 'evalWith'.
 evalWithAttrSet :: forall v m . MonadNixEval v m => m v -> m v -> m v
 evalWithAttrSet aset body = do
-    -- The scope is deliberately wrapped in a thunk here, since it is
-    -- evaluated each time a name is looked up within the weak scope, and
-    -- we want to be sure the action it evaluates is to force a thunk, so
-    -- its value is only computed once.
+  -- The scope is deliberately wrapped in a thunk here, since it is demanded
+  -- each time a name is looked up within the weak scope, and we want to be
+  -- sure the action it evaluates is to force a thunk, so its value is only
+  -- computed once.
   scope <- currentScopes :: m (Scopes m v)
-  s     <- defer @v @m $ withScopes scope aset
-  pushWeakScope
-    ?? body
-    $  demand s
-    $  fmap fst
-    .  fromValue @(AttrSet v, AttrSet SourcePos)
+  s     <- defer $ withScopes scope aset
+  let s' = demand s $ fmap fst . fromValue @(AttrSet v, AttrSet SourcePos)
+  pushWeakScope s' body
 
 attrSetAlter
   :: forall v m
@@ -264,7 +259,7 @@ evalBinds recursive binds = do
     finalValue >>= fromValue >>= \(o', p') ->
           -- jww (2018-05-09): What to do with the key position here?
                                               return $ map
-      (\(k, v) -> ([k], fromMaybe pos (M.lookup k p'), demand @v @m v pure))
+      (\(k, v) -> ([k], fromMaybe pos (M.lookup k p'), demand v pure))
       (M.toList o')
 
   go _ (NamedVar pathExpr finalValue pos) = do

src/Nix/Thunk.hs

@@ -40,7 +40,7 @@ class MonadThunkId m => MonadThunk t m a | t -> m, t -> a where
     forceEff :: t -> (a -> m r) -> m r
     -- | Modify the action to be performed by the thunk. For some implicits
     --   this modifies the thunk, for others it may create a new thunk.
-    -- further :: t -> (m a -> m a) -> m t
+    further :: t -> (m a -> m a) -> m t
 
 newtype ThunkLoop = ThunkLoop String -- contains rendering of ThunkId
     deriving Typeable

src/Nix/Thunk/Basic.hs

@@ -44,6 +44,7 @@ instance (MonadBasicThunk m, MonadCatch m)
   queryM   = queryThunk
   force    = forceThunk
   forceEff = forceEffects
+  further  = furtherThunk
 
 buildThunk :: MonadBasicThunk m => m v -> m (NThunkF m v)
 buildThunk action = do
@@ -100,3 +101,10 @@ forceEffects (Thunk _ active ref) k = do
           writeVar ref (Computed v)
           _ <- atomicModifyVar active (False, )
           k v
+
+furtherThunk :: MonadVar m => NThunkF m v -> (m v -> m v) -> m (NThunkF m v)
+furtherThunk t@(Thunk _ _ ref) k = do
+  _ <- atomicModifyVar ref $ \x -> case x of
+    Computed _ -> (x, x)
+    Deferred d -> (Deferred (k d), x)
+  return t

src/Nix/Thunk/Standard.hs

@@ -80,18 +80,20 @@ instance ( MonadStdThunk (u m)
   queryM x b f = queryM (_stdCited (_stdThunk x)) b f
   force    = force . _stdCited . _stdThunk
   forceEff = forceEff . _stdCited . _stdThunk
-  -- query x b f = query (_stdCited (_stdThunk x)) b f
-  -- wrapValue = StdThunk . StdCited . wrapValue
-  -- getValue  = getValue . _stdCited . _stdThunk
+  further  = (fmap (StdThunk . StdCited) .) . further . _stdCited . _stdThunk
 
 instance ( MonadAtomicRef (u m)
          , MonadThunk (StdThunk u m) (StdLazy u m) (StdValue u m)
          )
   => MonadValue (StdValue u m) (StdLazy u m) where
   defer = fmap Pure . thunk
+
   demand (Pure v) f = force v (flip demand f)
   demand (Free v) f = f (Free v)
 
+  inform (Pure t) f = Pure <$> further t f
+  inform (Free v) f = Free <$> bindNValue' id (flip inform f) v
+
 instance HasCitations (StdLazy u m) (StdValue u m) (StdThunk u m) where
   citations (StdThunk c) = citations1 c
   addProvenance x (StdThunk c) = StdThunk (addProvenance1 x c)

src/Nix/Type/Infer.hs

@@ -407,9 +407,10 @@ type MonadInfer m
   = ({- MonadThunkId m,-}
      MonadVar m, MonadFix m)
 
-instance MonadValue (Judgment s) (InferT s m) where
-  defer  = id
-  demand = flip ($)
+instance Monad m => MonadValue (Judgment s) (InferT s m) where
+  defer      = id
+  demand     = flip ($)
+  inform j f = f (pure j)
 
 {-
 instance MonadInfer m

src/Nix/Value/Monad.hs

@@ -6,7 +6,7 @@ module Nix.Value.Monad where
 class MonadValue v m where
   defer :: m v -> m v
   demand :: v -> (v -> m r) -> m r
-  -- | If 'v' is a thunk, 'train' allows us to modify the action to be
+  -- | If 'v' is a thunk, 'inform' allows us to modify the action to be
   --   peformed by the thunk, perhaps by enriching it with scpoe info, for
   --   example.
-  -- train :: v -> (m v -> m v) -> m v
+  inform :: v -> (m v -> m v) -> m v