Merge branch 'master' into vs-context-primops

.gitignore

@@ -1,5 +1,5 @@
-**/*~
 **/#*
+**/*~
 **/.#*
 /.history
 /Setup
@@ -7,6 +7,7 @@
 /nix-test-eval*
 /nix/
 TAGS
+cabal.project*
 ctags
 dist-newstyle
-result
+result

.travis.yml

@@ -15,8 +15,8 @@ env:
     - secure: "dm6I+M4+V+C7QMTpcSADdKPE633SvmToXZrTbZ7miNDGmMN+/SfHeN2ybi1+PW6oViMlbPN/7J/aEfiGjSJI8vLk72Y4uCWGmpSb8TXZLu6+whnxtZzzW8+z4tsM4048QJg7CF3N/25U8thRFgs3DqUub1Sf3nG9LrNWdz6ZcDQ="
 
   matrix:
-    - GHCVERSION=ghc844 STRICT=false TRACING=false
+    - GHCVERSION=ghc863 STRICT=false TRACING=false
-    - GHCVERSION=ghc844 STRICT=false TRACING=true
+    - GHCVERSION=ghc863 STRICT=false TRACING=true
 #     - GHCVERSION=ghcjs
 # 
 # matrix:

README.md

@@ -24,7 +24,7 @@ $ cabal test
 # To run all of the tests, which takes up to a minute:
 $ env ALL_TESTS=yes cabal test
 # To run only specific tests (see `tests/Main.hs` for a list)
