Simplify the implementation of thunks by relying on Haskell's implementation

Relates to #75

Nix.hs

@@ -31,6 +31,7 @@ import           Nix.Scope
 import           Nix.Stack
 import           Nix.Thunk
 import           Nix.Utils
+import           System.IO.Unsafe
 
 -- | Evaluate a nix expression in the default context
 evalTopLevelExpr :: MonadBuiltins e m
@@ -39,7 +40,7 @@ evalTopLevelExpr expr = do
     base <- baseEnv
     normalForm =<< pushScopes base (Eval.evalExpr expr)
 
-eval :: (MonadFix m, MonadIO m)
+eval :: (MonadFix m, MonadIO m, MonadInterleave (Lazy m))
      => NExpr -> m (NValueNF (Lazy m))
 eval = runLazyM . evalTopLevelExpr
 
@@ -56,12 +57,13 @@ evalTopLevelExprLoc mpath expr = do
             pushScope (M.singleton "__cur_file" ref)
                       (framedEvalExpr Eval.eval expr)
 
-evalLoc :: (MonadFix m, MonadIO m)
+evalLoc :: (MonadFix m, MonadIO m, MonadInterleave (Lazy m))
         => Maybe FilePath -> NExprLoc -> m (NValueNF (Lazy m))
 evalLoc mpath = runLazyM . evalTopLevelExprLoc mpath
 
-tracingEvalLoc :: (MonadFix m, MonadIO m, Alternative m)
-               => Maybe FilePath -> NExprLoc -> m (NValueNF (Lazy m))
+tracingEvalLoc
+    :: (MonadFix m, MonadIO m, Alternative m, MonadInterleave (Lazy m))
+    => Maybe FilePath -> NExprLoc -> m (NValueNF (Lazy m))
 tracingEvalLoc mpath expr = do
     traced <- tracingEvalExpr Eval.eval expr
     case mpath of
@@ -89,6 +91,10 @@ instance MonadIO m => MonadVar (Lint m) where
 instance MonadIO m => MonadFile (Lint m) where
     readFile = liftIO . BS.readFile
 
+instance MonadInterleave (Lint IO) where
+    unsafeInterleave (Lint (ReaderT f)) = Lint $ ReaderT $ \e ->
+        liftIO $ unsafeInterleaveIO (f e)
+
 instance MonadIO m =>
       Eval.MonadExpr (SThunk (Lint m))
           (IORef (NSymbolicF (NTypeF (Lint m) (SThunk (Lint m)))))
@@ -112,6 +118,7 @@ runLintM = flip runReaderT (Context emptyScopes []) . runLint
 symbolicBaseEnv :: Monad m => m (Scopes m (SThunk m))
 symbolicBaseEnv = return []     -- jww (2018-04-02): TODO
 
-lint :: (MonadFix m, MonadIO m) => NExpr -> m (Symbolic (Lint m))
+lint :: (MonadFix m, MonadIO m, MonadInterleave (Lint m))
+     => NExpr -> m (Symbolic (Lint m))
 lint expr = runLintM $ symbolicBaseEnv
     >>= (`pushScopes` Lint.lintExpr expr)

Nix/Builtins.hs

@@ -44,12 +44,11 @@ import           Nix.Eval
 import           Nix.Monad
 import           Nix.Scope
 import           Nix.Stack
-import           Nix.Thunk
 import           System.FilePath
 import           System.Posix.Files
 
 type MonadBuiltins e m =
-    (MonadEval e m, MonadNix m, MonadFix m, MonadFile m, MonadVar m)
+    (MonadEval e m, MonadNix m, MonadFix m, MonadFile m)
 
 baseEnv :: MonadBuiltins e m => m (Scopes m (NThunk m))
 baseEnv = do

Nix/Eval.hs

@@ -48,7 +48,7 @@ type MonadEval e m =
     ( Scoped e (NThunk m) m
     , Framed e m
     , MonadExpr (NThunk m) (NValue m) m
-    , MonadVar m
+    , MonadInterleave m
     , MonadFile m
     )
 
@@ -277,7 +277,7 @@ valueRefInt = return . NVConstant . NInt
 valueRefFloat :: MonadNix m => Float -> m (NValue m)
 valueRefFloat = return . NVConstant . NFloat
 
-thunkEq :: (MonadNix m, MonadVar m) => NThunk m -> NThunk m -> m Bool
+thunkEq :: MonadNix m => NThunk m -> NThunk m -> m Bool
 thunkEq lt rt = do
     lv <- force lt
     rv <- force rt
@@ -298,7 +298,7 @@ alignEqM eq fa fb = fmap (either (const False) (const True)) $ runExceptT $ do
         _ -> throwE ()
     forM_ pairs $ \(a, b) -> guard =<< lift (eq a b)
 
