Everything compiling again, but 25 tests failing

hnix.cabal

@@ -586,6 +586,7 @@ executable hnix
     , deepseq >=1.4.2 && <1.5
     , exceptions
     , filepath
+    , free
     , hashing
     , haskeline
     , hnix

main/Main.hs

@@ -14,6 +14,7 @@ import qualified Control.DeepSeq               as Deep
 import qualified Control.Exception             as Exc
 import           Control.Monad
 import           Control.Monad.Catch
+import           Control.Monad.Free
 import           Control.Monad.IO.Class
 -- import           Control.Monad.ST
 import qualified Data.Aeson.Text               as A
@@ -39,6 +40,7 @@ import qualified Nix.Type.Env                  as Env
 import qualified Nix.Type.Infer                as HM
 import           Nix.Utils
 import           Nix.Var
+import           Nix.Value.Monad
 import           Options.Applicative     hiding ( ParserResult(..) )
 import qualified Repl
 import           System.FilePath
@@ -132,7 +134,7 @@ main = do
    where
     printer
       | finder opts
-      = fromValue @(AttrSet (StandardThunk IO)) >=> findAttrs
+      = fromValue @(AttrSet (StandardValue IO)) >=> findAttrs
       | xml opts
       = liftIO
         .   putStrLn
@@ -152,14 +154,15 @@ main = do
       | otherwise
       = liftIO . print <=< prettyNValue
      where
+      findAttrs :: AttrSet (StandardValue IO) -> StandardT IO ()
       findAttrs = go ""
        where
         go prefix s = do
           xs <-
             forM (sortOn fst (M.toList s))
-              $ \(k, nv@(StdThunk (extract -> t))) -> case t of
-                  Value v       -> pure (k, Just v)
-                  Thunk _ _ ref -> do
+              $ \(k, nv) -> case nv of
+                  Free v       -> pure (k, Just (Free v))
+                  Pure (StdThunk (extract -> Thunk _ _ ref)) -> do
                     let path         = prefix ++ Text.unpack k
                         (_, descend) = filterEntry path k
                     val <- readVar @(StandardT IO) ref
@@ -197,7 +200,7 @@ main = do
             _                              -> (True, True)
 
           forceEntry k v =
-            catch (Just <$> force v pure) $ \(NixException frames) -> do
+            catch (Just <$> demand v pure) $ \(NixException frames) -> do
               liftIO
                 .   putStrLn
                 .   ("Exception forcing " ++)

main/Repl.hs

@@ -115,7 +115,7 @@ exec update source = do
   -- tyctx' <- hoistErr $ inferTop (tyctx st) expr
 
   -- TODO: track scope with (tmctx st)
-  mVal <- lift $ lift $ try $ pushScope @t M.empty (evalExprLoc expr)
+  mVal <- lift $ lift $ try $ pushScope M.empty (evalExprLoc expr)
 
   case mVal of
     Left (NixException frames) -> do
@@ -171,7 +171,8 @@ typeof args = do
   val <- case M.lookup line (tmctx st) of
     Just val -> return val
     Nothing  -> exec False line
-  liftIO $ putStrLn $ describeValue . valueType . extract . _nValue $ val
+  str <- lift $ lift $ showValueType val
+  liftIO $ putStrLn str
   where line = Text.pack (unwords args)
 
 -- :quit command

src/Nix.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE ViewPatterns #-}
 
 module Nix
@@ -51,6 +51,7 @@ import           Nix.Render.Frame
 import           Nix.Thunk
 import           Nix.Utils
 import           Nix.Value
+import           Nix.Value.Monad
 import           Nix.XML
 
 -- | This is the entry point for all evaluations, whatever the expression tree
@@ -82,7 +83,7 @@ nixEvalExprLoc
   -> m (NValue t f m)
 nixEvalExprLoc mpath = nixEval
   mpath
-  (Eval.addStackFrames @t . Eval.addSourcePositions)
+  (Eval.addStackFrames . Eval.addSourcePositions)
   (Eval.eval . annotated . getCompose)
 
 -- | Evaluate a nix expression with tracing in the default context. Note that
@@ -117,13 +118,12 @@ evaluateExpression mpath evaluator handler expr = do
 
   eval' = (normalForm =<<) . nixEvalExpr mpath
 