-$ env NIXPKGS_TESTS=yes PRETTY_TESTS=yes cabal test
+$ env NIXPKGS_TESTS=yes PRETTY_TESTS=1 cabal test
 $ ./dist/build/hnix/hnix --help
 ```
 

default.nix

@@ -1,4 +1,4 @@
-{ compiler ? "ghc844"
+{ compiler ? "ghc863"
 
 , doBenchmark ? false
 , doTracing   ? false
@@ -6,8 +6,10 @@
 , doProfiling ? false # enables profiling support in GHC
 , doStrict    ? false
 
-, rev    ? "3f3f6021593070330091a4a2bc785f6761bbb3c1"
+, withHoogle  ? false
-, sha256 ? "1a7vvxxz8phff51vwsrdlsq5i70ig5hxvvb7lkm2lgwizgvpa6gv"
+
+, rev    ? "120eab94e0981758a1c928ff81229cd802053158"
+, sha256 ? "0qk6k8gxx5xlkyg05dljywj5wx5fvrc3dzp4v2h6ab83b7zwg813"
 
 , pkgs   ?
     if builtins.compareVersions builtins.nixVersion "2.0" < 0
@@ -17,37 +19,68 @@
            inherit sha256; }) {
            config.allowUnfree = true;
            config.allowBroken = false;
+           config.packageOverrides = pkgs: rec {
+             nix = pkgs.nixUnstable.overrideDerivation (attrs: {
+               src = data/nix;
+               configureFlags = attrs.configureFlags ++ [ "--disable-doc-gen" ];
+               buildInputs = attrs.buildInputs ++
+                 [ pkgs.editline.dev
+                 ];
+               outputs = builtins.filter (s: s != "doc" && s != "man" ) attrs.outputs;
+             });
+           };
          }
 
-, returnShellEnv ? pkgs.lib.inNixShell
 , mkDerivation   ? null
 }:
 
-let haskellPackages = pkgs.haskell.packages.${compiler};
+let
+
+  hnix-store-src = pkgs.fetchFromGitHub {
+    owner = "haskell-nix";
+    repo = "hnix-store";
+    rev = "0fe7ff5e8492ce6141d0eb400685516b4d07594b";
+    sha256 = "1izqp4ma6bkvdjcxhkasjcv1p11l72hdnm4dqmnnpkbmw70xrp36";
+  };
+
+  overlay = pkgs.lib.foldr pkgs.lib.composeExtensions (_: _: {}) [
+    (import "${hnix-store-src}/overlay.nix")
+    (self: super: with pkgs.haskell.lib; {
+      mono-traversable = dontCheck super.mono-traversable;
+      these = doJailbreak super.these;
+    } // pkgs.lib.optionalAttrs withHoogle {
+      ghc = super.ghc // { withPackages = super.ghc.withHoogle; };
+      ghcWithPackages = self.ghc.withPackages;
+    })
+  ];
+
+  overrideHaskellPackages = orig: {
+    buildHaskellPackages =
+      orig.buildHaskellPackages.override overrideHaskellPackages;
+    overrides = if orig ? overrides
+      then pkgs.lib.composeExtensions orig.overrides overlay
+      else overlay;
+  };
+
+  haskellPackages = pkgs.haskell.packages.${compiler}.override
+    overrideHaskellPackages;
 
 drv = haskellPackages.developPackage {
   name = "hnix";
   root = ./.;
 
-  overrides = with pkgs.haskell.lib; self: super: {
-    mono-traversable = dontCheck super.mono-traversable;
-    megaparsec = super.megaparsec_7_0_4;
-  };
-
-  source-overrides = {};
-
   modifier = drv: pkgs.haskell.lib.overrideCabal drv (attrs: {
     buildTools = (attrs.buildTools or []) ++ [
-      pkgs.haskell.packages.${compiler}.cabal-install
+      haskellPackages.cabal-install
     ];
 
     enableLibraryProfiling = doProfiling;
     enableExecutableProfiling = doProfiling;
 
-    testHaskellDepends = attrs.testHaskellDepends ++
+    testHaskellDepends = attrs.testHaskellDepends ++ [
-      [ pkgs.nix
+      pkgs.nix
-        pkgs.haskell.packages.ghc844.criterion
+      haskellPackages.criterion
-      ];
+    ];
 
     inherit doBenchmark;
 
@@ -58,10 +91,11 @@ drv = haskellPackages.developPackage {
 
     passthru = {
       nixpkgs = pkgs;
+      inherit haskellPackages;
     };
   });
 
-  inherit returnShellEnv;
+  returnShellEnv = false;
 };
 
 in drv

hnix.cabal

@@ -433,11 +433,6 @@ flag profiling
   manual: True
   default: False
 
-flag tracing
-  description: Enable full debug tracing
-  manual: True
-  default: False
-
 library
   exposed-modules:
       Nix
@@ -454,6 +449,7 @@ library
       Nix.Expr.Types
       Nix.Expr.Types.Annotated
       Nix.Frames
+      Nix.Fresh
       Nix.Json
       Nix.Lint
       Nix.Normal
@@ -496,6 +492,7 @@ library
     , filepath
     , free
     , hashing
+    , hnix-store-core
     , http-client
     , http-client-tls
     , http-types
@@ -527,8 +524,6 @@ library
     , xml
   if flag(optimize)
     ghc-options: -fexpose-all-unfoldings -fspecialise-aggressively -O2
-  if flag(tracing)
-    cpp-options: -DENABLE_TRACING=1
   if os(linux) && impl(ghc >= 8.2) && impl(ghc < 8.3)
     build-depends:
         compact
@@ -548,9 +543,9 @@ library
     build-depends:
         lens-family >=1.2.2
       , lens-family-core >=1.2.2
-  if impl(ghc < 8.4.0) && !flag(profiling)
+  -- if impl(ghc < 8.4.0) && !flag(profiling)
-    build-depends:
+  --   build-depends:
-        ghc-datasize
+  --       ghc-datasize
   if impl(ghcjs)
     build-depends:
         hashable >=1.2.4 && <1.3
@@ -595,8 +590,6 @@ executable hnix
     , unordered-containers >=0.2.9 && <0.3
   if flag(optimize)
     ghc-options: -fexpose-all-unfoldings -fspecialise-aggressively -O2
-  if flag(tracing)
-    cpp-options: -DENABLE_TRACING=1
   if os(linux) && impl(ghc >= 8.2) && impl(ghc < 8.3)
     build-depends:
         compact
@@ -666,8 +659,6 @@ test-suite hnix-tests
     , unordered-containers >=0.2.9 && <0.3
   if flag(optimize)
     ghc-options: -fexpose-all-unfoldings -fspecialise-aggressively -O2
-  if flag(tracing)
-    cpp-options: -DENABLE_TRACING=1
   if os(linux) && impl(ghc >= 8.2) && impl(ghc < 8.3)
     build-depends:
         compact
@@ -684,7 +675,6 @@ test-suite hnix-tests
   else
     buildable: True
   default-language: Haskell2010
-  build-tool-depends: hspec-discover:hspec-discover == 2.*
 
 benchmark hnix-benchmarks
   type: exitcode-stdio-1.0
@@ -715,8 +705,6 @@ benchmark hnix-benchmarks
     , unordered-containers >=0.2.9 && <0.3
   if flag(optimize)
     ghc-options: -fexpose-all-unfoldings -fspecialise-aggressively -O2
-  if flag(tracing)
-    cpp-options: -DENABLE_TRACING=1
   if os(linux) && impl(ghc >= 8.2) && impl(ghc < 8.3)
     build-depends:
         compact

shell.nix

@@ -0,0 +1 @@
+{} @ attrs: (import ./. attrs).env

src/Nix/Builtins.hs

@@ -89,8 +89,10 @@ import           Nix.Thunk
 import           Nix.Utils
 import           Nix.Value
 import           Nix.XML
+import           System.Nix.Internal.Hash (printHashBytes32)
 import           System.FilePath
 import           System.Posix.Files (isRegularFile, isDirectory, isSymbolicLink)
+import           Text.Read
 import           Text.Regex.TDFA
 
 -- | Evaluate a nix expression in the default context
@@ -459,7 +461,7 @@ splitVersion s = case Text.uncons s of
       | h `elem` versionComponentSeparators -> splitVersion t
       | isDigit h ->
           let (digits, rest) = Text.span isDigit s
-          in VersionComponent_Number (read $ Text.unpack digits) : splitVersion rest
+          in VersionComponent_Number (fromMaybe (error $ "splitVersion: couldn't parse " <> show digits) $ readMaybe $ Text.unpack digits) : splitVersion rest
       | otherwise ->
           let (chars, rest) = Text.span (\c -> not $ isDigit c || c `elem` versionComponentSeparators) s
               thisComponent = case chars of
@@ -950,7 +952,7 @@ placeHolder :: MonadNix e m => m (NValue m) -> m (NValue m)
 placeHolder = fromValue >=> fromStringNoContext >=> \t -> do
     h <- runPrim (hashString (principledMakeNixStringWithoutContext "sha256")
                              (principledMakeNixStringWithoutContext ("nix-output:" <> t)))
-    toNix $ principledMakeNixStringWithoutContext $ Text.cons '/' $ printHash32 $
+    toNix $ principledMakeNixStringWithoutContext $ Text.cons '/' $ printHashBytes32 $
       -- The result coming out of hashString is base16 encoded
       fst $ Base16.decode $ encodeUtf8 $ principledStringIgnoreContext h
 
@@ -1094,11 +1096,16 @@ fetchurl v = v >>= \case
  where
     go :: Maybe (NThunk m) -> NValue m -> m (NValue m)
     go _msha = \case
-        NVStr ns -> getURL (hackyStringIgnoreContext ns) >>= \case -- msha
+        NVStr ns -> noContextAttrs ns >>= getURL >>= \case -- msha
             Left e -> throwError e
             Right p -> toValue p
         v -> throwError $ ErrorCall $
-                 "builtins.fetchurl: Expected URI or string, got " ++ show v
+          "builtins.fetchurl: Expected URI or string, got " ++ show v
+  
+    noContextAttrs ns = case principledGetStringNoContext ns of
+      Nothing -> throwError $ ErrorCall $
+        "builtins.fetchurl: unsupported arguments to url"
+      Just t -> pure t
 
 partition_ :: forall e m. MonadNix e m
            => m (NValue m) -> m (NValue m) -> m (NValue m)
@@ -1115,7 +1122,7 @@ currentSystem :: MonadNix e m => m (NValue m)
 currentSystem = do
   os <- getCurrentSystemOS
   arch <- getCurrentSystemArch
-  return $ nvStr $ hackyMakeNixStringWithoutContext (arch <> "-" <> os)
+  return $ nvStr $ principledMakeNixStringWithoutContext (arch <> "-" <> os)
 
 currentTime_ :: MonadNix e m => m (NValue m)
 currentTime_ = do

src/Nix/Eval.hs

@@ -39,8 +39,9 @@ import           Nix.Strings (runAntiquoted)
 import           Nix.Thunk
 import           Nix.Utils
 
-class (Show v, Monad m) => MonadEval v m | v -> m where
+class (Show v, Monad m) => MonadEval v m where
     freeVariable    :: Text -> m v
+    synHole         :: Text -> m v
     attrMissing     :: NonEmpty Text -> Maybe v -> m v
     evaledSym       :: Text -> v -> m v
     evalCurPos      :: m v
@@ -91,10 +92,18 @@ data EvalFrame m v
     = EvaluatingExpr (Scopes m v) NExprLoc
     | ForcingExpr (Scopes m v) NExprLoc
     | Calling String SrcSpan
+    | SynHole (SynHoleInfo m v)
     deriving (Show, Typeable)
 
 instance (Typeable m, Typeable v) => Exception (EvalFrame m v)
 
+data SynHoleInfo m t = SynHoleInfo
+   { _synHoleInfo_expr :: NExprLoc
+   , _synHoleInfo_scope :: Scopes m t
+   } deriving (Show, Typeable)
+
+instance (Typeable m, Typeable t) => Exception (SynHoleInfo m t)
+
 eval :: forall v t m. MonadNixEval v t m => NExprF (m v) -> m v
 
 eval (NSym "__curPos") = evalCurPos
@@ -148,6 +157,8 @@ eval (NAbs params body) = do
         args <- buildArgument params arg
         pushScope args (k (M.map (`force` pure) args) body)
 
+eval (NSynHole name) = synHole name
+
 -- | If you know that the 'scope' action will result in an 'AttrSet t', then
 --   this implementation may be used as an implementation for 'evalWith'.
 evalWithAttrSet :: forall v t m. MonadNixEval v t m => m v -> m v -> m v
@@ -341,26 +352,25 @@ buildArgument params arg = do
                         Nothing -> id
                         Just n -> M.insert n $ const $
                             thunk (withScopes scope arg)
-                loebM (inject $ alignWithKey (assemble scope isVariadic)
+                loebM (inject $ M.mapMaybe id $ alignWithKey (assemble scope isVariadic)
                                              args (M.fromList s))
   where
     assemble :: Scopes m t
              -> Bool
              -> Text
              -> These t (Maybe (m v))
-             -> AttrSet t
+             -> Maybe (AttrSet t -> m t)
-             -> m t
     assemble scope isVariadic k = \case
-        That Nothing  ->
+        That Nothing  -> Just $
             const $ evalError @v $ ErrorCall $
                 "Missing value for parameter: " ++ show k
-        That (Just f) -> \args ->
+        That (Just f) -> Just $ \args ->
             thunk $ withScopes scope $ pushScope args f
-        This x | isVariadic -> const (pure x)
+        This _ | isVariadic -> Nothing
-               | otherwise  ->
+               | otherwise  -> Just $
                  const $ evalError @v $ ErrorCall $
                      "Unexpected parameter: " ++ show k
-        These x _ -> const (pure x)
+        These x _ -> Just (const (pure x))
 
 addSourcePositions :: (MonadReader e m, Has e SrcSpan)
                    => Transform NExprLocF (m a)

src/Nix/Exec.hs

@@ -57,6 +57,7 @@ import           Nix.Effects
 import           Nix.Eval as Eval
 import           Nix.Expr
 import           Nix.Frames
+import           Nix.Fresh
 import           Nix.String
 import           Nix.Normal
 import           Nix.Options
@@ -84,7 +85,7 @@ import           GHC.DataSize
 type MonadNix e m =
     (Scoped (NThunk m) m, Framed e m, Has e SrcSpan, Has e Options,
      Typeable m, MonadVar m, MonadEffects m, MonadFix m, MonadCatch m,
-     Alternative m)
+     Alternative m, MonadFreshId Int m)
 
 data ExecFrame m = Assertion SrcSpan (NValue m)
     deriving (Show, Typeable)
@@ -150,6 +151,14 @@ instance MonadNix e m => MonadEval (NValue m) m where
     freeVariable var =
         nverr $ ErrorCall $ "Undefined variable '" ++ Text.unpack var ++ "'"
 
+    synHole name = do
+        span <- currentPos
+        scope <- currentScopes
+        evalError @(NValue m) $ SynHole $ SynHoleInfo
+          { _synHoleInfo_expr = Fix $ NSynHole_ span name
+          , _synHoleInfo_scope = scope
+          }
+
     attrMissing ks Nothing =
         evalError @(NValue m) $ ErrorCall $
             "Inheriting unknown attribute: "
@@ -487,13 +496,13 @@ fromStringNoContext ns =
 
 newtype Lazy m a = Lazy
     { runLazy :: ReaderT (Context (Lazy m) (NThunk (Lazy m)))
-                        (StateT (HashMap FilePath NExprLoc) m) a }
+                        (StateT (HashMap FilePath NExprLoc) (FreshIdT Int m)) a }
     deriving (Functor, Applicative, Alternative, Monad, MonadPlus,
               MonadFix, MonadIO,
               MonadReader (Context (Lazy m) (NThunk (Lazy m))))
 
 instance MonadTrans Lazy where
-    lift = Lazy . lift . lift
+    lift = Lazy . lift . lift . lift
 
 instance MonadRef m => MonadRef (Lazy m) where
     type Ref (Lazy m) = Ref m
@@ -520,6 +529,9 @@ instance MonadException m => MonadException (Lazy m) where
       in runLazy <$> f run'
 #endif
 
+instance Monad m => MonadFreshId Int (Lazy m) where
+  freshId = Lazy $ lift $ lift freshId
+
 instance MonadStore m => MonadStore (Lazy m) where
     addPath' = lift . addPath'
     toFile_' n = lift . toFile_' n
@@ -591,19 +603,20 @@ instance (MonadFix m, MonadCatch m, MonadFile m, MonadStore m, MonadVar m,
         mapMaybeM op = foldr f (return [])
           where f x xs = op x >>= (<$> xs) . (++) . maybeToList
 
-        --handleEntry :: Bool -> (Text, NThunk (Lazy m)) -> Lazy m (Maybe (Text, NThunk (Lazy m)))
+        handleEntry :: Bool -> (Text, NThunk (Lazy m)) -> Lazy m (Maybe (Text, NThunk (Lazy m)))
         handleEntry ignoreNulls (k, v) = fmap (k,) <$> case k of
             -- The `args' attribute is special: it supplies the command-line
             -- arguments to the builder.
             -- TODO This use of coerceToString is probably not right and may
             -- not have the right arguments.
