Merge branch 'master' into vs-context-primops
This commit is contained in:
commit
718c94e0bb
|
@ -1,5 +1,5 @@
|
|||
**/*~
|
||||
**/#*
|
||||
**/*~
|
||||
**/.#*
|
||||
/.history
|
||||
/Setup
|
||||
|
@ -7,6 +7,7 @@
|
|||
/nix-test-eval*
|
||||
/nix/
|
||||
TAGS
|
||||
cabal.project*
|
||||
ctags
|
||||
dist-newstyle
|
||||
result
|
||||
result
|
|
@ -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:
|
||||
|
|
|
@ -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
|
||||
```
|
||||
|
||||
|
|
70
default.nix
70
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"
|
||||
, 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
|
||||
|
|
22
hnix.cabal
22
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)
|
||||
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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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)
|
||||
|
||||
|
|
|
@ -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))
|
||||
|
||||
|
|
|
@ -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
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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")
|
||||
|
||||
|
|
|
@ -256,6 +256,7 @@ exprFNixDoc = \case
|
|||
[ "assert" <+> withoutParens cond <> semi
|
||||
, align $ withoutParens body
|
||||
]
|
||||
NSynHole name -> simpleExpr $ pretty ("^" <> unpack name)
|
||||
where
|
||||
recPrefix = "rec" <> space
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
|
@ -0,0 +1,5 @@
|
|||
with builtins;
|
||||
|
||||
let a = fetchurl "https://haskell.org";
|
||||
|
||||
in [ a (hasContext a) ]
|
|
@ -0,0 +1 @@
|
|||
builtins.hasContext builtins.currentSystem
|
|
@ -0,0 +1,3 @@
|
|||
let x = 1;
|
||||
f = { ... }: x;
|
||||
in f { x = 2; }
|
Loading…
Reference in New Issue