-  argmap args = pure $ nvSet (M.fromList args') mempty
-    where args' = map (fmap (wrapValue . nValueFromNF)) args
+  argmap args = nvSet (M.fromList args') mempty
+    where args' = map (fmap nValueFromNF) args
 
-  compute ev x args p = do
-    f :: NValue t f m <- ev mpath x
-    processResult p =<< case f of
-      NVClosure _ g -> force ?? pure =<< g args
+  compute ev x args p = ev mpath x >>= \f -> demand f $ \f' ->
+    processResult p =<< case f' of
+      NVClosure _ g -> g args
       _             -> pure f
 
 processResult
@@ -135,22 +135,22 @@ processResult
 processResult h val = do
   opts :: Options <- asks (view hasLens)
   case attr opts of
-    Nothing                         -> h val
+    Nothing                        -> h val
     Just (Text.splitOn "." -> keys) -> go keys val
  where
   go :: [Text.Text] -> NValue t f m -> m a
   go [] v = h v
-  go ((Text.decimal -> Right (n,"")) : ks) v = case v of
+  go ((Text.decimal -> Right (n,"")) : ks) v = demand v $ \case
     NVList xs -> case ks of
-      [] -> force @t @m @(NValue t f m) (xs !! n) h
-      _  -> force (xs !! n) (go ks)
+      [] -> h (xs !! n)
+      _  -> go ks (xs !! n)
     _ ->
       errorWithoutStackTrace
         $  "Expected a list for selector '"
         ++ show n
         ++ "', but got: "
         ++ show v
-  go (k : ks) v = case v of
+  go (k : ks) v = demand v $ \case
     NVSet xs _ -> case M.lookup k xs of
       Nothing ->
         errorWithoutStackTrace
@@ -158,8 +158,8 @@ processResult h val = do
           ++ Text.unpack k
           ++ "'"
       Just v' -> case ks of
-        [] -> force v' h
-        _  -> force v' (go ks)
+        [] -> h v'
+        _  -> go ks v'
     _ ->
       errorWithoutStackTrace
         $  "Expected a set for selector '"

src/Nix/Builtins.hs

@@ -174,7 +174,7 @@ builtinsList = sequence
   , add2 Normal   "catAttrs"         catAttrs
   , add2 Normal   "compareVersions"  compareVersions_
   , add  Normal   "concatLists"      concatLists
-  , add' Normal   "concatStringsSep" (arity2 principledIntercalateNixString)
+  -- , add' Normal   "concatStringsSep" (arity2 principledIntercalateNixString)
   , add0 Normal   "currentSystem"    currentSystem
   , add0 Normal   "currentTime"      currentTime_
   , add2 Normal   "deepSeq"          deepSeq

src/Nix/Thunk/Standard.hs

@@ -23,6 +23,7 @@ module Nix.Thunk.Standard where
 import           Control.Comonad                ( Comonad )
 import           Control.Comonad.Env            ( ComonadEnv )
 import           Control.Monad.Catch     hiding ( catchJust )
+import           Control.Monad.Free
 import           Control.Monad.Reader
 import           Control.Monad.Ref
 import           Data.Typeable
@@ -36,6 +37,7 @@ import           Nix.Options
 import           Nix.Thunk
 import           Nix.Thunk.Basic
 import           Nix.Value
+import           Nix.Value.Monad
 import           Nix.Var
 
 newtype StdThunk (u :: (* -> *) -> * -> *) (m :: * -> *) = StdThunk
@@ -82,6 +84,18 @@ instance ( MonadStdThunk (u m)
   -- wrapValue = StdThunk . StdCited . wrapValue
   -- getValue  = getValue . _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)
+
+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)
+
 instance HasCitations1 (StdLazy u m) (StdValue u m) (StdCited u m) where
   citations1 (StdCited c) = citations1 c
   addProvenance1 x (StdCited c) = StdCited (addProvenance1 x c)
@@ -107,7 +121,7 @@ runStandard opts action = do
 runStandardIO :: Options -> StdLazy StdIdT IO a -> IO a
 runStandardIO = runStandard
 
-whileForcingThunk
-  :: forall t f m s e r . (Exception s, Convertible e t f m) => s -> m r -> m r
-whileForcingThunk frame =
-  withFrame Debug (ForcingThunk @t @f @m) . withFrame Debug frame
+-- whileForcingThunk
+--   :: forall t f m s e r . (Exception s, Convertible e t f m) => s -> m r -> m r
+-- whileForcingThunk frame =
+--   withFrame Debug (ForcingThunk @t @f @m) . withFrame Debug frame

src/Nix/Value.hs

@@ -501,6 +501,12 @@ describeValue = \case
   TPath              -> "a path"
   TBuiltin           -> "a builtin function"
 
+showValueType :: (MonadThunk t m (NValue t f m), Comonad f)
+              => NValue t f m -> m String
+showValueType (Pure t) = force t showValueType
+showValueType (Free (NValue (extract -> v))) =
+  pure $ describeValue $ valueType $ v
+
 data ValueFrame t f m
     = ForcingThunk t
     | ConcerningValue (NValue t f m)