Add cycle detection

Fixes #131

Nix.hs

@@ -95,6 +95,10 @@ instance MonadVar (Lint s) where
     newVar x     = Lint $ ReaderT $ \_ -> newSTRef x
     readVar x    = Lint $ ReaderT $ \_ -> readSTRef x
     writeVar x y = Lint $ ReaderT $ \_ -> writeSTRef x y
+    atomicModifyVar x f = Lint $ ReaderT $ \_ -> do
+        res <- snd . f <$> readSTRef x
+        _ <- modifySTRef x (fst . f)
+        return res
 
 instance MonadFile (Lint s) where
     readFile x = Lint $ ReaderT $ \_ -> unsafeIOToST $ BS.readFile x

Nix/Builtins.hs

@@ -65,7 +65,7 @@ type MonadBuiltins e m =
 baseEnv :: MonadBuiltins e m => m (Scopes m (NThunk m))
 baseEnv = do
     ref <- thunk $ NVSet <$> builtins
-    pos <- repeatingThunk curPos -- re-evaluate each time it's reference
+    let pos = repeatingThunk curPos -- re-evaluate each time it's forced
     lst <- ([("builtins", ref), ("__curPos", pos)] ++)
         <$> topLevelBuiltins
     pushScope (M.fromList lst) currentScopes

Nix/Eval.hs

@@ -286,7 +286,8 @@ 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, Framed e m, MonadFile m, MonadVar m)
+        => NThunk m -> NThunk m -> m Bool
 thunkEq lt rt = do
     lv <- force lt
     rv <- force rt
@@ -307,7 +308,8 @@ 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, Framed e m, MonadFile m, MonadVar m)
+        => NValue m -> NValue m -> m Bool
 valueEq l r = case (l, r) of
     (NVStr ls _, NVConstant (NUri ru)) -> pure $ ls == ru
     (NVConstant (NUri lu), NVStr rs _) -> pure $ lu == rs

Nix/Lint.hs

@@ -78,7 +78,7 @@ newtype SThunk m = SThunk { getSThunk :: Thunk m (Symbolic m) }
 sthunk :: MonadVar m => m (Symbolic m) -> m (SThunk m)
 sthunk = fmap coerce . buildThunk
 
-sforce :: MonadVar m => SThunk m -> m (Symbolic m)
+sforce :: (Framed e m, MonadFile m, MonadVar m) => SThunk m -> m (Symbolic m)
 sforce = forceThunk . coerce
 
 svalueThunk :: forall m. Symbolic m -> SThunk m

Nix/Monad.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -18,6 +19,7 @@ import GHC.Generics
 import Nix.Atoms
 import Nix.Expr.Types
 import Nix.Scope