-            "args"          -> force v (\v2 -> Just <$> coerceNix v2)
+            "args"          -> force v $ fmap Just . coerceNixList
             "__ignoreNulls" -> pure Nothing
             _ -> force v $ \case
                 NVConstant NNull | ignoreNulls -> pure Nothing
                 v' -> Just <$> coerceNix v'
           where
             coerceNix = toNix <=< coerceToString CopyToStore CoerceAny
+            coerceNixList = toNix <=< traverse (\x -> force x coerceNix) <=< fromValue @[NThunk (Lazy m)]
 
     traceEffect = putStrLn
 
@@ -611,7 +624,8 @@ getRecursiveSize :: MonadIntrospect m => a -> m (NValue m)
 getRecursiveSize = toNix @Integer . fromIntegral <=< recursiveSize
 
 runLazyM :: Options -> MonadIO m => Lazy m a -> m a
-runLazyM opts = (`evalStateT` M.empty)
+runLazyM opts = runFreshIdT 0
+              . (`evalStateT` M.empty)
               . (`runReaderT` newContext opts)
               . runLazy
 
@@ -790,10 +804,44 @@ fetchTarball v = v >>= \case
               ++ "url    = \"" ++ Text.unpack url ++ "\"; "
               ++ "sha256 = \"" ++ Text.unpack sha ++ "\"; }"
 
-exec :: (MonadExec m, Framed e m, MonadThrow m, Alternative m, MonadCatch m, MonadFix m, MonadEffects m, GEq (Ref m), MonadAtomicRef m, Typeable m, Has e Options, Has e SrcSpan, Scoped (NThunk m) m) => [String] -> m (NValue m)
+exec
+  :: ( MonadExec m
+     , Framed e m
+     , MonadThrow m
+     , Alternative m
+     , MonadCatch m
+     , MonadFix m
+     , MonadEffects m
+     , MonadFreshId Int m
+     , GEq (Ref m)
+     , MonadAtomicRef m
+     , Typeable m
+     , Has e Options
+     , Has e SrcSpan
+     , Scoped (NThunk m) m
+     )
+  => [String]
+  -> m (NValue m)
 exec args = either throwError evalExprLoc =<< exec' args
 
-nixInstantiateExpr :: (MonadInstantiate m, Framed e m, MonadThrow m, Alternative m, MonadCatch m, MonadFix m, MonadEffects m, GEq (Ref m), MonadAtomicRef m, Typeable m, Has e Options, Has e SrcSpan, Scoped (NThunk m) m) => String -> m (NValue m)
+nixInstantiateExpr
+  :: ( MonadInstantiate m
+     , Framed e m
+     , MonadThrow m
+     , Alternative m
+     , MonadCatch m
+     , MonadFix m
+     , MonadEffects m
+     , MonadFreshId Int m
+     , GEq (Ref m)
+     , MonadAtomicRef m
+     , Typeable m
+     , Has e Options
+     , Has e SrcSpan
+     , Scoped (NThunk m) m
+     )
+  => String
+  -> m (NValue m)
 nixInstantiateExpr s = either throwError evalExprLoc =<< instantiateExpr s
 
 instance Monad m => Scoped (NThunk (Lazy m)) (Lazy m) where

src/Nix/Expr/Shorthands.hs

@@ -70,6 +70,12 @@ mkSym = Fix . mkSymF
 mkSymF :: Text -> NExprF a
 mkSymF = NSym
 
+mkSynHole :: Text -> NExpr
+mkSynHole = Fix . mkSynHoleF
+
+mkSynHoleF :: Text -> NExprF a
+mkSynHoleF = NSynHole
+
 mkSelector :: Text -> NAttrPath NExpr
 mkSelector = (:| []) . StaticKey
 

src/Nix/Expr/Types.hs

@@ -134,6 +134,8 @@ data NExprF r
   -- evaluate the second argument.
   | NAssert !r !r
   -- ^ Assert that the first returns true before evaluating the second.
+  | NSynHole !VarName
+  -- ^ Syntactic hole, e.g. @^foo@ , @^hole_name@
   deriving (Ord, Eq, Generic, Generic1, Typeable, Data, Functor,
             Foldable, Traversable, Show, NFData, Hashable)
 

src/Nix/Expr/Types/Annotated.hs