-valueEq :: (MonadNix m, MonadVar m) => NValue m -> NValue m -> m Bool
+valueEq :: MonadNix m => NValue m -> NValue m -> m Bool
 valueEq l r = case (l, r) of
     (NVConstant lc, NVConstant rc) -> pure $ lc == rc
     (NVStr ls _, NVStr rs _) -> pure $ ls == rs
@@ -378,7 +378,7 @@ class (Monoid (MText m), Coercible (Thunk m v) t)
 
 buildArgument
     :: forall e t v m. (MonadExpr t v m, Scoped e t m, Framed e m,
-                  MonadVar m, MonadFix m, MonadFile m)
+                  MonadFix m, MonadFile m, MonadInterleave m)
     => Params (m t) -> t -> m (HashMap Text t)
 buildArgument params arg = case params of
     Param name -> return $ M.singleton name arg
@@ -418,8 +418,9 @@ buildArgument params arg = case params of
         These x _ -> const (pure x)
 
 attrSetAlter
-    :: forall e t v m. (MonadExpr t v m, Scoped e t m, Framed e m,
-                  MonadVar m, MonadFile m)
+    :: forall e t v m.
+        (MonadExpr t v m, Scoped e t m, Framed e m,
+         MonadFile m, MonadInterleave m)
     => [Text]
     -> HashMap Text (m v)
     -> m v
@@ -450,8 +451,9 @@ attrSetAlter (p:ps) m val = case M.lookup p m of
             =<< traverse (fmap coerce . buildThunk . withScopes scope) m'
 
 evalBinds
-    :: forall e t v m. (MonadExpr t v m, Scoped e t m, Framed e m,
-                  MonadVar m, MonadFix m, MonadFile m)
+    :: forall e t v m.
+        (MonadExpr t v m, Scoped e t m, Framed e m,
+         MonadFix m, MonadFile m, MonadInterleave m)
     => Bool
     -> Bool
     -> [Binding (m v)]

Nix/Lint.hs

@@ -9,6 +9,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module Nix.Lint where
 
@@ -74,15 +75,22 @@ data NSymbolicF r
 
 newtype SThunk m = SThunk { getSThunk :: Thunk m (Symbolic m) }
 
-sthunk :: MonadVar m => m (Symbolic m) -> m (SThunk m)
+sthunk :: (Functor m, MonadInterleave m) => m (Symbolic m) -> m (SThunk m)
 sthunk = fmap SThunk . buildThunk
 
-sforce :: MonadVar m => SThunk m -> m (Symbolic m)
+sforce :: Applicative m => SThunk m -> m (Symbolic m)
 sforce = forceThunk . getSThunk
 
-svalueThunk :: MonadVar m => Symbolic m -> m (SThunk m)
+svalueThunk :: Applicative m => Symbolic m -> m (SThunk m)
 svalueThunk = fmap SThunk . valueRef
 
+class Monad m => MonadVar m where
+    type Var m :: * -> *
+
+    newVar :: a -> m (Var m a)
+    readVar :: Var m a -> m a
+    writeVar :: Var m a -> a -> m ()
+
 type Symbolic m = Var m (NSymbolicF (NTypeF m (SThunk m)))
 
 everyPossible :: MonadVar m => m (Symbolic m)