+import {-# SOURCE #-} Nix.Stack
 import Nix.Thunk
 import Nix.Utils
 import System.Posix.Files
@@ -27,10 +29,10 @@ newtype NThunk m = NThunk (Thunk m (NValue m))
 thunk :: MonadVar m => m (NValue m) -> m (NThunk m)
 thunk = fmap coerce . buildThunk
 
-repeatingThunk :: MonadVar m => m (NValue m) -> m (NThunk m)
-repeatingThunk = fmap coerce . buildRepeatingThunk
+repeatingThunk :: MonadVar m => m (NValue m) -> NThunk m
+repeatingThunk = coerce . buildRepeatingThunk
 
-force :: MonadVar m => NThunk m -> m (NValue m)
+force :: (Framed e m, MonadFile m, MonadVar m) => NThunk m -> m (NValue m)
 force = forceThunk . coerce
 
 valueThunk :: forall m. NValue m -> NThunk m
@@ -77,8 +79,8 @@ type NValue m   = NValueF m (NThunk m) -- head normal form
 type ValueSet m = HashMap Text (NThunk m)
 
 instance Show (NThunk m) where
-    show (NThunk (Left v)) = show v
-    show (NThunk (Right _)) = "<thunk>"
+    show (NThunk (Value v)) = show v
+    show (NThunk _) = "<thunk>"
 
 instance Show f => Show (NValueF m f) where
     showsPrec = flip go where

Nix/Monad/Instance.hs

@@ -90,9 +90,10 @@ instance (MonadFix m, MonadNix (Lazy m), MonadIO m)
 instance MonadIO m => MonadVar (Lazy m) where
     type Var (Lazy m) = IORef
 
-    newVar   = liftIO . newIORef
-    readVar  = liftIO . readIORef
+    newVar = liftIO . newIORef
+    readVar = liftIO . readIORef
     writeVar = (liftIO .) . writeIORef
+    atomicModifyVar = (liftIO .) . atomicModifyIORef
 
 instance MonadIO m => MonadFile (Lazy m) where
     readFile = liftIO . BS.readFile

Nix/Pretty.hs

@@ -13,6 +13,7 @@ import qualified Data.Text as Text
 import           Nix.Atoms
 import           Nix.Expr
 import           Nix.Monad
+import           Nix.Thunk
 import           Nix.Parser.Library (reservedNames)
 import           Nix.Parser.Operators
 import           Nix.StringOperations
@@ -212,8 +213,8 @@ printNix = cata phi
 removeEffects :: Functor m => NValue m -> NValueNF m
 removeEffects = Fix . fmap dethunk
   where
-    dethunk (NThunk (Left v)) = removeEffects v
-    dethunk (NThunk (Right _)) = Fix $ NVStr "<thunk>" mempty
+    dethunk (NThunk (Value v)) = removeEffects v
+    dethunk (NThunk _) = Fix $ NVStr "<thunk>" mempty
 
 showValue :: Functor m => NValue m -> String
 showValue = show . prettyNixValue . removeEffects

Nix/Stack.hs-boot

@@ -0,0 +1,27 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Nix.Stack where
+
+import Control.Monad.Reader
+import Data.ByteString (ByteString)
+import Nix.Expr.Types.Annotated
+import Nix.Utils
+import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))
+
+type Frames = [Either String (NExprLocF ())]
+
+type Framed e m = (MonadReader e m, Has e Frames)
+
+withExprContext :: Framed e m => NExprLocF () -> m r -> m r
+
+withStringContext :: Framed e m => String -> m r -> m r
+
+class Monad m => MonadFile m where
+    readFile :: FilePath -> m ByteString
+
+renderLocation :: MonadFile m => SrcSpan -> Doc -> m Doc
+
+renderFrame :: MonadFile m => Either String (NExprLocF ()) -> m String
+
+throwError :: (Framed e m, MonadFile m) => String -> m a

Nix/Thunk.hs

@@ -1,40 +1,48 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeFamilies #-}
 
 module Nix.Thunk where
 
+import {-# SOURCE #-} Nix.Stack
+
 data Deferred m v
-    = DeferredAction (m v)
-    | RepeatingAction (m v)
-    | ComputedValue v
+    = Deferred (m v)
+    | Computed v
 
 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 ()
+    atomicModifyVar :: Var m a -> (a -> (a, b)) -> m b
 
-type Thunk m v = Either v (Var m (Deferred m v))
+data Thunk m v
+    = Value v
+    | Action (m v)
+    | Thunk (Var m Bool) (Var m (Deferred m v))
 
 valueRef :: v -> Thunk m v
-valueRef  = Left
+valueRef = Value
+
+buildRepeatingThunk :: m v -> Thunk m v
+buildRepeatingThunk = Action
 
 buildThunk :: MonadVar m => m v -> m (Thunk m v)
-buildThunk action =
-    Right <$> newVar (DeferredAction action)
+buildThunk action = Thunk <$> newVar False <*> newVar (Deferred action)
 
-buildRepeatingThunk :: MonadVar m => m v -> m (Thunk m v)
-buildRepeatingThunk action =
-    Right <$> newVar (RepeatingAction action)
-
-forceThunk :: MonadVar m => Thunk m v -> m v
-forceThunk (Left ref) = pure ref
-forceThunk (Right ref) = do
+forceThunk :: (Framed e m, MonadFile m, MonadVar m) => Thunk m v -> m v
+forceThunk (Value ref) = pure ref
+forceThunk (Action ref) = ref
+forceThunk (Thunk avail ref) = do
     eres <- readVar ref
     case eres of
-        ComputedValue value -> return value
-        DeferredAction action -> do
-            value <- action
-            writeVar ref (ComputedValue value)
-            return value
-        RepeatingAction action -> action
+        Computed value -> return value
+        Deferred action -> do
+            active <- atomicModifyVar avail (True,)
+            if active
+                then throwError "Cycle detected"
+                else do
+                    value <- action
+                    writeVar ref (Computed value)
+                    return value

Nix/Utils.hs

@@ -12,7 +12,7 @@ import Data.Fix
 import Data.Functor.Identity
 import Data.Monoid (Endo)
 
--- #define ENABLE_TRACING 1
+#define ENABLE_TRACING 1
 #if ENABLE_TRACING
 import Debug.Trace as X
 #else