@@ -190,6 +190,9 @@ nullSpan = SrcSpan nullPos nullPos
 pattern NSym_ :: SrcSpan -> VarName -> NExprLocF r
 pattern NSym_ ann x = Compose (Ann ann (NSym x))
 
+pattern NSynHole_ :: SrcSpan -> Text -> NExprLocF r
+pattern NSynHole_ ann x = Compose (Ann ann (NSynHole x))
+
 pattern NConstant_ :: SrcSpan -> NAtom -> NExprLocF r
 pattern NConstant_ ann x = Compose (Ann ann (NConstant x))
 

src/Nix/Fresh.hs

@@ -0,0 +1,77 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Nix.Fresh where
+
+import Control.Applicative
+import Control.Monad.Catch
+import Control.Monad.Except
+import Control.Monad.Reader
+import Control.Monad.Ref
+import Control.Monad.ST
+import Control.Monad.State.Strict
+import Control.Monad.Writer
+#ifdef MIN_VERSION_haskeline
+import System.Console.Haskeline.MonadException hiding (catch)
+#endif
+
+-- TODO better fresh name supply
+class Monad m => MonadFreshId i m | m -> i where
+  freshId :: m i
+  default freshId :: (MonadFreshId i m', MonadTrans t, m ~ (t m')) => m i
+  freshId = lift freshId
+
+newtype FreshIdT i m a = FreshIdT { unFreshIdT :: StateT i m a }
+  deriving
+    ( Functor
+    , Applicative
+    , Alternative
+    , Monad
+    , MonadPlus
+    , MonadTrans
+    , MonadFix
+    , MonadRef
+    , MonadAtomicRef
+    , MonadIO
+    , MonadCatch
+    , MonadThrow
+#ifdef MIN_VERSION_haskeline
+    , MonadException
+#endif
+    )
+
+instance (Monad m, Num i) => MonadFreshId i (FreshIdT i m) where
+  freshId = FreshIdT $ get <* modify (+ 1)
+
+runFreshIdT :: Functor m => i -> FreshIdT i m a -> m a
+runFreshIdT i m = fst <$> runStateT (unFreshIdT m) i
+
+instance MonadFreshId i m => MonadFreshId i (ReaderT r m)
+instance (Monoid w, MonadFreshId i m) => MonadFreshId i (WriterT w m)
+instance MonadFreshId i m => MonadFreshId i (ExceptT e m)
+instance MonadFreshId i m => MonadFreshId i (StateT s m)
+
+-- Orphan instance needed by Infer.hs and Lint.hs
+
+-- Since there's no forking, it's automatically atomic.
+instance MonadAtomicRef (ST s) where
+  atomicModifyRef r f = do
+    v <- readRef r
+    let (a, b) = f v
+    writeRef r a
+    return b
+  atomicModifyRef' r f = do
+    v <- readRef r
+    let (a, b) = f v
+    writeRef r $! a
+    return b

src/Nix/Json.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE LambdaCase #-}
 
 module Nix.Json where
@@ -7,6 +8,7 @@ import           Control.Monad
 import           Control.Monad.Trans
 import qualified Data.Aeson as A
 import qualified Data.Aeson.Encoding as A
+import qualified Data.HashMap.Lazy as HM
 import qualified Data.Text as Text
 import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Lazy.Encoding as TL
@@ -34,8 +36,9 @@ nvalueToJSON = \case
   NVStr ns  -> A.toJSON <$> extractNixString ns
   NVList l  ->
     A.Array . V.fromList <$> traverse (join . lift . flip force (return . nvalueToJSON)) l
-  NVSet m _ ->
+  NVSet m _ -> case HM.lookup "outPath" m of
-    A.Object <$> traverse (join . lift . flip force (return . nvalueToJSON)) m
+    Nothing -> A.Object <$> traverse (join . lift . flip force (return . nvalueToJSON)) m
+    Just outPath -> join $ lift $ force outPath (return . nvalueToJSON)
   NVPath p  -> do
     fp <- lift $ unStorePath <$> addPath p
     addSingletonStringContext $ StringContext (Text.pack fp) DirectPath

src/Nix/Lint.hs

@@ -36,7 +36,6 @@ import           Data.HashMap.Lazy (HashMap)
 import qualified Data.HashMap.Lazy as M
 import           Data.List
 import qualified Data.List.NonEmpty as NE
-import           Data.STRef
 import           Data.Text (Text)
 import qualified Data.Text as Text
 import           Nix.Atoms
@@ -46,6 +45,7 @@ import           Nix.Eval (MonadEval(..))
 import qualified Nix.Eval as Eval
 import           Nix.Expr
 import           Nix.Frames
+import           Nix.Fresh
 import           Nix.String
 import           Nix.Options
 import           Nix.Scope
@@ -118,7 +118,7 @@ unpackSymbolic :: MonadVar m
 unpackSymbolic = readVar . coerce
 
 type MonadLint e m = (Scoped (SThunk m) m, Framed e m, MonadVar m,
-                      MonadCatch m)
+                      MonadCatch m, MonadFreshId Int m)
 
 symerr :: forall e m a. MonadLint e m => String -> m a
 symerr = evalError @(Symbolic m) . ErrorCall
@@ -389,21 +389,17 @@ lintApp context fun arg = unpackSymbolic fun >>= \case
         (head args,) <$> foldM (unify context) y ys
 
 newtype Lint s a = Lint
-    { runLint :: ReaderT (Context (Lint s) (SThunk (Lint s))) (ST s) a }
+  { runLint :: ReaderT (Context (Lint s) (SThunk (Lint s))) (FreshIdT Int (ST s)) a }
-    deriving (Functor, Applicative, Monad, MonadFix,
+  deriving
-              MonadReader (Context (Lint s) (SThunk (Lint s))))
+    ( Functor
-
+    , Applicative
-instance MonadRef (Lint s) where
+    , Monad
-    type Ref (Lint s) = Ref (ST s)
+    , MonadFix
-    newRef x     = Lint $ newRef x
+    , MonadReader (Context (Lint s) (SThunk (Lint s)))
-    readRef x    = Lint $ readRef x
+    , MonadFreshId Int
-    writeRef x y = Lint $ writeRef x y
+    , MonadRef
-
+    , MonadAtomicRef
-instance MonadAtomicRef (Lint s) where
+    )
-    atomicModifyRef x f = Lint $ ReaderT $ \_ -> do
-        res <- snd . f <$> readSTRef x
-        _ <- modifySTRef x (fst . f)
-        return res
 
 instance MonadThrow (Lint s) where
     throwM e = Lint $ ReaderT $ \_ -> throw e
@@ -412,7 +408,7 @@ instance MonadCatch (Lint s) where
     catch _m _h = Lint $ ReaderT $ \_ -> error "Cannot catch in 'Lint s'"
 
 runLintM :: Options -> Lint s a -> ST s a
-runLintM opts = flip runReaderT (newContext opts) . runLint
+runLintM opts = runFreshIdT 0 . flip runReaderT (newContext opts) . runLint
 
 symbolicBaseEnv :: Monad m => m (Scopes m (SThunk m))
 symbolicBaseEnv = return emptyScopes

src/Nix/Parser.hs

@@ -129,7 +129,8 @@ nixTerm = do
         x == '<' ||
         x == '/' ||
         x == '"' ||
-        x == '\''
+        x == '\''||
+        x == '^'
     case c of
         '('  -> nixSelect nixParens
         '{'  -> nixSelect nixSet
@@ -138,6 +139,7 @@ nixTerm = do
         '/'  -> nixPath
         '"'  -> nixString
         '\'' -> nixString
+        '^'  -> nixSynHole
         _    -> msum $
             [ nixSelect nixSet | c == 'r' ] ++
             [ nixPath | pathChar c ] ++