@@ -188,6 +196,7 @@ type MonadLint e m =
     ( Scoped e (SThunk m) m
     , Framed e m
     , MonadExpr (SThunk m) (Symbolic m) m
+    , MonadInterleave m
     , MonadFix m
     , MonadFile m
     , MonadVar m

Nix/Monad.hs

@@ -23,13 +23,13 @@ import System.Posix.Files
 
 newtype NThunk m = NThunk (Thunk m (NValue m))
 
-thunk :: MonadVar m => m (NValue m) -> m (NThunk m)
+thunk :: (Functor m, MonadInterleave m) => m (NValue m) -> m (NThunk m)
 thunk = fmap coerce . buildThunk
 
-force :: MonadVar m => NThunk m -> m (NValue m)
+force :: Applicative m => NThunk m -> m (NValue m)
 force = forceThunk . coerce
 
-valueThunk :: MonadVar m => NValue m -> m (NThunk m)
+valueThunk :: Applicative m => NValue m -> m (NThunk m)
 valueThunk = fmap coerce . valueRef
 
 -- | An 'NValue' is the most reduced form of an 'NExpr' after evaluation

Nix/Monad/Instance.hs

@@ -10,6 +10,7 @@
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 {-# OPTIONS_GHC -Wno-missing-signatures #-}
 
@@ -23,7 +24,6 @@ import           Control.Monad.Trans.Reader
 import qualified Data.ByteString as BS
 import           Data.Fix
 import qualified Data.HashMap.Lazy as M
-import           Data.IORef
 import           Data.List
 import           Data.List.Split
 import           Data.Text (Text)
@@ -40,8 +40,9 @@ import           System.Directory
 import           System.Environment
 import           System.Exit (ExitCode (ExitSuccess))
 import           System.FilePath
-import           System.Process (readProcessWithExitCode)
+import           System.IO.Unsafe
 import           System.Posix.Files
+import           System.Process (readProcessWithExitCode)
 
 data Context m v = Context
     { scopes :: Scopes m v
@@ -69,7 +70,8 @@ removeDotDotIndirections = intercalate "/" . go [] . splitOn "/"
           go (_:s) ("..":rest) = go s rest
           go s (this:rest) = go (this:s) rest
 
-instance (MonadFix m, MonadNix (Lazy m), MonadIO m)
+instance (MonadFix m, MonadNix (Lazy m), MonadIO m,
+          MonadInterleave (Lazy m))
       => MonadExpr (NThunk (Lazy m)) (NValue (Lazy m)) (Lazy m) where
     embedSet    = return . NVSet
     projectSet  = \case
@@ -86,17 +88,15 @@ instance (MonadFix m, MonadNix (Lazy m), MonadIO m)
         NVConstant NNull -> return $ Just Nothing
         v -> fmap (Just . Just) . valueText True =<< normalForm v
 
-instance MonadIO m => MonadVar (Lazy m) where
-    type Var (Lazy m) = IORef
-
-    newVar   = liftIO . newIORef
-    readVar  = liftIO . readIORef
-    writeVar = (liftIO .) . writeIORef
+instance MonadInterleave (Lazy IO) where
+    unsafeInterleave (Lazy (ReaderT f)) = Lazy $ ReaderT $ \e ->
+        liftIO $ unsafeInterleaveIO (f e)
 
 instance MonadIO m => MonadFile (Lazy m) where
     readFile = liftIO . BS.readFile
 
-instance (MonadFix m, MonadIO m) => MonadNix (Lazy m) where
+instance (MonadFix m, MonadIO m, MonadInterleave (Lazy m))
+      => MonadNix (Lazy m) where
     addPath path = liftIO $ do
         (exitCode, out, _) <-
             readProcessWithExitCode "nix-store" ["--add", path] ""

Nix/Thunk.hs

@@ -2,35 +2,26 @@
 
 module Nix.Thunk where
 
-data Deferred m v
-    = DeferredAction (m v)
-    -- ^ This is closure over the environment where it was created.
-    | ComputedValue v
+-- | Rather than encoding laziness ourselves, using a datatype containing
+--   deferred actions or computed values in an IORef, we can leverage
+--   Haskell's own laziness by deferring actions until forced. For monads that
+--   are already non-strict in their binds, this type class is just the
+--   identity; but for monads like IO, we need support from the runtime such
+--   as 'unsafeInterleaveIO'. So what we're doing is making use of an already
+--   existing implementation of thunks, rather than duplicating it here.
+--
+--   See issue #75
 
-class Monad m => MonadVar m where
-    type Var m :: * -> *
+class MonadInterleave m where
+    unsafeInterleave :: m a -> m a
 
-    newVar :: a -> m (Var m a)
-    readVar :: Var m a -> m a
-    writeVar :: Var m a -> a -> m ()
+type Thunk (m :: * -> *) v = v
 
-newtype MonadVar m => Thunk m v =
-    Thunk { getThunk :: Either v (Var m (Deferred m v)) }
+valueRef :: Applicative m => v -> m (Thunk m v)
+valueRef = pure
 
-valueRef :: MonadVar m => v -> m (Thunk m v)
-valueRef  = pure . Thunk . Left
+buildThunk :: MonadInterleave m => m v -> m (Thunk m v)
+buildThunk = unsafeInterleave
 
-buildThunk :: MonadVar m => m v -> m (Thunk m v)
-buildThunk action =
-    Thunk . Right <$> newVar (DeferredAction action)
-
-forceThunk :: MonadVar m => Thunk m v -> m v
-forceThunk (Thunk (Left ref)) = pure ref
-forceThunk (Thunk (Right ref)) = do
-    eres <- readVar ref
-    case eres of
-        ComputedValue value -> return value
-        DeferredAction action -> do
-            value <- action
-            writeVar ref (ComputedValue value)
-            return value
+forceThunk :: Applicative m => Thunk m v -> m v
+forceThunk x = pure $! x

main/Main.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE QuasiQuotes #-}
+-- {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TupleSections #-}
 
 module Main where