Merge branch 'master' into vs-context-primops

This commit is contained in:
Ken Micklas 2019-03-10 13:48:58 -04:00
commit 718c94e0bb
30 changed files with 521 additions and 205 deletions

5
.gitignore vendored
View File

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

View File

@ -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=ghc844 STRICT=false TRACING=true
- GHCVERSION=ghc863 STRICT=false TRACING=false
- GHCVERSION=ghc863 STRICT=false TRACING=true
# - GHCVERSION=ghcjs
#
# matrix:

View File

@ -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
```

View File

@ -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"
, sha256 ? "1a7vvxxz8phff51vwsrdlsq5i70ig5hxvvb7lkm2lgwizgvpa6gv"
, withHoogle ? false
, 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 ++
[ pkgs.nix
pkgs.haskell.packages.ghc844.criterion
];
testHaskellDepends = attrs.testHaskellDepends ++ [
pkgs.nix
haskellPackages.criterion
];
inherit doBenchmark;
@ -58,10 +91,11 @@ drv = haskellPackages.developPackage {
passthru = {
nixpkgs = pkgs;
inherit haskellPackages;
};
});
inherit returnShellEnv;
returnShellEnv = false;
};
in drv

View File

@ -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)
build-depends:
ghc-datasize
-- if impl(ghc < 8.4.0) && !flag(profiling)
-- build-depends:
-- 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

1
shell.nix Normal file
View File

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

View File

@ -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

View File

@ -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
-> m t
-> Maybe (AttrSet 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)
| otherwise ->
This _ | isVariadic -> Nothing
| 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)

View File

@ -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

View File

@ -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

View File

@ -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)

View File

@ -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))

77
src/Nix/Fresh.hs Normal file
View File

@ -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

View File

@ -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 _ ->
A.Object <$> traverse (join . lift . flip force (return . nvalueToJSON)) m
NVSet m _ -> case HM.lookup "outPath" m of
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

View File

@ -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 }
deriving (Functor, Applicative, Monad, MonadFix,
MonadReader (Context (Lint s) (SThunk (Lint s))))
instance MonadRef (Lint s) where
type Ref (Lint s) = Ref (ST s)
newRef x = Lint $ newRef x
readRef x = Lint $ readRef x
writeRef x y = Lint $ writeRef x y
instance MonadAtomicRef (Lint s) where
atomicModifyRef x f = Lint $ ReaderT $ \_ -> do
res <- snd . f <$> readSTRef x
_ <- modifySTRef x (fst . f)
return res
{ runLint :: ReaderT (Context (Lint s) (SThunk (Lint s))) (FreshIdT Int (ST s)) a }
deriving
( Functor
, Applicative
, Monad
, MonadFix
, MonadReader (Context (Lint s) (SThunk (Lint s)))
, MonadFreshId Int
, MonadRef
, MonadAtomicRef
)
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

View File

@ -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")

View File

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

View File

@ -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 (SrcSpan beg@(SourcePos _ _ _) _) msg =
return $ pretty $ init $ parseErrorPretty @String (posAndMsg beg msg)
renderLocation :: MonadFile m => SrcSpan -> Doc a -> m (Doc a)
renderLocation (SrcSpan (SourcePos file begLine begCol)
(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

View File

@ -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 :: ThunkLoop) <- fromException f = renderThunkLoop level e
| Just (e :: ValueFrame m) <- fromException f = renderValueFrame level e
| Just (e :: NormalLoop m) <- fromException f = renderNormalLoop level e
| Just (e :: ExecFrame m) <- fromException f = renderExecFrame level e
| Just (e :: ErrorCall) <- fromException f = pure [pretty (show e)]
| Just (e :: EvalFrame m v) <- fromException f = renderEvalFrame level e
| Just (e :: ThunkLoop) <- fromException f = renderThunkLoop level e
| Just (e :: ValueFrame m) <- fromException f = renderValueFrame level e
| Just (e :: NormalLoop m) <- fromException f = renderNormalLoop level e
| Just (e :: ExecFrame m) <- fromException f = renderExecFrame level 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)

View File

@ -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

View File

@ -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 Data.IORef
import System.IO.Unsafe
import Nix.Fresh
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 action =
#if ENABLE_TRACING
let !x = unsafePerformIO (atomicModifyIORef' counter (\c -> (succ c, c))) in
Thunk x
#else
Thunk 0
#endif
<$> newVar False <*> newVar (Deferred action)
buildThunk :: (MonadVar m, MonadFreshId Int m) => m v -> m (Thunk m v)
buildThunk action =do
freshThunkId <- freshId
Thunk freshThunkId <$> 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

View File

@ -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))
(StateT InferState (ExceptT InferError (ST s))) a
ReaderT (Set.Set TVar, Scopes (InferT s m) (JThunkT s m))
(StateT InferState (ExceptT InferError m)) a
}
deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadFix,
MonadReader (Set.Set TVar, Scopes (Infer s) (JThunk s)), MonadFail,
MonadState InferState, MonadError InferError)
MonadReader (Set.Set TVar, Scopes (InferT s m) (JThunkT s m)), MonadFail,
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 m = runST (runInfer' m)
runInfer :: (forall s. InferT s (FreshIdT Int (ST s)) a) -> Either InferError a
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 x = Infer . local (first (Set.insert x)) . getInfer
extendMSet :: Monad m => TVar -> InferT s m a -> InferT s m a
extendMSet x = InferT . local (first (Set.insert x)) . getInfer
letters :: [String]
letters = [1..] >>= flip replicateM ['a'..'z']
fresh :: MonadState InferState m => m Type
fresh = do
freshTVar :: MonadState InferState m => m TVar
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 = Infer . lift . lift . lift
liftInfer :: Monad m => m a -> InferT s m a
liftInfer = InferT . lift . lift . lift
instance MonadRef (Infer s) where
type Ref (Infer s) = STRef s
newRef x = liftInfer $ newSTRef x
readRef x = liftInfer $ readSTRef x
writeRef x y = liftInfer $ writeSTRef x y
instance (MonadRef m, Ref m ~ STRef s) => MonadRef (InferT s m) where
type Ref (InferT s m) = Ref m
newRef x = liftInfer $ newRef x
readRef x = liftInfer $ readRef x
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
_ <- modifySTRef x (fst . f)
res <- snd . f <$> readRef x
_ <- 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

View File

@ -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

View File

@ -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
(NVClosure _ _, NVClosure _ _) -> pure True
let unsafePtrEq = case (lt, rt) of
(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

View File

@ -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
return $ testGroup "Eval comparison tests" $ map mkTestCase files
td <- D.listDirectory testDir
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 f = testCase f $ assertEvalFileMatchesNix (testDir </> f)
mkTestCase td f = testCase f $ assertEvalFileMatchesNix (td </> 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"

View File

@ -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

View File

@ -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

View File

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

View File

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

View File

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