@@ -157,6 +159,9 @@ nixToplevelForm = keywords <+> nixLambda <+> nixExpr
 nixSym :: Parser NExprLoc
 nixSym = annotateLocation1 $ mkSymF <$> identifier
 
+nixSynHole :: Parser NExprLoc
+nixSynHole = annotateLocation1 $ mkSynHoleF <$> (char '^' >> identifier)
+
 nixInt :: Parser NExprLoc
 nixInt = annotateLocation1 (mkIntF <$> integer <?> "integer")
 

src/Nix/Pretty.hs

@@ -256,6 +256,7 @@ exprFNixDoc = \case
         [ "assert" <+> withoutParens cond <> semi
         , align $ withoutParens body
         ]
+    NSynHole name -> simpleExpr $ pretty ("^" <> unpack name)
   where
     recPrefix = "rec" <> space
 

src/Nix/Render.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module Nix.Render where
 
@@ -16,13 +17,16 @@ import           Control.Monad.Trans
 import           Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
 import qualified Data.Set as Set
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
 import           Data.Text.Prettyprint.Doc
 import           Data.Void
+import           Debug.Trace
 import           Nix.Expr.Types.Annotated
-import qualified System.Posix.Files as S
 import qualified System.Directory as S
+import qualified System.Posix.Files as S
 import           Text.Megaparsec.Error
-import           Text.Megaparsec.Pos (SourcePos(..))
+import           Text.Megaparsec.Pos
 
 class Monad m => MonadFile m where
     readFile :: FilePath -> m ByteString
@@ -69,6 +73,39 @@ posAndMsg (SourcePos _ lineNo _) msg =
     FancyError (unPos lineNo)
         (Set.fromList [ErrorFail (show msg) :: ErrorFancy Void])
 
-renderLocation :: Monad m => SrcSpan -> Doc a -> m (Doc a)
+renderLocation :: MonadFile m => SrcSpan -> Doc a -> m (Doc a)
-renderLocation (SrcSpan beg@(SourcePos _ _ _) _) msg =
+renderLocation (SrcSpan (SourcePos file begLine begCol)
-    return $ pretty $ init $ parseErrorPretty @String (posAndMsg beg msg)
+                        (SourcePos file' endLine endCol)) msg
+    | file /= "<string>" && file == file' = do
+    exist <- doesFileExist file
+    if exist
+        then do
+            txt <- sourceContext file begLine begCol endLine endCol msg
+            return $ vsep
+              [ "In file " <> errorContext file begLine begCol endLine endCol <> ":"
+              , txt
+              ]
+        else return msg
+renderLocation (SrcSpan beg end) msg =
+    fail $ "Don't know how to render range from " ++ show beg ++ " to " ++ show end
+      ++ " for error: " ++ show msg
+
+errorContext :: FilePath -> Pos -> Pos -> Pos -> Pos -> Doc a
+errorContext path bl bc _el _ec =
+    pretty path <> ":" <> pretty (unPos bl) <> ":" <> pretty (unPos bc)
+
+sourceContext :: MonadFile m => FilePath -> Pos -> Pos -> Pos -> Pos -> Doc a -> m (Doc a)
+sourceContext path (unPos -> begLine) (unPos -> begCol)
+                   (unPos -> endLine) (unPos -> endCol) msg = do
+    traceM $ "Taking lines from " ++ path
+    traceM $ "begLine = " ++ show begLine
+    traceM $ "begCol  = " ++ show begCol
+    traceM $ "endLine = " ++ show endLine
+    traceM $ "endCol  = " ++ show endCol
+    traceM $ "msg     = " ++ show msg
+    ls <- take (endLine - begLine)
+        . drop (pred begLine)
+        . T.lines
+        . T.decodeUtf8
+        <$> readFile path
+    pure $ vsep $ map pretty ls

src/Nix/Render/Frame.hs

@@ -75,12 +75,13 @@ renderFrame :: forall v e m ann.
                MonadFile m, Typeable m, Typeable v)
             => NixFrame -> m [Doc ann]
 renderFrame (NixFrame level f)
-    | Just (e :: EvalFrame m v) <- fromException f = renderEvalFrame level e
+    | Just (e :: EvalFrame m v)   <- fromException f = renderEvalFrame level e
-    | Just (e :: ThunkLoop)     <- fromException f = renderThunkLoop level e
+    | Just (e :: ThunkLoop)       <- fromException f = renderThunkLoop level e
-    | Just (e :: ValueFrame m)  <- fromException f = renderValueFrame level e
+    | Just (e :: ValueFrame m)    <- fromException f = renderValueFrame level e
-    | Just (e :: NormalLoop m)  <- fromException f = renderNormalLoop level e
+    | Just (e :: NormalLoop m)    <- fromException f = renderNormalLoop level e
-    | Just (e :: ExecFrame m)   <- fromException f = renderExecFrame level e
+    | Just (e :: ExecFrame m)     <- fromException f = renderExecFrame level e
-    | Just (e :: ErrorCall)     <- fromException f = pure [pretty (show e)]
+    | Just (e :: ErrorCall)       <- fromException f = pure [pretty (show e)]
+    | Just (e :: SynHoleInfo m v) <- fromException f = pure [pretty (show e)]
     | otherwise = error $ "Unrecognized frame: " ++ show f
 
 wrapExpr :: NExprF r -> NExpr
@@ -107,7 +108,15 @@ renderEvalFrame level f = do
             fmap (:[]) $ renderLocation ann $
                 "While calling builtins." <> pretty name
 
-        _ -> pure []
+        SynHole synfo -> sequence $
+            let e@(Fix (Compose (Ann ann _))) = _synHoleInfo_expr synfo
+             in [ renderLocation ann =<<
+                    renderExpr level "While evaluating" "Syntactic Hole" e
+                , pure $ pretty $ show (_synHoleInfo_scope synfo)
+                ]
+
+        ForcingExpr _ _ -> pure []
+
 
 renderExpr :: (MonadReader e m, Has e Options, MonadFile m)
            => NixLevel -> String -> String -> NExprLoc -> m (Doc ann)

src/Nix/TH.hs

@@ -61,6 +61,7 @@ freeVars e = case unFix e of
   -- This also makes sense because its value can be overridden by `x: with y; x`
   (NWith set expr) -> freeVars set `Set.union` freeVars expr
   (NAssert assertion expr) -> freeVars assertion `Set.union` freeVars expr
+  (NSynHole _) -> Set.empty
 
   where
 

src/Nix/Thunk.hs

@@ -1,20 +1,16 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DeriveTraversable #-}
-
-#if ENABLE_TRACING
-{-# LANGUAGE BangPatterns #-}
-#endif
-
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeFamilies #-}
+
+{-# OPTIONS_GHC -Wno-orphans #-}
 
 module Nix.Thunk where
 
@@ -29,23 +25,19 @@ import Data.Typeable
 
 import Unsafe.Coerce
 
-#if ENABLE_TRACING
+import Nix.Fresh
-import Data.IORef
-import System.IO.Unsafe
 import Nix.Utils
 
-counter :: IORef Int
-counter = unsafePerformIO $ newIORef 0
-{-# NOINLINE counter #-}
-#endif
-
 data Deferred m v = Deferred (m v) | Computed v
     deriving (Functor, Foldable, Traversable)
 
 type Var m = Ref m
 
 --TODO: Eliminate the old MonadVar shims
-type MonadVar m = (MonadAtomicRef m, GEq (Ref m))
+type MonadVar m =
+  ( MonadAtomicRef m
+  , GEq (Ref m)
+  )
 
 eqVar :: forall m a. GEq (Ref m) => Ref m a -> Ref m a -> Bool
 eqVar a b = isJust $ geq a b
@@ -73,7 +65,7 @@ instance GEq (STRef s) where
                 then Just $ unsafeCoerce Refl
                 else Nothing
 
-class Monad m => MonadThunk v t m | v -> m, v -> t, t -> m, t -> v where
+class Monad m => MonadThunk v t m | m -> t, t -> m, t -> v where
     thunk :: m v -> m t
     force :: t -> (v -> m r) -> m r
     value :: v -> t
@@ -90,24 +82,15 @@ instance Exception ThunkLoop
 valueRef :: v -> Thunk m v
 valueRef = Value
 
-buildThunk :: MonadVar m => m v -> m (Thunk m v)
+buildThunk :: (MonadVar m, MonadFreshId Int m) => m v -> m (Thunk m v)
-buildThunk action =
+buildThunk action =do
-#if ENABLE_TRACING
+    freshThunkId <- freshId
-    let !x = unsafePerformIO (atomicModifyIORef' counter (\c -> (succ c, c))) in
+    Thunk freshThunkId <$> newVar False <*> newVar (Deferred action)
-    Thunk x
-#else
-    Thunk 0
-#endif
-        <$> newVar False <*> newVar (Deferred action)
 
 forceThunk :: (MonadVar m, MonadThrow m, MonadCatch m)
            => Thunk m v -> (v -> m a) -> m a
 forceThunk (Value ref) k = k ref
-#if ENABLE_TRACING
 forceThunk (Thunk n active ref) k = do
-#else
-forceThunk (Thunk _ active ref) k = do
-#endif
     eres <- readVar ref
     case eres of
         Computed v -> k v
@@ -115,15 +98,9 @@ forceThunk (Thunk _ active ref) k = do
             nowActive <- atomicModifyVar active (True,)
             if nowActive
                 then
-#if ENABLE_TRACING
                     throwM $ ThunkLoop (Just n)
-#else
-                    throwM $ ThunkLoop Nothing
-#endif
                 else do
-#if ENABLE_TRACING
                     traceM $ "Forcing " ++ show n
-#endif
                     v <- catch action $ \(e :: SomeException) -> do
                         _ <- atomicModifyVar active (False,)
                         throwM e

src/Nix/Type/Infer.hs

@@ -32,7 +32,7 @@ import           Control.Monad.Logic
 import           Control.Monad.Reader
 import           Control.Monad.Ref
 import           Control.Monad.ST
-import           Control.Monad.State
+import           Control.Monad.State.Strict
 import           Data.Fix
 import           Data.Foldable
 import qualified Data.HashMap.Lazy as M
@@ -49,6 +49,7 @@ import           Nix.Eval (MonadEval(..))
 import qualified Nix.Eval as Eval
 import           Nix.Expr.Types
 import           Nix.Expr.Types.Annotated
+import           Nix.Fresh
 import           Nix.String
 import           Nix.Scope
 import           Nix.Thunk
@@ -63,14 +64,15 @@ import           Nix.Utils
 -------------------------------------------------------------------------------
 
 -- | Inference monad
-newtype Infer s a = Infer
+newtype InferT s m a = InferT
     { getInfer ::
-        ReaderT (Set.Set TVar, Scopes (Infer s) (JThunk s))
+        ReaderT (Set.Set TVar, Scopes (InferT s m) (JThunkT s m))
-            (StateT InferState (ExceptT InferError (ST s))) a
+            (StateT InferState (ExceptT InferError m)) a
     }
     deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadFix,
-              MonadReader (Set.Set TVar, Scopes (Infer s) (JThunk s)), MonadFail,
+              MonadReader (Set.Set TVar, Scopes (InferT s m) (JThunkT s m)), MonadFail,
-              MonadState InferState, MonadError InferError)
+              MonadState InferState, MonadError InferError,
+              MonadFreshId i)
 
 -- | Inference state
 newtype InferState = InferState { count :: Int }
@@ -186,16 +188,26 @@ instance Monoid InferError where
 -------------------------------------------------------------------------------
 
 -- | Run the inference monad
-runInfer' :: Infer s a -> ST s (Either InferError a)
+runInfer' ::
+  ( MonadFreshId Int m
+  , MonadAtomicRef m
+  , Ref m ~ STRef s
+  , MonadFix m
+  ) => InferT s m a -> m (Either InferError a)
 runInfer' = runExceptT
           . (`evalStateT` initInfer)
           . (`runReaderT` (Set.empty, emptyScopes))
           . getInfer
 
-runInfer :: (forall s. Infer s a) -> Either InferError a
+runInfer :: (forall s. InferT s (FreshIdT Int (ST s)) a) -> Either InferError a
-runInfer m = runST (runInfer' m)
+runInfer m = runST (runFreshIdT 0 (runInfer' m))
 
-inferType :: Env -> NExpr -> Infer s [(Subst, Type)]
+inferType ::
+  ( MonadFreshId Int m
+  , MonadAtomicRef m
+  , Ref m ~ STRef s
+  , MonadFix m
+  ) => Env -> NExpr -> InferT s m [(Subst, Type)]
 inferType env ex = do
   Judgment as cs t <- infer ex
   let unbounds = Set.fromList (As.keys as) `Set.difference`
@@ -224,17 +236,20 @@ inferExpr env ex = case runInfer (inferType env ex) of
 closeOver :: Type -> Scheme
 closeOver = normalize . generalize Set.empty
 
-extendMSet :: TVar -> Infer s a -> Infer s a
+extendMSet :: Monad m => TVar -> InferT s m a -> InferT s m a
-extendMSet x = Infer . local (first (Set.insert x)) . getInfer
+extendMSet x = InferT . local (first (Set.insert x)) . getInfer
 
 letters :: [String]
 letters = [1..] >>= flip replicateM ['a'..'z']
 
-fresh :: MonadState InferState m => m Type
+freshTVar :: MonadState InferState m => m TVar
-fresh = do
+freshTVar = do
     s <- get
     put s{count = count s + 1}
-    return $ TVar $ TV (letters !! count s)
+    return $ TV (letters !! count s)
+
+fresh :: MonadState InferState m => m Type
+fresh = TVar <$> freshTVar
 
 instantiate :: MonadState InferState m => Scheme -> m Type
 instantiate (Forall as t) = do
@@ -306,34 +321,37 @@ binops u1 = \case
                             , typeFun [typeFloat,  typeInt,    typeFloat]
                             ]) ]
 
-liftInfer :: ST s a -> Infer s a
+liftInfer :: Monad m => m a -> InferT s m a
-liftInfer = Infer . lift . lift . lift
+liftInfer = InferT . lift . lift . lift
 
-instance MonadRef (Infer s) where
+instance (MonadRef m, Ref m ~ STRef s) => MonadRef (InferT s m) where
-    type Ref (Infer s) = STRef s
+    type Ref (InferT s m) = Ref m
-    newRef x            = liftInfer $ newSTRef x
+    newRef x     = liftInfer $ newRef x
-    readRef x           = liftInfer $ readSTRef x
+    readRef x    = liftInfer $ readRef x
-    writeRef x y        = liftInfer $ writeSTRef x y
+    writeRef x y = liftInfer $ writeRef x y
 
-instance MonadAtomicRef (Infer s) where
+instance (MonadAtomicRef m, Ref m ~ STRef s) => MonadAtomicRef (InferT s m) where
     atomicModifyRef x f = liftInfer $ do
-        res <- snd . f <$> readSTRef x
+        res <- snd . f <$> readRef x
-        _ <- modifySTRef x (fst . f)
+        _ <- modifyRef x (fst . f)
         return res
 
-newtype JThunk s = JThunk (Thunk (Infer s) (Judgment s))
+newtype JThunkT s m = JThunk (Thunk (InferT s m) (Judgment s))
 
-instance MonadThrow (Infer s) where
+instance Monad m => MonadThrow (InferT s m) where
     throwM = throwError . EvaluationError
 
-instance MonadCatch (Infer s) where
+instance Monad m => MonadCatch (InferT s m) where
     catch m h = catchError m $ \case
         EvaluationError e ->
             maybe (error $ "Exception was not an exception: " ++ show e) h
                   (fromException (toException e))
         err -> error $ "Unexpected error: " ++ show err
 
-instance MonadThunk (Judgment s) (JThunk s) (Infer s) where
+instance ( MonadFreshId Int m
+         , MonadAtomicRef m
+         , Ref m ~ STRef s
+         ) => MonadThunk (Judgment s) (JThunkT s m) (InferT s m) where
     thunk = fmap JThunk . buildThunk
 
     force (JThunk t) f = catch (forceThunk t f) $ \(_ :: ThunkLoop) ->
@@ -342,11 +360,19 @@ instance MonadThunk (Judgment s) (JThunk s) (Infer s) where
 
     value = JThunk . valueRef
 
-instance MonadEval (Judgment s) (Infer s) where
+instance ( MonadFreshId Int m
+         , MonadAtomicRef m
+         , Ref m ~ STRef s
+         , MonadFix m
+         ) => MonadEval (Judgment s) (InferT s m) where
     freeVariable var = do
         tv <- fresh
         return $ Judgment (As.singleton var tv) [] tv
 
+    synHole var = do
+        tv <- fresh
+        return $ Judgment (As.singleton var tv) [] tv
+
     -- If we fail to look up an attribute, we just don't know the type.
     attrMissing _ _ = Judgment As.empty [] <$> fresh
 
@@ -408,7 +434,8 @@ instance MonadEval (Judgment s) (Infer s) where
             tv
 
     evalAbs (Param x) k = do
-        tv@(TVar a) <- fresh
+        a <- freshTVar
+        let tv = TVar a
         ((), Judgment as cs t) <-
             extendMSet a (k (pure (Judgment (As.singleton x tv) [] tv))
                             (\_ b -> ((),) <$> b))
@@ -450,11 +477,15 @@ data Judgment s = Judgment
     }
     deriving Show
 
-instance FromValue NixString (Infer s) (Judgment s) where
+instance Monad m => FromValue NixString (InferT s m) (Judgment s) where
     fromValueMay _ = return Nothing
     fromValue _ = error "Unused"
 
-instance FromValue (AttrSet (JThunk s), AttrSet SourcePos) (Infer s) (Judgment s) where
+instance ( MonadFreshId Int m
+         , MonadAtomicRef m
+         , Ref m ~ STRef s
+         , MonadFix m
+         ) => FromValue (AttrSet (JThunkT s m), AttrSet SourcePos) (InferT s m) (Judgment s) where
     fromValueMay (Judgment _ _ (TSet _ xs)) = do
         let sing _ = Judgment As.empty []
         pure $ Just (M.mapWithKey (\k v -> value (sing k v)) xs, M.empty)
@@ -463,7 +494,11 @@ instance FromValue (AttrSet (JThunk s), AttrSet SourcePos) (Infer s) (Judgment s
         Just v  -> pure v
         Nothing -> pure (M.empty, M.empty)
 
-instance ToValue (AttrSet (JThunk s), AttrSet SourcePos) (Infer s) (Judgment s) where
+instance ( MonadFreshId Int m
+         , MonadAtomicRef m
+         , Ref m ~ STRef s
+         , MonadFix m
+         ) => ToValue (AttrSet (JThunkT s m), AttrSet SourcePos) (InferT s m) (Judgment s) where
     toValue (xs, _) = Judgment
         <$> foldrM go As.empty xs
         <*> (concat <$> traverse (`force` (pure . typeConstraints)) xs)
@@ -471,7 +506,11 @@ instance ToValue (AttrSet (JThunk s), AttrSet SourcePos) (Infer s) (Judgment s)
       where
         go x rest = force x $ \x' -> pure $ As.merge (assumptions x') rest
 
-instance ToValue [JThunk s] (Infer s) (Judgment s) where
+instance ( MonadFreshId Int m
+         , MonadAtomicRef m
+         , Ref m ~ STRef s
+         , MonadFix m
+         ) => ToValue [JThunkT s m] (InferT s m) (Judgment s) where
     toValue xs = Judgment
         <$> foldrM go As.empty xs
         <*> (concat <$> traverse (`force` (pure . typeConstraints)) xs)
@@ -479,10 +518,18 @@ instance ToValue [JThunk s] (Infer s) (Judgment s) where
       where
         go x rest = force x $ \x' -> pure $ As.merge (assumptions x') rest
 
-instance ToValue Bool (Infer s) (Judgment s) where
+instance ( MonadFreshId Int m
+         , MonadAtomicRef m
+         , Ref m ~ STRef s
+         , MonadFix m
+         ) => ToValue Bool (InferT s m) (Judgment s) where
     toValue _ = pure $ Judgment As.empty [] typeBool
 
-infer :: NExpr -> Infer s (Judgment s)
+infer :: ( MonadFreshId Int m
+         , MonadAtomicRef m
+         , Ref m ~ STRef s
+         , MonadFix m
+         ) => NExpr -> InferT s m (Judgment s)
 infer = cata Eval.eval
 
 inferTop :: Env -> [(Text, NExpr)] -> Either InferError Env
@@ -618,8 +665,8 @@ solve cs = solve' (nextSolvable cs)
       s' <- lift $ instantiate s
       solve (EqConst t s' : cs)
 
-instance Scoped (JThunk s) (Infer s) where
+instance Monad m => Scoped (JThunkT s m) (InferT s m) where
   currentScopes = currentScopesReader
-  clearScopes = clearScopesReader @(Infer s) @(JThunk s)
+  clearScopes = clearScopesReader @(InferT s m) @(JThunkT s m)
   pushScopes = pushScopesReader
   lookupVar = lookupVarReader

src/Nix/Utils.hs

@@ -14,9 +14,6 @@ import           Control.Monad
 import           Control.Monad.Fix
 import qualified Data.Aeson as A
 import qualified Data.Aeson.Encoding as A
-import           Data.Bits
-import           Data.ByteString (ByteString)
-import qualified Data.ByteString as B
 import           Data.Fix
 import           Data.HashMap.Lazy (HashMap)
 import qualified Data.HashMap.Lazy as M
@@ -127,26 +124,3 @@ uriAwareSplit = go where
                 let ((suffix, _):path) = go (Text.drop 3 e2)
                  in (e1 <> Text.pack "://" <> suffix, PathEntryURI) : path
             | otherwise -> (e1, PathEntryPath) : go (Text.drop 1 e2)
-
-printHash32 :: ByteString -> Text
-printHash32 bs = go (base32Len bs - 1) ""
-  where
-   go n s
-     | n >= 0 = go (n-1) (Text.snoc s $ nextCharHash32 bs n)
-     | otherwise = s
-
-nextCharHash32 :: ByteString -> Int -> Char
-nextCharHash32 bs n = Text.index base32Chars (c .&. 0x1f)
-  where
-    b = n * 5
-    i = b `div` 8
-    j = b `mod` 8
-    c = fromIntegral $ shiftR (B.index bs i) j .|. mask
-    mask = if i >= B.length bs - 1
-             then 0
-             else shiftL (B.index bs (i+1)) (8 - j)
-    -- e, o, u, and t are omitted (see base32Chars in nix/src/libutil/hash.cc)
-    base32Chars = "0123456789abcdfghijklmnpqrsvwxyz"
-
-base32Len :: ByteString -> Int
-base32Len bs = ((B.length bs * 8 - 1) `div` 5) + 1

src/Nix/Value.hs

@@ -226,8 +226,13 @@ isClosureNF _ = False
 thunkEq :: MonadThunk (NValue m) (NThunk m) m
         => NThunk m -> NThunk m -> m Bool
 thunkEq lt rt = force lt $ \lv -> force rt $ \rv ->
-  case (lv, rv) of
+  let unsafePtrEq = case (lt, rt) of
-    (NVClosure _ _, NVClosure _ _) -> pure True
+        (NThunk _ (Thunk lid _ _), NThunk _ (Thunk rid _ _)) | lid == rid -> return True
+        _ -> valueEq lv rv
+  in case (lv, rv) of
+    (NVClosure _ _, NVClosure _ _) -> unsafePtrEq
+    (NVList _, NVList _) -> unsafePtrEq
+    (NVSet _ _, NVSet _ _) -> unsafePtrEq
     _ -> valueEq lv rv
 
 -- | Checks whether two containers are equal, using the given item equality

tests/EvalTests.hs

@@ -13,6 +13,7 @@ import           Control.Monad.Catch
 import           Control.Monad (when)
 import           Control.Monad.IO.Class
 import qualified Data.HashMap.Lazy as M
+import           Data.List ((\\))
 import           Data.Maybe (isJust)
 import           Data.String.Interpolate.IsString
 import qualified Data.Set as S
@@ -41,7 +42,7 @@ case_zero_div = do
   assertNixEvalThrows "builtins.div 1.0 0.0"
 
 case_bit_ops = do
-    -- mic92 (2018-08-20): change to constantEqualText, 
+    -- mic92 (2018-08-20): change to constantEqualText,
     -- when hnix's nix fork supports bitAnd/bitOr/bitXor
     constantEqualText' "0" "builtins.bitAnd 1 0"
     constantEqualText' "1" "builtins.bitOr 1 1"
@@ -373,17 +374,45 @@ case_empty_string_not_equal_null_is_true =
 case_null_equal_not_empty_string_is_true =
   constantEqualText "true" "null != \"\""
 
+case_list_nested_bottom_diverges =
+  assertNixEvalThrows "let nested = [(let x = x; in x)]; in nested == nested"
+
+case_attrset_nested_bottom_diverges =
+  assertNixEvalThrows "let nested = { y = (let x = x; in x); }; in nested == nested"
+
+case_list_list_nested_bottom_equal =
+  constantEqualText "true" "let nested = [[(let x = x; in x)]]; in nested == nested"
+
+case_list_attrset_nested_bottom_equal =
+  constantEqualText "true" "let nested = [{ y = (let x = x; in x); }]; in nested == nested"
+
+case_list_function_nested_bottom_equal =
+  constantEqualText "true" "let nested = [(_: let x = x; in x)]; in nested == nested"
+
+case_attrset_list_nested_bottom_equal =
+  constantEqualText "true" "let nested = { y = [(let x = x; in x)];}; in nested == nested"
+
+case_attrset_attrset_nested_bottom_equal =
+  constantEqualText "true" "let nested = { y = { y = (let x = x; in x); }; }; in nested == nested"
+
+case_attrset_function_nested_bottom_equal =
+  constantEqualText "true" "let nested = { y = _: (let x = x; in x); }; in nested == nested"
+
 -----------------------
 
 tests :: TestTree
 tests = $testGroupGenerator
 
 genEvalCompareTests = do
-    files <- filter ((==".nix") . takeExtension) <$> D.listDirectory testDir
+    td <- D.listDirectory testDir
-    return $ testGroup "Eval comparison tests" $ map mkTestCase files
+
+    let unmaskedFiles = filter ((==".nix") . takeExtension) td
+    let files = unmaskedFiles \\ maskedFiles
+
+    return $ testGroup "Eval comparison tests" $ map (mkTestCase testDir) files
   where
-    testDir = "tests/eval-compare"
+    mkTestCase td f = testCase f $ assertEvalFileMatchesNix (td </> f)
-    mkTestCase f = testCase f $ assertEvalFileMatchesNix (testDir </> f)
+
 
 instance (Show r, Show (NValueF m r), Eq r) => Eq (NValueF m r) where
     NVConstantF x == NVConstantF y = x == y
@@ -439,3 +468,10 @@ freeVarsEqual a xs = do
       xs' = S.fromList xs
       free = freeVars a'
   assertEqual "" xs' free
+
+maskedFiles :: [FilePath]
+maskedFiles =
+  [ "builtins.fetchurl-01.nix" ]
+
+testDir :: FilePath
+testDir = "tests/eval-compare"

tests/NixLanguageTests.hs

@@ -13,6 +13,8 @@ import           Data.List (delete, sort)
 import           Data.List.Split (splitOn)
 import           Data.Map (Map)
 import qualified Data.Map as Map
+import           Data.Set (Set)
+import qualified Data.Set as Set
 import qualified Data.Text as Text
 import qualified Data.Text.IO as Text
 import           Data.Time
@@ -56,11 +58,23 @@ From (git://nix)/tests/lang.sh we see that
 groupBy :: Ord k => (v -> k) -> [v] -> Map k [v]
 groupBy key = Map.fromListWith (++) . map (key &&& pure)
 
+-- | New tests, which have never yet passed.  Once any of these is passing,
+-- please remove it from this list.  Do not add tests to this list if they have
+-- previously passed.
+newFailingTests :: Set String
+newFailingTests = Set.fromList
+  [ "eval-okay-path"
+  , "eval-okay-fromTOML"
+  , "eval-okay-context-introspection"
+  , "eval-okay-concatmap"
+  , "eval-okay-builtins-add"
+  ]
+
 genTests :: IO TestTree
 genTests = do
   testFiles <- sort
         -- jww (2018-05-07): Temporarily disable this test until #128 is fixed.
-      . filter ((/= "eval-okay-path") . takeBaseName)
+      . filter ((`Set.notMember` newFailingTests) . takeBaseName)
       . filter ((/= ".xml") . takeExtension)
       <$> globDir1 (compile "*-*-*.*") "data/nix/tests/lang"
   let testsByName = groupBy (takeFileName . dropExtensions) testFiles

tests/eval-compare/builtins.eq-bottom-00.nix

@@ -0,0 +1,25 @@
+let
+
+  plain = (let x = x; in x);
+  nested_list = [(let x = x; in x)];
+  nested_attrset = { y = (let x = x; in x); };
+  nested_list_list = [[(let x = x; in x)]];
+  nested_list_attrset = [{ y = (let x = x; in x); }];
+  nested_list_function = [(_: let x = x; in x)];
+  nested_attrset_list = { y = [(let x = x; in x)]; };
+  nested_attrset_attrset = { y = { y = (let x = x; in x); }; };
+  nested_attrset_function = { y = (_: let x = x; in x); };
+
+  tests = [
+    # (plain == plain) # Diverges
+    # (nested_list == nested_list) # Diverges
+    # (nested_attrset == nested_attrset) # Diverges
+    (nested_list_list == nested_list_list)
+    (nested_list_attrset == nested_list_attrset)
+    (nested_list_function == nested_list_function)
+    (nested_attrset_attrset == nested_attrset_attrset)
+    (nested_attrset_list == nested_attrset_list)
+    (nested_attrset_function == nested_attrset_function)
+  ];
+
+in tests

tests/eval-compare/builtins.fetchurl-01.nix

@@ -0,0 +1,5 @@
+with builtins;
+
+let a = fetchurl "https://haskell.org";
+
+in [ a (hasContext a) ]

tests/eval-compare/current-system.nix

@@ -0,0 +1 @@
+builtins.hasContext builtins.currentSystem

tests/eval-compare/ellipsis.nix

@@ -0,0 +1,3 @@
+let x = 1;
+    f = { ... }: x;
+in f { x = 2; }