diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -2,6 +2,7 @@
[](https://travis-ci.org/haskell-nix/hnix)
[](https://gitter.im/haskell-nix/Lobby)
+([Hackage Matrix Builder](https://matrix.hackage.haskell.org/package/hnix))
Haskell parser, evaluator and type checker for the Nix language.
@@ -21,7 +22,9 @@
$ cabal build
$ cabal test
# To run all of the tests, which takes up to a minute:
-$ LANGUAGE_TESTS=yes NIXPKGS_TESTS=yes cabal test
+$ 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
$ ./dist/build/hnix/hnix --help
```
@@ -44,8 +47,8 @@
use:
```
-$ nix-shell --arg doProfiling true
-$ cabal configure --enable-tests --enable-profiling --flags=tracing
+$ nix-shell
+$ cabal configure --enable-tests --enable-profiling --flags=profiling --flags=tracing
$ cabal build
$ ./dist/build/hnix/hnix -v5 --trace +RTS -xc
```
@@ -69,11 +72,22 @@
To build `hnix` with profiling enabled:
```
-$ nix-shell --arg doProfiling true
-$ cabal configure --enable-tests --enable-profiling
+$ nix-shell
+$ cabal configure --enable-tests --enable-profiling --flags=profiling
$ cabal build
$ ./dist/build/hnix/hnix +RTS -p
```
+
+## Building with GHCJS
+
+From the project root directory, run:
+
+```
+$ NIX_CONF_DIR=$PWD/ghcjs nix-build ghcjs
+```
+
+This will build an `hnix` library that can be linked to your GHCJS
+application.
## How you can help
diff --git a/hnix.cabal b/hnix.cabal
--- a/hnix.cabal
+++ b/hnix.cabal
@@ -2,15 +2,15 @@
--
-- see: https://github.com/sol/hpack
--
--- hash: 4fcbb40c5cce579b650040f74a0c3536bfcbeed20237041c20a91aac50e82808
+-- hash: ba0f61f8a049f6970ff03fd924cfed6fc1251eceb90547c1be8051226c453632
name: hnix
-version: 0.5.1
+version: 0.5.2
synopsis: Haskell implementation of the Nix language
description: Haskell implementation of the Nix language.
category: System, Data, Nix
-homepage: https://github.com/jwiegley/hnix#readme
-bug-reports: https://github.com/jwiegley/hnix/issues
+homepage: https://github.com/haskell-nix/hnix#readme
+bug-reports: https://github.com/haskell-nix/hnix/issues
author: John Wiegley
maintainer: johnw@newartisans.com
license: BSD3
@@ -427,7 +427,7 @@
source-repository head
type: git
- location: https://github.com/jwiegley/hnix
+ location: https://github.com/haskell-nix/hnix
flag optimize
description: Enable all optimization flags
@@ -494,7 +494,7 @@
, containers
, data-fix
, deepseq >=1.4.2 && <1.5
- , deriving-compat >=0.3 && <0.5
+ , deriving-compat >=0.3 && <0.6
, directory
, exceptions
, filepath
@@ -502,11 +502,10 @@
, http-client
, http-client-tls
, http-types
- , lens-family
- , lens-family-core
+ , interpolate
, lens-family-th
, logict
- , megaparsec >=6.0 && <6.6
+ , megaparsec >=6.5 && <7.0
, monadlist
, mtl
, optparse-applicative
@@ -526,6 +525,13 @@
, unordered-containers >=0.2.9 && <0.3
, vector
, 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
if !impl(ghcjs)
build-depends:
base16-bytestring
@@ -534,6 +540,17 @@
, cryptohash-sha256
, cryptohash-sha512
, serialise
+ if impl(ghc < 8.1)
+ build-depends:
+ lens-family ==1.2.1
+ , lens-family-core ==1.2.1
+ else
+ 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(ghcjs)
build-depends:
hashable >=1.2.4 && <1.3
@@ -576,6 +593,13 @@
, time
, transformers
, 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
if !impl(ghcjs)
build-depends:
base16-bytestring
@@ -599,6 +623,7 @@
ParserTests
PrettyParseTests
PrettyTests
+ ReduceExprTests
TestCommon
Paths_hnix
hs-source-dirs:
@@ -607,7 +632,6 @@
build-depends:
Diff
, Glob
- , QuickCheck
, ansi-wl-pprint
, base >=4.9 && <5
, bytestring
@@ -619,6 +643,7 @@
, filepath
, generic-random
, hashing
+ , hedgehog
, hnix
, interpolate
, megaparsec
@@ -626,9 +651,9 @@
, optparse-applicative
, pretty-show
, process
- , quickcheck-instances
, split
, tasty
+ , tasty-hedgehog
, tasty-hunit
, tasty-quickcheck
, tasty-th
@@ -638,6 +663,13 @@
, transformers
, unix
, 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
if !impl(ghcjs)
build-depends:
base16-bytestring
@@ -651,6 +683,7 @@
else
buildable: True
default-language: Haskell2010
+ build-tool-depends: hspec-discover:hspec-discover == 2.*
benchmark hnix-benchmarks
type: exitcode-stdio-1.0
@@ -680,6 +713,13 @@
, time
, transformers
, 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
if !impl(ghcjs)
build-depends:
base16-bytestring
diff --git a/main/Main.hs b/main/Main.hs
--- a/main/Main.hs
+++ b/main/Main.hs
@@ -144,7 +144,7 @@
. A.encodingToLazyByteString
. toEncodingSorted
<=< fromNix
- | normalize opts =
+ | strict opts =
liftIO . print . prettyNValueNF <=< normalForm
| values opts =
liftIO . print <=< prettyNValueProv
diff --git a/main/Repl.hs b/main/Repl.hs
--- a/main/Repl.hs
+++ b/main/Repl.hs
@@ -103,7 +103,7 @@
go expr = do
val <- evalExprLoc expr
opts :: Nix.Options <- asks (view hasLens)
- if | normalize opts ->
+ if | strict opts ->
liftIO . print . prettyNValueNF =<< normalForm val
| values opts ->
liftIO . print =<< prettyNValueProv val
diff --git a/package.yaml b/package.yaml
--- a/package.yaml
+++ b/package.yaml
@@ -1,7 +1,7 @@
name: hnix
-version: 0.5.1
+version: 0.5.2
synopsis: Haskell implementation of the Nix language
-github: jwiegley/hnix
+github: haskell-nix/hnix
author: John Wiegley
maintainer: johnw@newartisans.com
category: System, Data, Nix
@@ -53,17 +53,6 @@
ghc-options:
- -Wall
-when:
- - condition: flag(optimize)
- ghc-options:
- - -fexpose-all-unfoldings
- - -fspecialise-aggressively
- - -O2
-
-when:
- - condition: flag(tracing)
- cpp-options: -DENABLE_TRACING=1
-
dependencies:
- base >= 4.9 && < 5
- ansi-wl-pprint
@@ -83,11 +72,19 @@
- unordered-containers >= 0.2.9 && < 0.3
when:
- - condition: "os(linux) && impl(ghc < 8.2)"
+ - condition: flag(optimize)
+ ghc-options:
+ - -fexpose-all-unfoldings
+ - -fspecialise-aggressively
+ - -O2
+
+ - condition: flag(tracing)
+ cpp-options: -DENABLE_TRACING=1
+
+ - condition: "os(linux) && impl(ghc >= 8.2) && impl(ghc < 8.3)"
dependencies:
- compact
-when:
- condition: "!impl(ghcjs)"
dependencies:
- base16-bytestring
@@ -104,16 +101,15 @@
- ansi-wl-pprint
- array >= 0.4 && < 0.6
- binary
- - deriving-compat >= 0.3 && < 0.5
+ - deriving-compat >= 0.3 && < 0.6
- directory
- http-types
- http-client
- http-client-tls
- - lens-family
- - lens-family-core
+ - interpolate
- lens-family-th
- logict
- - megaparsec >= 6.0 && < 6.6
+ - megaparsec >= 6.5 && < 7.0
- monadlist
- process
- regex-tdfa
@@ -127,10 +123,20 @@
- vector
- xml
when:
- - condition: impl(ghc < 8.4.0) && !flag(profiling)
+ - condition: "impl(ghc < 8.1)"
+ then:
+ dependencies:
+ - lens-family == 1.2.1
+ - lens-family-core == 1.2.1
+ else:
+ dependencies:
+ - lens-family >= 1.2.2
+ - lens-family-core >= 1.2.2
+
+ - condition: "impl(ghc < 8.4.0) && !flag(profiling)"
dependencies:
- ghc-datasize
- when:
+
- condition: "impl(ghcjs)"
then:
dependencies:
@@ -165,6 +171,9 @@
source-dirs: tests
main: Main.hs
ghc-options: -threaded
+ verbatim:
+ build-tool-depends:
+ hspec-discover:hspec-discover == 2.*
dependencies:
- hnix
- Glob
@@ -173,11 +182,11 @@
- process
- split
- tasty
+ - tasty-hedgehog
- tasty-hunit
- tasty-th
- unix
- - QuickCheck
- - quickcheck-instances
+ - hedgehog
- generic-random
- Diff
- megaparsec
diff --git a/src/Nix/Atoms.hs b/src/Nix/Atoms.hs
--- a/src/Nix/Atoms.hs
+++ b/src/Nix/Atoms.hs
@@ -6,7 +6,7 @@
module Nix.Atoms where
-#if MIN_VERSION_serialise(0, 2, 0)
+#ifdef MIN_VERSION_serialise
import Codec.Serialise
#endif
import Control.DeepSeq
@@ -31,7 +31,7 @@
deriving (Eq, Ord, Generic, Typeable, Data, Show, Read, NFData,
Hashable)
-#if MIN_VERSION_serialise(0, 2, 0)
+#ifdef MIN_VERSION_serialise
instance Serialise NAtom
#endif
diff --git a/src/Nix/Builtins.hs b/src/Nix/Builtins.hs
--- a/src/Nix/Builtins.hs
+++ b/src/Nix/Builtins.hs
@@ -10,6 +10,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
@@ -43,6 +44,7 @@
import qualified "cryptohash-sha256" Crypto.Hash.SHA256 as SHA256
import qualified "cryptohash-sha512" Crypto.Hash.SHA512 as SHA512
#endif
+
import qualified Data.Aeson as A
import qualified Data.Aeson.Encoding as A
import Data.Align (alignWith)
@@ -60,6 +62,7 @@
import Data.Semigroup
import Data.Set (Set)
import qualified Data.Set as S
+import Data.String.Interpolate.IsString
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Text.Encoding
@@ -68,7 +71,6 @@
import Data.These (fromThese)
import qualified Data.Time.Clock.POSIX as Time
import Data.Traversable (mapM)
-import Language.Haskell.TH.Syntax (addDependentFile, runIO)
import Nix.Atoms
import Nix.Convert
import Nix.Effects
@@ -141,15 +143,41 @@
, add0 Normal "currentSystem" currentSystem
, add0 Normal "currentTime" currentTime_
, add2 Normal "deepSeq" deepSeq
-#if MIN_VERSION_base(4, 10, 0)
- -- TODO Remove this CPP after the Lift instance for NExpr works with GHC 8.0
- , add0 TopLevel "derivation" $(do
- let f = "data/nix/corepkgs/derivation.nix"
- addDependentFile f
- Success expr <- runIO $ parseNixFile f
+
+ , add0 TopLevel "derivation" $(do
+ -- This is compiled in so that we only parse and evaluate it once,
+ -- at compile-time.
+ let Success expr = parseNixText [i|
+ /* This is the implementation of the ‘derivation’ builtin function.
+ It's actually a wrapper around the ‘derivationStrict’ primop. */
+
+ drvAttrs @ { outputs ? [ "out" ], ... }:
+
+ let
+
+ strict = derivationStrict drvAttrs;
+
+ commonAttrs = drvAttrs // (builtins.listToAttrs outputsList) //
+ { all = map (x: x.value) outputsList;
+ inherit drvAttrs;
+ };
+
+ outputToAttrListElement = outputName:
+ { name = outputName;
+ value = commonAttrs // {
+ outPath = builtins.getAttr outputName strict;
+ drvPath = strict.drvPath;
+ type = "derivation";
+ inherit outputName;
+ };
+ };
+
+ outputsList = map outputToAttrListElement outputs;
+
+ in (builtins.head outputsList).value|]
[| cata Eval.eval expr |]
)
-#endif
+
, add TopLevel "derivationStrict" derivationStrict_
, add TopLevel "dirOf" dirOf
, add2 Normal "div" div_
@@ -194,6 +222,7 @@
, add TopLevel "placeholder" placeHolder
, add Normal "readDir" readDir_
, add Normal "readFile" readFile_
+ , add2 Normal "findFile" findFile_
, add2 TopLevel "removeAttrs" removeAttrs
, add3 Normal "replaceStrings" replaceStrings
, add2 TopLevel "scopedImport" scopedImport
@@ -211,6 +240,7 @@
, add' Normal "toJSON"
(arity1 $ decodeUtf8 . LBS.toStrict . A.encodingToLazyByteString
. toEncodingSorted)
+ , add2 Normal "toFile" toFile
, add Normal "toPath" toPath
, add TopLevel "toString" toString
, add Normal "toXML" toXML_
@@ -266,8 +296,7 @@
nvStr (Text.pack (fromMaybe "" mn)) mempty) ]) : rest
toString :: MonadNix e m => m (NValue m) -> m (NValue m)
-toString str =
- str >>= normalForm >>= valueText False >>= toNix @(Text, DList Text)
+toString str = str >>= coerceToString False >>= toNix . Text.pack
hasAttr :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
hasAttr x y =
@@ -285,11 +314,11 @@
hasContext =
toNix . not . null . (appEndo ?? []) . snd <=< fromValue @(Text, DList Text)
-getAttr :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
-getAttr x y = x >>= \x' -> y >>= \y' -> case (x', y') of
- (NVStr key _, NVSet aset _) -> attrsetGet key aset >>= force'
- (x, y) -> throwError $ ErrorCall $ "Invalid types for builtin.getAttr: "
- ++ show (x, y)
+getAttr :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
+getAttr x y =
+ fromValue @Text x >>= \key ->
+ fromValue @(AttrSet (NThunk m), AttrSet SourcePos) y >>= \(aset, _) ->
+ attrsetGet key aset >>= force'
unsafeGetAttrPos :: forall e m. MonadNix e m
=> m (NValue m) -> m (NValue m) -> m (NValue m)
@@ -297,7 +326,7 @@
(NVStr key _, NVSet _ apos) -> case M.lookup key apos of
Nothing -> pure $ nvConstant NNull
Just delta -> toValue delta
- (x, y) -> throwError $ ErrorCall $ "Invalid types for builtin.unsafeGetAttrPos: "
+ (x, y) -> throwError $ ErrorCall $ "Invalid types for builtins.unsafeGetAttrPos: "
++ show (x, y)
-- This function is a bit special in that it doesn't care about the contents
@@ -327,11 +356,14 @@
div_ :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
div_ x y = x >>= \x' -> y >>= \y' -> case (x', y') of
- (NVConstant (NInt x), NVConstant (NInt y)) ->
+ (NVConstant (NInt x), NVConstant (NInt y)) | y /= 0 ->
toNix (floor (fromInteger x / fromInteger y :: Double) :: Integer)
- (NVConstant (NFloat x), NVConstant (NInt y)) -> toNix (x / fromInteger y)
- (NVConstant (NInt x), NVConstant (NFloat y)) -> toNix (fromInteger x / y)
- (NVConstant (NFloat x), NVConstant (NFloat y)) -> toNix (x / y)
+ (NVConstant (NFloat x), NVConstant (NInt y)) | y /= 0 ->
+ toNix (x / fromInteger y)
+ (NVConstant (NInt x), NVConstant (NFloat y)) | y /= 0 ->
+ toNix (fromInteger x / y)
+ (NVConstant (NFloat x), NVConstant (NFloat y)) | y /= 0 ->
+ toNix (x / y)
(_, _) ->
throwError $ Division x' y'
@@ -677,6 +709,13 @@
v -> throwError $ ErrorCall $
"builtins.functionArgs: expected function, got " ++ show v
+toFile :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
+toFile name s = do
+ name' <- fromValue name
+ s' <- fromValue s
+ mres <- toFile_ (Text.unpack name') (Text.unpack s')
+ toNix $ Text.pack $ unStorePath mres
+
toPath :: MonadNix e m => m (NValue m) -> m (NValue m)
toPath = fromValue @Path >=> toNix @Path
@@ -826,6 +865,19 @@
readFile_ :: MonadNix e m => m (NValue m) -> m (NValue m)
readFile_ path =
path >>= absolutePathFromValue >>= Nix.Render.readFile >>= toNix
+
+findFile_ :: forall e m. MonadNix e m
+ => m (NValue m) -> m (NValue m) -> m (NValue m)
+findFile_ aset filePath =
+ aset >>= \aset' ->
+ filePath >>= \filePath' ->
+ case (aset', filePath') of
+ (NVList x, NVStr name _) -> do
+ mres <- findPath x (Text.unpack name)
+ pure $ nvPath mres
+ (NVList _, y) -> throwError $ ErrorCall $ "expected a string, got " ++ show y
+ (x, NVStr _ _) -> throwError $ ErrorCall $ "expected a list, got " ++ show x
+ (x, y) -> throwError $ ErrorCall $ "Invalid types for builtins.findFile: " ++ show (x, y)
data FileType
= FileTypeRegular
diff --git a/src/Nix/Cache.hs b/src/Nix/Cache.hs
--- a/src/Nix/Cache.hs
+++ b/src/Nix/Cache.hs
@@ -13,7 +13,7 @@
import qualified Data.Compact as C
import qualified Data.Compact.Serialize as C
#endif
-#if MIN_VERSION_serialise(0, 2, 0)
+#ifdef MIN_VERSION_serialise
import qualified Codec.Serialise as S
#endif
@@ -25,7 +25,7 @@
Left err -> error $ "Error reading cache file: " ++ err
Right expr -> return $ C.getCompact expr
#else
-#if MIN_VERSION_serialise(0, 2, 0)
+#ifdef MIN_VERSION_serialise
eres <- S.deserialiseOrFail <$> BS.readFile path
case eres of
Left err -> error $ "Error reading cache file: " ++ show err
@@ -40,7 +40,7 @@
#ifdef USE_COMPACT
C.writeCompact path =<< C.compact expr
#else
-#if MIN_VERSION_serialise(0, 2, 0)
+#ifdef MIN_VERSION_serialise
BS.writeFile path (S.serialise expr)
#else
error "writeCache not implemented for this platform"
diff --git a/src/Nix/Effects.hs b/src/Nix/Effects.hs
--- a/src/Nix/Effects.hs
+++ b/src/Nix/Effects.hs
@@ -13,10 +13,16 @@
-- | Import a path into the nix store, and return the resulting path
addPath :: FilePath -> m StorePath
+ toFile_ :: FilePath -> String -> m StorePath
+
-- | Determine the absolute path of relative path in the current context
makeAbsolutePath :: FilePath -> m FilePath
findEnvPath :: String -> m FilePath
+ -- | Having an explicit list of sets corresponding to the NIX_PATH
+ -- and a file path try to find an existing path
+ findPath :: [NThunk m] -> FilePath -> m FilePath
+
pathExists :: FilePath -> m Bool
importPath :: AttrSet (NThunk m) -> FilePath -> m (NValue m)
@@ -38,3 +44,4 @@
traceEffect :: String -> m ()
exec :: [String] -> m (NValue m)
+
diff --git a/src/Nix/Eval.hs b/src/Nix/Eval.hs
--- a/src/Nix/Eval.hs
+++ b/src/Nix/Eval.hs
@@ -1,19 +1,14 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
@@ -23,16 +18,16 @@
import Control.Monad.Fix
import Control.Monad.Reader
import Control.Monad.State.Strict
-import Data.Align.Key
-import Data.Fix
+import Data.Align.Key (alignWithKey)
+import Data.Either (isRight)
+import Data.Fix (Fix(Fix))
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M
-import Data.List (partition, foldl')
+import Data.List (partition)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (fromMaybe, catMaybes)
import Data.Text (Text)
-import qualified Data.Text as Text
-import Data.These
+import Data.These (These(..))
import Data.Traversable (for)
import Nix.Atoms
import Nix.Convert
@@ -44,10 +39,9 @@
import Nix.Utils
class (Show v, Monad m) => MonadEval v m | v -> m where
- freeVariable :: Text -> m v
- attrMissing :: NonEmpty Text -> Maybe v -> m v
- evaledSym :: Text -> v -> m v
-
+ freeVariable :: Text -> m v
+ attrMissing :: NonEmpty Text -> Maybe v -> m v
+ evaledSym :: Text -> v -> m v
evalCurPos :: m v
evalConstant :: NAtom -> m v
evalString :: NString (m v) -> m v
@@ -64,7 +58,6 @@
evalAbs :: Params (m v)
-> (forall a. m v -> (AttrSet (m v) -> m v -> m (a, v)) -> m (a, v))
-> m v
-
{-
evalSelect :: v -> NonEmpty Text -> Maybe (m v) -> m v
evalHasAttr :: v -> NonEmpty Text -> m v
@@ -80,7 +73,6 @@
evalLetElem :: Text -> m v -> m v
evalLet :: m v -> m v
-}
-
evalError :: Exception s => s -> m a
type MonadNixEval e v t m =
@@ -109,52 +101,35 @@
eval (NSym var) =
lookupVar var >>= maybe (freeVariable var) (force ?? evaledSym var)
-eval (NConstant x) = evalConstant x
-eval (NStr str) = evalString str
-eval (NLiteralPath p) = evalLiteralPath p
-eval (NEnvPath p) = evalEnvPath p
-eval (NUnary op arg) = evalUnary op =<< arg
+eval (NConstant x) = evalConstant x
+eval (NStr str) = evalString str
+eval (NLiteralPath p) = evalLiteralPath p
+eval (NEnvPath p) = evalEnvPath p
+eval (NUnary op arg) = evalUnary op =<< arg
eval (NBinary NApp fun arg) = do
scope <- currentScopes @_ @t
- evalApp ?? withScopes scope arg =<< fun
+ fun >>= (`evalApp` withScopes scope arg)
-eval (NBinary op larg rarg) = larg >>= \lval -> evalBinary op lval rarg
+eval (NBinary op larg rarg) = larg >>= evalBinary op ?? rarg
-eval (NSelect aset attr alt) = do
- traceM "NSelect"
- mres <- evalSelect aset attr
- traceM "NSelect..2"
- case mres of
- Right v -> v
- Left (s, ks) -> fromMaybe (attrMissing ks (Just s)) alt
+eval (NSelect aset attr alt) = evalSelect aset attr >>= either go id
+ where
+ go (s, ks) = fromMaybe (attrMissing ks (Just s)) alt
-eval (NHasAttr aset attr) =
- toValue . either (const False) (const True) =<< evalSelect aset attr
+eval (NHasAttr aset attr) = evalSelect aset attr >>= toValue . isRight
eval (NList l) = do
scope <- currentScopes
- toValue =<< for l (thunk . withScopes @t scope)
+ for l (thunk . withScopes @t scope) >>= toValue
-eval (NSet binds) = do
- traceM "NSet..1"
- (s, p) <- evalBinds True False binds
- traceM $ "NSet..2: s = " ++ show (void s)
- traceM $ "NSet..2: p = " ++ show (void p)
- toValue (s, p)
+eval (NSet binds) =
+ evalBinds False (desugarBinds (eval . NSet) binds) >>= toValue
-eval (NRecSet binds) = do
- traceM "NRecSet..1"
- (s, p) <- evalBinds True True (desugarBinds (eval . NRecSet) binds)
- traceM $ "NRecSet..2: s = " ++ show (void s)
- traceM $ "NRecSet..2: p = " ++ show (void p)
- toValue (s, p)
+eval (NRecSet binds) =
+ evalBinds True (desugarBinds (eval . NRecSet) binds) >>= toValue
-eval (NLet binds body) = do
- traceM "Let..1"
- (s, _) <- evalBinds True True binds
- traceM $ "Let..2: s = " ++ show (void s)
- pushScope s body
+eval (NLet binds body) = evalBinds True binds >>= (pushScope ?? body) . fst
eval (NIf cond t f) = cond >>= \v -> evalIf v t f
@@ -168,47 +143,47 @@
-- we defer here so the present scope is restored when the parameters and
-- body are forced during application.
scope <- currentScopes @_ @t
- evalAbs params $ \arg k ->
- withScopes @t scope $ do
- args <- buildArgument params arg
- pushScope args (k (M.map (`force` pure) args) body)
+ evalAbs params $ \arg k -> withScopes @t scope $ do
+ args <- buildArgument params arg
+ pushScope args (k (M.map (`force` pure) args) body)
-- | 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 e v t m. MonadNixEval e v t m => m v -> m v -> m v
-evalWithAttrSet scope body = do
+evalWithAttrSet aset body = do
-- The scope is deliberately wrapped in a thunk here, since it is
-- evaluated each time a name is looked up within the weak scope, and
-- we want to be sure the action it evaluates is to force a thunk, so
-- its value is only computed once.
- cur <- currentScopes @_ @t
- s <- thunk $ withScopes cur scope
+ scope <- currentScopes @_ @t
+ s <- thunk $ withScopes scope aset
pushWeakScope ?? body $ force s $
fmap fst . fromValue @(AttrSet t, AttrSet SourcePos)
attrSetAlter :: forall e v t m. MonadNixEval e v t m
=> [Text]
+ -> SourcePos
-> AttrSet (m v)
+ -> AttrSet SourcePos
-> m v
- -> m (AttrSet (m v))
-attrSetAlter [] _ _ =
+ -> m (AttrSet (m v), AttrSet SourcePos)
+attrSetAlter [] _ _ _ _ =
evalError @v $ ErrorCall "invalid selector with no components"
-attrSetAlter (p:ps) m val = case M.lookup p m of
- Nothing
- | null ps -> go
- | otherwise -> recurse M.empty
- Just x
- | null ps -> go
- | otherwise ->
- x >>= fromValue @(AttrSet t, AttrSet SourcePos)
- >>= \(s, _) -> recurse (force ?? pure <$> s)
+
+attrSetAlter (k:ks) pos m p val = case M.lookup k m of
+ Nothing | null ks -> go
+ | otherwise -> recurse M.empty M.empty
+ Just x | null ks -> go
+ | otherwise ->
+ x >>= fromValue @(AttrSet t, AttrSet SourcePos)
+ >>= \(st, sp) -> recurse (force ?? pure <$> st) sp
where
- go = return $ M.insert p val m
+ go = return (M.insert k val m, M.insert k pos p)
- recurse s = attrSetAlter ps s val <&> \m' ->
- M.insert p (toValue @(AttrSet t, AttrSet SourcePos)
- =<< fmap (, mempty)
- (fmap (value @_ @_ @m) <$> sequence m')) m
+ recurse st sp = attrSetAlter ks pos st sp val <&> \(st', _) ->
+ ( M.insert k (toValue @(AttrSet t, AttrSet SourcePos)
+ =<< (, mempty) . fmap value <$> sequence st') st
+ , M.insert k pos sp )
desugarBinds :: forall r. ([Binding r] -> r) -> [Binding r] -> [Binding r]
desugarBinds embed binds = evalState (mapM (go <=< collect) binds) M.empty
@@ -218,10 +193,9 @@
(Either VarName (Binding r))
collect (NamedVar (StaticKey x :| y:ys) val p) = do
m <- get
- let v = case M.lookup x m of
- Nothing -> (p, [NamedVar (y:|ys) val p])
- Just (p, v) -> (p, NamedVar (y:|ys) val p : v)
- put $ M.insert x v m
+ put $ M.insert x ?? m $ case M.lookup x m of
+ Nothing -> (p, [NamedVar (y:|ys) val p])
+ Just (q, v) -> (q, NamedVar (y:|ys) val q : v)
pure $ Left x
collect x = pure $ Right x
@@ -235,10 +209,9 @@
evalBinds :: forall e v t m. MonadNixEval e v t m
=> Bool
- -> Bool
-> [Binding (m v)]
-> m (AttrSet t, AttrSet SourcePos)
-evalBinds allowDynamic recursive binds = do
+evalBinds recursive binds = do
scope <- currentScopes @_ @t
buildResult scope . concat =<< mapM (go scope) (moveOverridesLast binds)
where
@@ -257,7 +230,7 @@
go _ (NamedVar pathExpr finalValue pos) = do
let go :: NAttrPath (m v) -> m ([Text], SourcePos, m v)
go = \case
- h :| t -> evalSetterKeyName allowDynamic h >>= \case
+ h :| t -> evalSetterKeyName h >>= \case
Nothing ->
pure ([], nullPos,
toValue @(AttrSet t, AttrSet SourcePos)
@@ -274,9 +247,9 @@
result -> [result]
go scope (Inherit ms names pos) = fmap catMaybes $ forM names $
- evalSetterKeyName allowDynamic >=> \case
- Nothing -> return Nothing
- Just key -> return $ Just ([key], pos, do
+ evalSetterKeyName >=> \case
+ Nothing -> pure Nothing
+ Just key -> pure $ Just ([key], pos, do
mv <- case ms of
Nothing -> withScopes scope $ lookupVar key
Just s -> s
@@ -291,90 +264,52 @@
-> [([Text], SourcePos, m v)]
-> m (AttrSet t, AttrSet SourcePos)
buildResult scope bindings = do
- s <- foldM insert M.empty bindings
+ (s, p) <- foldM insert (M.empty, M.empty) bindings
res <- if recursive
then loebM (encapsulate <$> s)
- else traverse (thunk . withScopes scope) s
- return (res, foldl' go M.empty bindings)
+ else traverse mkThunk s
+ return (res, p)
where
- go m ([k], pos, _) = M.insert k pos m
- go m _ = m
+ mkThunk = thunk . withScopes scope
- encapsulate f attrs =
- thunk . withScopes scope . pushScope attrs $ f
+ encapsulate f attrs = mkThunk . pushScope attrs $ f
- insert m (path, _, value) = attrSetAlter path m value
+ insert (m, p) (path, pos, value) = attrSetAlter path pos m p value
evalSelect :: forall e v t m. MonadNixEval e v t m
=> m v
-> NAttrPath (m v)
-> m (Either (v, NonEmpty Text) (m v))
evalSelect aset attr = do
- traceM "evalSelect"
s <- aset
- traceM "evalSelect..2"
- path <- evalSelector True attr
- traceM $ "evalSelect..3: " ++ show path
- res <- extract s path
- traceM "evalSelect..4"
- return res
+ path <- traverse evalGetterKeyName attr
+ extract s path
where
extract x path@(k:|ks) = fromValueMay x >>= \case
- Just (s :: AttrSet t, p :: AttrSet SourcePos) ->
- case M.lookup k s of
- Just t -> do
- traceM $ "Forcing value at selector " ++ Text.unpack k
- case ks of
- [] -> pure $ Right $ force t pure
- y:ys -> force t $ extract ?? (y:|ys)
- Nothing ->
- Left . (, path) <$> toValue (s, p)
- Nothing ->
- return $ Left (x, path)
-
-evalSelector :: (MonadEval v m, FromValue (Text, DList Text) m v)
- => Bool -> NAttrPath (m v) -> m (NonEmpty Text)
-evalSelector = traverse . evalGetterKeyName
+ Just (s :: AttrSet t, p :: AttrSet SourcePos)
+ | Just t <- M.lookup k s -> case ks of
+ [] -> pure $ Right $ force t pure
+ y:ys -> force t $ extract ?? (y:|ys)
+ | otherwise -> Left . (, path) <$> toValue (s, p)
+ Nothing -> return $ Left (x, path)
-- | Evaluate a component of an attribute path in a context where we are
-- *retrieving* a value
-evalGetterKeyName :: (MonadEval v m, FromValue (Text, DList Text) m v)
- => Bool -> NKeyName (m v) -> m Text
-evalGetterKeyName canBeDynamic
- | canBeDynamic = evalKeyNameDynamicNotNull
- | otherwise = evalKeyNameStatic
-
-evalKeyNameStatic :: forall v m. MonadEval v m => NKeyName (m v) -> m Text
-evalKeyNameStatic = \case
- StaticKey k -> pure k
- _ -> evalError @v $ ErrorCall "dynamic attribute not allowed in this context"
-
-evalKeyNameDynamicNotNull
- :: forall v m. (MonadEval v m, FromValue (Text, DList Text) m v)
- => NKeyName (m v) -> m Text
-evalKeyNameDynamicNotNull = evalKeyNameDynamicNullable >=> \case
+evalGetterKeyName :: forall v m. (MonadEval v m, FromValue (Text, DList Text) m v)
+ => NKeyName (m v) -> m Text
+evalGetterKeyName = evalSetterKeyName >=> \case
Just k -> pure k
Nothing -> evalError @v $ ErrorCall "value is null while a string was expected"
-- | Evaluate a component of an attribute path in a context where we are
-- *binding* a value
evalSetterKeyName :: (MonadEval v m, FromValue (Text, DList Text) m v)
- => Bool -> NKeyName (m v) -> m (Maybe Text)
-evalSetterKeyName canBeDynamic
- | canBeDynamic = evalKeyNameDynamicNullable
- | otherwise = fmap Just . evalKeyNameStatic
-
--- | Returns Nothing iff the key value is null
-evalKeyNameDynamicNullable
- :: forall v m. (MonadEval v m, FromValue (Text, DList Text) m v)
- => NKeyName (m v)
- -> m (Maybe Text)
-evalKeyNameDynamicNullable = \case
- StaticKey k -> pure (Just k)
- DynamicKey k ->
- runAntiquoted "\n" assembleString (>>= fromValueMay) k
- <&> \case Just (t, _) -> Just t
- _ -> Nothing
+ => NKeyName (m v) -> m (Maybe Text)
+evalSetterKeyName = \case
+ StaticKey k -> pure (Just k)
+ DynamicKey k -> runAntiquoted "\n" assembleString (>>= fromValueMay) k
+ <&> \case Just (t, _) -> Just t
+ _ -> Nothing
assembleString :: forall v m. (MonadEval v m, FromValue (Text, DList Text) m v)
=> NString (m v) -> m (Maybe (Text, DList Text))
@@ -382,17 +317,16 @@
Indented _ parts -> fromParts parts
DoubleQuoted parts -> fromParts parts
where
- go = runAntiquoted "\n" (pure . Just . (, mempty)) (>>= fromValueMay)
+ fromParts = fmap (fmap mconcat . sequence) . traverse go
- fromParts parts = fmap mconcat . sequence <$> mapM go parts
+ go = runAntiquoted "\n" (pure . Just . (, mempty)) (>>= fromValueMay)
buildArgument :: forall e v t m. MonadNixEval e v t m
=> Params (m v) -> m v -> m (AttrSet t)
buildArgument params arg = do
scope <- currentScopes @_ @t
case params of
- Param name -> M.singleton name
- <$> thunk (withScopes scope arg)
+ Param name -> M.singleton name <$> thunk (withScopes scope arg)
ParamSet s isVariadic m ->
arg >>= fromValue @(AttrSet t, AttrSet SourcePos)
>>= \(args, _) -> do
diff --git a/src/Nix/Exec.hs b/src/Nix/Exec.hs
--- a/src/Nix/Exec.hs
+++ b/src/Nix/Exec.hs
@@ -44,6 +44,7 @@
import Data.List
import qualified Data.List.NonEmpty as NE
import Data.List.Split
+import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Typeable
@@ -66,7 +67,7 @@
import Nix.Thunk
import Nix.Utils
import Nix.Value
-#if MIN_VERSION_haskeline(0, 4, 7)
+#ifdef MIN_VERSION_haskeline
import System.Console.Haskeline.MonadException hiding (catch)
#endif
import System.Directory
@@ -78,6 +79,9 @@
import System.Process (readProcessWithExitCode)
import Text.PrettyPrint.ANSI.Leijen (text)
import qualified Text.PrettyPrint.ANSI.Leijen as P
+#ifdef MIN_VERSION_pretty_show
+import qualified Text.Show.Pretty as PS
+#endif
#ifdef MIN_VERSION_ghc_datasize
#if MIN_VERSION_ghc_datasize(0,2,0) && __GLASGOW_HASKELL__ >= 804
@@ -364,6 +368,20 @@
NNEq -> toBool . not =<< valueEq (nvSet M.empty M.empty) rval
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
+ (ls@NVSet {}, NVStr rs rc) -> case op of
+ NPlus -> (\ls -> bin nvStrP (Text.pack ls `mappend` rs) rc)
+ <$> coerceToString False ls
+ NEq -> toBool =<< valueEq lval rval
+ NNEq -> toBool . not =<< valueEq lval rval
+ _ -> nverr $ ErrorCall $ unsupportedTypes lval rval
+
+ (NVStr ls lc, rs@NVSet {}) -> case op of
+ NPlus -> (\rs -> bin nvStrP (ls `mappend` Text.pack rs) lc)
+ <$> coerceToString False rs
+ NEq -> toBool =<< valueEq lval rval
+ NNEq -> toBool . not =<< valueEq lval rval
+ _ -> nverr $ ErrorCall $ unsupportedTypes lval rval
+
(NVList ls, NVList rs) -> case op of
NConcat -> pure $ bin nvListP $ ls ++ rs
NEq -> toBool =<< valueEq lval rval
@@ -420,26 +438,29 @@
toInt = pure . bin nvConstantP . NInt
toFloat = pure . bin nvConstantP . NFloat
-coerceToString :: MonadNix e m => NValue m -> m String
-coerceToString = \case
- NVConstant (NBool b)
- | b -> pure "1"
- | otherwise -> pure ""
- NVConstant (NInt n) -> pure $ show n
- NVConstant (NFloat n) -> pure $ show n
- NVConstant NNull -> pure ""
+coerceToString :: MonadNix e m => Bool -> NValue m -> m String
+coerceToString copyToStore = go
+ where
+ go = \case
+ NVConstant (NBool b)
+ | b -> pure "1"
+ | otherwise -> pure ""
+ NVConstant (NInt n) -> pure $ show n
+ NVConstant (NFloat n) -> pure $ show n
+ NVConstant NNull -> pure ""
- NVStr t _ -> pure $ Text.unpack t
- NVPath p -> unStorePath <$> addPath p
- NVList l -> unwords <$> traverse (`force` coerceToString) l
+ NVStr t _ -> pure $ Text.unpack t
+ NVPath p | copyToStore -> unStorePath <$> addPath p
+ | otherwise -> pure p
+ NVList l -> unwords <$> traverse (`force` go) l
- v@(NVSet s _) | Just p <- M.lookup "__toString" s ->
- force p $ (`callFunc` pure v) >=> coerceToString
+ v@(NVSet s _) | Just p <- M.lookup "__toString" s ->
+ force p $ (`callFunc` pure v) >=> go
- NVSet s _ | Just p <- M.lookup "outPath" s ->
- force p coerceToString
+ NVSet s _ | Just p <- M.lookup "outPath" s ->
+ force p go
- v -> throwError $ ErrorCall $ "Expected a string, but saw: " ++ show v
+ v -> throwError $ ErrorCall $ "Expected a string, but saw: " ++ show v
newtype Lazy m a = Lazy
{ runLazy :: ReaderT (Context (Lazy m) (NThunk (Lazy m)))
@@ -466,7 +487,7 @@
instance MonadThrow m => MonadThrow (Lazy m) where
throwM = Lazy . throwM
-#if MIN_VERSION_haskeline(0, 4, 7)
+#ifdef MIN_VERSION_haskeline
instance MonadException m => MonadException (Lazy m) where
controlIO f = Lazy $ controlIO $ \(RunIO run) ->
let run' = RunIO (fmap Lazy . run . runLazy)
@@ -486,6 +507,12 @@
_ -> throwError $ ErrorCall $
"addPath: failed: nix-store --add " ++ show path
+ toFile_ filepath content = do
+ liftIO $ writeFile filepath content
+ storepath <- addPath filepath
+ liftIO $ removeFile filepath
+ return storepath
+
makeAbsolutePath origPath = do
origPathExpanded <- liftIO $ expandHomePath origPath
absPath <- if isAbsolute origPathExpanded then pure origPathExpanded else do
@@ -504,6 +531,8 @@
findEnvPath = findEnvPathM
+ findPath = findPathM
+
pathExists = liftIO . fileExist
importPath scope origPath = do
@@ -572,7 +601,7 @@
"__ignoreNulls" -> pure Nothing
_ -> force v $ \case
NVConstant NNull | ignoreNulls -> pure Nothing
- v' -> Just <$> (toNix =<< Text.pack <$> coerceToString v')
+ v' -> Just <$> (toNix =<< Text.pack <$> coerceToString True v')
nixInstantiateExpr expr = do
traceM $ "Executing: "
@@ -615,12 +644,12 @@
-- return response
let status = statusCode (responseStatus response)
if status /= 200
- then throwError $ ErrorCall $
+ then throwError $ ErrorCall $
"fail, got " ++ show status ++ " when fetching url:" ++ urlstr
else -- do
-- let bstr = responseBody response
-- liftIO $ print bstr
- throwError $ ErrorCall $
+ throwError $ ErrorCall $
"success in downloading but hnix-store is not yet ready; url = " ++ urlstr
traceEffect = liftIO . putStrLn
@@ -678,50 +707,67 @@
joinPath $ head [ xs ++ drop (length tx) ys
| tx <- tails xs, tx `elem` inits ys ]
-nixFilePath :: (MonadEffects m, MonadIO m) => FilePath -> m (Maybe FilePath)
-nixFilePath path = do
- path <- makeAbsolutePath path
- exists <- liftIO $ doesDirectoryExist path
- path' <- if exists
- then makeAbsolutePath $ path "default.nix"
- else return path
- exists <- liftIO $ doesFileExist path'
- return $ if exists then Just path' else Nothing
-
-findEnvPathM :: forall e m. (MonadNix e m, MonadIO m)
- => FilePath -> m FilePath
-findEnvPathM name = do
- mres <- lookupVar @_ @(NThunk m) "__nixPath"
- mpath <- case mres of
- Nothing -> error "impossible"
- Just x -> force x $ fromValue >=> \(l :: [NThunk m]) ->
- foldM go Nothing l
+findPathBy :: forall e m. (MonadNix e m, MonadIO m) =>
+ (FilePath -> m (Maybe FilePath)) ->
+ [NThunk m] -> FilePath -> m FilePath
+findPathBy finder l name = do
+ mpath <- foldM go Nothing l
case mpath of
Nothing ->
throwError $ ErrorCall $ "file '" ++ name
++ "' was not found in the Nix search path"
++ " (add it using $NIX_PATH or -I)"
Just path -> return path
- where
- go :: Maybe FilePath -> NThunk m -> m (Maybe FilePath)
- go p@(Just _) _ = pure p
- go Nothing l = force l $ fromValue >=> \(s :: HashMap Text (NThunk m)) ->
- case M.lookup "path" s of
- Just p -> force p $ fromValue >=> \(Path path) ->
- case M.lookup "prefix" s of
- Nothing -> tryPath path Nothing
- Just pf -> force pf $ fromValueMay >=> \case
- Just (pfx :: Text) | not (Text.null pfx) ->
- tryPath path (Just (Text.unpack pfx))
- _ -> tryPath path Nothing
- Nothing ->
- throwError $ ErrorCall $ "__nixPath must be a list of attr sets"
- ++ " with 'path' elements, but saw: " ++ show s
+ where
+ go :: Maybe FilePath -> NThunk m -> m (Maybe FilePath)
+ go p@(Just _) _ = pure p
+ go Nothing l = force l $ fromValue >=>
+ \(s :: HashMap Text (NThunk m)) ->
+ case M.lookup "path" s of
+ Just p -> force p $ fromValue >=> \(Path path) ->
+ case M.lookup "prefix" s of
+ Nothing -> tryPath path Nothing
+ Just pf -> force pf $ fromValueMay >=> \case
+ Just (pfx :: Text) | not (Text.null pfx) ->
+ tryPath path (Just (Text.unpack pfx))
+ _ -> tryPath path Nothing
+ Nothing ->
+ throwError $ ErrorCall $ "__nixPath must be a list of attr sets"
+ ++ " with 'path' elements, but saw: " ++ show s
- tryPath p (Just n) | n':ns <- splitDirectories name, n == n' =
- nixFilePath $ p joinPath ns
- tryPath p _ = nixFilePath $ p name
+ tryPath p (Just n) | n':ns <- splitDirectories name, n == n' =
+ finder $ p joinPath ns
+ tryPath p _ = finder $ p name
+findPathM :: forall e m. (MonadNix e m, MonadIO m) =>
+ [NThunk m] -> FilePath -> m FilePath
+findPathM l name = findPathBy path l name
+ where
+ path :: (MonadEffects m, MonadIO m) => FilePath -> m (Maybe FilePath)
+ path path = do
+ path <- makeAbsolutePath path
+ exists <- liftIO $ doesPathExist path
+ return $ if exists then Just path else Nothing
+
+findEnvPathM :: forall e m. (MonadNix e m, MonadIO m)
+ => FilePath -> m FilePath
+findEnvPathM name = do
+ mres <- lookupVar @_ @(NThunk m) "__nixPath"
+ case mres of
+ Nothing -> error "impossible"
+ Just x -> force x $ fromValue >=> \(l :: [NThunk m]) ->
+ findPathBy nixFilePath l name
+ where
+ nixFilePath :: (MonadEffects m, MonadIO m) => FilePath -> m (Maybe FilePath)
+ nixFilePath path = do
+ path <- makeAbsolutePath path
+ exists <- liftIO $ doesDirectoryExist path
+ path' <- if exists
+ then makeAbsolutePath $ path "default.nix"
+ else return path
+ exists <- liftIO $ doesFileExist path'
+ return $ if exists then Just path' else Nothing
+
addTracing :: (MonadNix e m, Has e Options, MonadIO m,
MonadReader Int n, Alternative n)
=> Alg NExprLocF (m a) -> Alg NExprLocF (n (m a))
@@ -734,13 +780,17 @@
opts :: Options <- asks (view hasLens)
let rendered =
if verbose opts >= Chatty
- then show (void x)
- else show (prettyNix (Fix (Fix (NSym "?") <$ x)))
- msg x = "eval: " ++ replicate depth ' ' ++ x
- loc <- renderLocation span (text (msg rendered ++ " ..."))
+#ifdef MIN_VERSION_pretty_show
+ then text $ PS.ppShow (void x)
+#else
+ then text $ show (void x)
+#endif
+ else prettyNix (Fix (Fix (NSym "?") <$ x))
+ msg x = text ("eval: " ++ replicate depth ' ') <> x
+ loc <- renderLocation span (msg rendered <> text " ...\n")
liftIO $ putStr $ show loc
res <- k v'
- liftIO $ putStrLn $ msg (rendered ++ " ...done")
+ liftIO $ print $ msg rendered <> text " ...done"
return res
evalExprLoc :: forall e m. (MonadNix e m, Has e Options, MonadIO m)
diff --git a/src/Nix/Expr/Types.hs b/src/Nix/Expr/Types.hs
--- a/src/Nix/Expr/Types.hs
+++ b/src/Nix/Expr/Types.hs
@@ -27,7 +27,7 @@
-- | The nix expression type and supporting types.
module Nix.Expr.Types where
-#if MIN_VERSION_serialise(0, 2, 0)
+#ifdef MIN_VERSION_serialise
import Codec.Serialise (Serialise)
import qualified Codec.Serialise as Ser
#endif
@@ -147,7 +147,7 @@
instance NFData1 NExprF
#endif
-#if MIN_VERSION_serialise(0, 2, 0)
+#ifdef MIN_VERSION_serialise
instance Serialise r => Serialise (NExprF r)
#endif
@@ -162,12 +162,17 @@
case Reflection.typeOf b `eqTypeRep` Reflection.typeRep @Text of
Just HRefl -> Just [| pack $(liftString $ unpack b) |]
Nothing -> Nothing
+#else
+instance Lift (Fix NExprF) where
+ lift = dataToExpQ $ \b -> case cast b of
+ Just t -> Just [| pack $(liftString $ unpack t) |]
+ Nothing -> Nothing
#endif
-- | The monomorphic expression type is a fixed point of the polymorphic one.
type NExpr = Fix NExprF
-#if MIN_VERSION_serialise(0, 2, 0)
+#ifdef MIN_VERSION_serialise
instance Serialise NExpr
#endif
@@ -193,7 +198,7 @@
instance NFData1 Binding
#endif
-#if MIN_VERSION_serialise(0, 2, 0)
+#ifdef MIN_VERSION_serialise
instance Serialise r => Serialise (Binding r)
#endif
@@ -217,7 +222,7 @@
instance NFData1 Params
#endif
-#if MIN_VERSION_serialise(0, 2, 0)
+#ifdef MIN_VERSION_serialise
instance Serialise r => Serialise (Params r)
#endif
@@ -250,7 +255,7 @@
instance NFData v => NFData1 (Antiquoted v)
#endif
-#if MIN_VERSION_serialise(0, 2, 0)
+#ifdef MIN_VERSION_serialise
instance (Serialise v, Serialise r) => Serialise (Antiquoted v r)
#endif
@@ -276,7 +281,7 @@
instance NFData1 NString
#endif
-#if MIN_VERSION_serialise(0, 2, 0)
+#ifdef MIN_VERSION_serialise
instance Serialise r => Serialise (NString r)
#endif
@@ -310,7 +315,7 @@
deriving (Eq, Ord, Generic, Typeable, Data, Show, Read, NFData,
Hashable)
-#if MIN_VERSION_serialise(0, 2, 0)
+#ifdef MIN_VERSION_serialise
instance Serialise r => Serialise (NKeyName r)
instance Serialise Pos where
@@ -391,10 +396,10 @@
-- | There are two unary operations: logical not and integer negation.
data NUnaryOp = NNeg | NNot
- deriving (Eq, Ord, Generic, Typeable, Data, Show, Read, NFData,
- Hashable)
+ deriving (Eq, Ord, Enum, Bounded, Generic, Typeable, Data, Show, Read,
+ NFData, Hashable)
-#if MIN_VERSION_serialise(0, 2, 0)
+#ifdef MIN_VERSION_serialise
instance Serialise NUnaryOp
#endif
@@ -416,10 +421,10 @@
| NDiv -- ^ Division (/)
| NConcat -- ^ List concatenation (++)
| NApp -- ^ Apply a function to an argument.
- deriving (Eq, Ord, Generic, Typeable, Data, Show, Read, NFData,
- Hashable)
+ deriving (Eq, Ord, Enum, Bounded, Generic, Typeable, Data, Show, Read,
+ NFData, Hashable)
-#if MIN_VERSION_serialise(0, 2, 0)
+#ifdef MIN_VERSION_serialise
instance Serialise NBinaryOp
#endif
@@ -427,6 +432,10 @@
paramName :: Params r -> Maybe VarName
paramName (Param n) = Just n
paramName (ParamSet _ _ n) = n
+
+#if !MIN_VERSION_deepseq(1, 4, 3)
+instance NFData NExpr
+#endif
$(deriveEq1 ''NExprF)
$(deriveEq1 ''NString)
diff --git a/src/Nix/Expr/Types/Annotated.hs b/src/Nix/Expr/Types/Annotated.hs
--- a/src/Nix/Expr/Types/Annotated.hs
+++ b/src/Nix/Expr/Types/Annotated.hs
@@ -21,7 +21,7 @@
, SourcePos(..), unPos, mkPos
)where
-#if MIN_VERSION_serialise(0, 2, 0)
+#ifdef MIN_VERSION_serialise
import Codec.Serialise
#endif
import Control.DeepSeq
@@ -56,7 +56,7 @@
deriving (Ord, Eq, Generic, Typeable, Data, Show, NFData,
Hashable)
-#if MIN_VERSION_serialise(0, 2, 0)
+#ifdef MIN_VERSION_serialise
instance Serialise SrcSpan
#endif
@@ -75,7 +75,7 @@
instance Hashable ann => Hashable1 (Ann ann)
#endif
-#if MIN_VERSION_serialise(0, 2, 0)
+#ifdef MIN_VERSION_serialise
instance (Serialise ann, Serialise a) => Serialise (Ann ann a)
#endif
@@ -108,12 +108,13 @@
-- | A nix expression with source location at each subexpression.
type NExprLoc = Fix NExprLocF
-#if MIN_VERSION_hashable(1, 2, 5) && MIN_VERSION_deepseq(1, 4, 3)
--- Needs deepseq-1.4.3 because Compose requires NFData1
-instance NFData NExprLoc
+#if !MIN_VERSION_deepseq(1, 4, 3)
+instance (NFData (f (g a)), NFData (g a)) => NFData (Compose f g a)
#endif
-#if MIN_VERSION_serialise(0, 2, 0)
+instance NFData NExprLoc
+
+#ifdef MIN_VERSION_serialise
instance Serialise NExprLoc
#endif
@@ -129,7 +130,7 @@
instance ToJSON SrcSpan
instance FromJSON SrcSpan
-#if MIN_VERSION_serialise(0, 2, 0)
+#ifdef MIN_VERSION_serialise
instance Serialise r => Serialise (Compose (Ann SrcSpan) NExprF r) where
encode (Compose (Ann ann a)) = encode ann <> encode a
decode = (Compose .) . Ann <$> decode <*> decode
diff --git a/src/Nix/Options.hs b/src/Nix/Options.hs
--- a/src/Nix/Options.hs
+++ b/src/Nix/Options.hs
@@ -16,7 +16,6 @@
, finder :: Bool
, findFile :: Maybe FilePath
, strict :: Bool
- , normalize :: Bool
, evaluate :: Bool
, json :: Bool
, xml :: Bool
@@ -50,7 +49,6 @@
, finder = False
, findFile = Nothing
, strict = False
- , normalize = False
, evaluate = False
, json = False
, xml = False
diff --git a/src/Nix/Options/Parser.hs b/src/Nix/Options/Parser.hs
--- a/src/Nix/Options/Parser.hs
+++ b/src/Nix/Options/Parser.hs
@@ -70,9 +70,6 @@
( long "strict"
<> help "When used with --eval, recursively evaluate list elements and attributes")
<*> switch
- ( long "force"
- <> help "Whether to force the results of evaluation to normal form")
- <*> switch
( long "eval"
<> help "Whether to evaluate, or just pretty-print")
<*> switch
diff --git a/src/Nix/Parser.hs b/src/Nix/Parser.hs
--- a/src/Nix/Parser.hs
+++ b/src/Nix/Parser.hs
@@ -313,8 +313,11 @@
nixBinders :: Parser [Binding NExprLoc]
nixBinders = (inherit <+> namedVar) `endBy` semi where
inherit = do
- x <- reserved "inherit" *> optional scope
+ -- We can't use 'reserved' here because it would consume the whitespace
+ -- after the keyword, which is not exactly the semantics of C++ Nix.
+ try $ string "inherit" *> lookAhead (void (satisfy reservedEnd))
p <- getPosition
+ x <- whiteSpace *> optional scope
Inherit x <$> many keyName <*> pure p "inherited binding"
namedVar = do
p <- getPosition
diff --git a/src/Nix/Reduce.hs b/src/Nix/Reduce.hs
--- a/src/Nix/Reduce.hs
+++ b/src/Nix/Reduce.hs
@@ -78,31 +78,30 @@
MonadState (HashMap FilePath NExprLoc) m)
=> SrcSpan -> FilePath -> m NExprLoc
staticImport pann path = do
+ mfile <- asks fst
+ path <- liftIO $ pathToDefaultNixFile path
+ path' <- liftIO $ pathToDefaultNixFile =<< canonicalizePath
+ (maybe path (\p -> takeDirectory p path) mfile)
+
imports <- get
- case M.lookup path imports of
+ case M.lookup path' imports of
Just expr -> pure expr
- Nothing -> go
+ Nothing -> go path'
where
- go = do
- mfile <- asks fst
- path <- liftIO $ pathToDefaultNixFile path
- path' <- liftIO $ pathToDefaultNixFile =<< canonicalizePath
- (maybe path (\p -> takeDirectory p path) mfile)
-
- liftIO $ putStrLn $ "Importing file " ++ path'
+ go path = do
+ liftIO $ putStrLn $ "Importing file " ++ path
- eres <- liftIO $ parseNixFileLoc path'
+ eres <- liftIO $ parseNixFileLoc path
case eres of
Failure err -> error $ "Parse failed: " ++ show err
Success x -> do
let pos = SourcePos "Reduce.hs" (mkPos 1) (mkPos 1)
span = SrcSpan pos pos
cur = NamedVar (StaticKey "__cur_file" :| [])
- (Fix (NLiteralPath_ pann path')) pos
+ (Fix (NLiteralPath_ pann path)) pos
x' = Fix (NLet_ span [cur] x)
modify (M.insert path x')
- local (const (Just path',
- emptyScopes @m @NExprLoc)) $ do
+ local (const (Just path, emptyScopes @m @NExprLoc)) $ do
x'' <- cata reduce x'
modify (M.insert path x'')
return x''
@@ -125,10 +124,13 @@
MonadState (HashMap FilePath NExprLoc) m)
=> NExprLocF (m NExprLoc) -> m NExprLoc
+-- | Reduce the variable to its value if defined.
+-- Leave it as it is otherwise.
reduce (NSym_ ann var) = lookupVar var <&> \case
Nothing -> Fix (NSym_ ann var)
Just v -> v
+-- | Reduce binary and integer negation.
reduce (NUnary_ uann op arg) = arg >>= \x -> case (op, x) of
(NNeg, Fix (NConstant_ cann (NInt n))) ->
return $ Fix $ NConstant_ cann (NInt (negate n))
@@ -136,6 +138,12 @@
return $ Fix $ NConstant_ cann (NBool (not b))
_ -> return $ Fix $ NUnary_ uann op x
+-- | Reduce function applications.
+--
+-- * Reduce an import to the actual imported expression.
+--
+-- * Reduce a lambda function by adding its name to the local
+-- scope and recursively reducing its body.
reduce (NBinary_ bann NApp fun arg) = fun >>= \case
f@(Fix (NSym_ _ "import")) -> arg >>= \case
-- Fix (NEnvPath_ pann origPath) -> staticImport pann origPath
@@ -148,6 +156,7 @@
f -> Fix . NBinary_ bann NApp f <$> arg
+-- | Reduce an integer addition to its result.
reduce (NBinary_ bann op larg rarg) = do
lval <- larg
rval <- rarg
@@ -156,10 +165,41 @@
return $ Fix (NConstant_ ann (NInt (x + y)))
_ -> pure $ Fix $ NBinary_ bann op lval rval
--- reduce (NSelect aset attr alt) = do
+-- | Reduce a select on a Set by substituing the set to the selected value.
+--
+-- Before applying this reduction, we need to ensure that:
+--
+-- 1. The selected expr is indeed a set.
+-- 2. The selection AttrPath is a list of StaticKeys.
+-- 3. The selected AttrPath exists in the set.
+reduce base@(NSelect_ _ _ attrs _)
+ | sAttrPath $ NE.toList attrs = do
+ (NSelect_ _ aset attrs _) <- sequence base
+ inspectSet (unFix aset) attrs
+ | otherwise = sId
+ where
+ sId = Fix <$> sequence base
+ -- The selection AttrPath is composed of StaticKeys.
+ sAttrPath (StaticKey _:xs) = sAttrPath xs
+ sAttrPath [] = True
+ sAttrPath _ = False
+ -- Find appropriate bind in set's binds.
+ findBind [] _ = Nothing
+ findBind (x:xs) attrs@(a:|_) = case x of
+ n@(NamedVar (a':|_) _ _) | a' == a -> Just n
+ _ -> findBind xs attrs
+ -- Follow the attrpath recursively in sets.
+ inspectSet (NSet_ _ binds) attrs = case findBind binds attrs of
+ Just (NamedVar _ e _) -> case NE.uncons attrs of
+ (_,Just attrs) -> inspectSet (unFix e) attrs
+ _ -> pure e
+ _ -> sId
+ inspectSet _ _ = sId
-- reduce (NHasAttr aset attr) =
+-- | Reduce a set by inlining its binds outside of the set
+-- if none of the binds inherit the super set.
reduce e@(NSet_ ann binds) = do
let usesInherit = flip any binds $ \case
Inherit {} -> True
@@ -179,6 +219,8 @@
reduce (NWith_ ann scope body) =
clearScopes @NExprLoc $ fmap Fix $ NWith_ ann <$> scope <*> body
+-- | Reduce a let binds section by pushing lambdas,
+-- constants and strings to the body scope.
reduce (NLet_ ann binds body) = do
s <- fmap (M.fromList . catMaybes) $ forM binds $ \case
NamedVar (StaticKey name :| []) def _pos -> def >>= \case
@@ -203,10 +245,14 @@
-- go (M.insert name v m) xs
-- _ -> go m xs
+-- | Reduce an if to the relevant path if
+-- the condition is a boolean constant.
reduce e@(NIf_ _ b t f) = b >>= \case
Fix (NConstant_ _ (NBool b')) -> if b' then t else f
_ -> Fix <$> sequence e
+-- | Reduce an assert atom to its encapsulated
+-- symbol if the assertion is a boolean constant.
reduce e@(NAssert_ _ b body) = b >>= \case
Fix (NConstant_ _ (NBool b')) | b' -> body
_ -> Fix <$> sequence e
diff --git a/src/Nix/Render/Frame.hs b/src/Nix/Render/Frame.hs
--- a/src/Nix/Render/Frame.hs
+++ b/src/Nix/Render/Frame.hs
@@ -30,7 +30,7 @@
import Text.Megaparsec.Pos
import qualified Text.PrettyPrint.ANSI.Leijen as P
import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))
-#if MIN_VERSION_pretty_show(1, 6, 16)
+#ifdef MIN_VERSION_pretty_show
import qualified Text.Show.Pretty as PS
#endif
@@ -114,7 +114,7 @@
opts :: Options <- asks (view hasLens)
let rendered
| verbose opts >= DebugInfo =
-#if MIN_VERSION_pretty_show(1, 6, 16)
+#ifdef MIN_VERSION_pretty_show
text (PS.ppShow (stripAnnotation e))
#else
text (show (stripAnnotation e))
diff --git a/src/Nix/TH.hs b/src/Nix/TH.hs
--- a/src/Nix/TH.hs
+++ b/src/Nix/TH.hs
@@ -1,36 +1,74 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeSynonymInstances #-}
{-# OPTIONS_GHC -Wno-missing-fields #-}
module Nix.TH where
import Data.Fix
+import Data.Foldable
import Data.Generics.Aliases
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Text as Text
import Language.Haskell.TH
import Language.Haskell.TH.Quote
+import Nix.Atoms
import Nix.Expr
import Nix.Parser
quoteExprExp :: String -> ExpQ
quoteExprExp s = do
- expr <- case parseNixText (Text.pack s) of
+ expr <- case parseNixTextLoc (Text.pack s) of
Failure err -> fail $ show err
Success e -> return e
dataToExpQ (const Nothing `extQ` metaExp (freeVars expr)) expr
-freeVars :: NExpr -> Set VarName
-freeVars = error "NYI: Implement an evaluator to find free variables"
+quoteExprPat :: String -> PatQ
+quoteExprPat s = do
+ expr <- case parseNixTextLoc (Text.pack s) of
+ Failure err -> fail $ show err
+ Success e -> return e
+ dataToPatQ (const Nothing `extQ` metaPat (freeVars expr)) expr
-metaExp :: Set VarName -> NExpr -> Maybe ExpQ
-metaExp fvs (Fix (NSym x)) | x `Set.member` fvs =
- Just [| toExpr $(varE (mkName (Text.unpack x))) |]
+freeVars :: NExprLoc -> Set VarName
+freeVars = cata $ \case
+ NSym_ _ var -> Set.singleton var
+ Compose (Ann _ x) -> fold x
+
+class ToExpr a where
+ toExpr :: a -> NExprLoc
+
+instance ToExpr NExprLoc where
+ toExpr = id
+
+instance ToExpr VarName where
+ toExpr = Fix . NSym_ nullSpan
+
+instance ToExpr Int where
+ toExpr = Fix . NConstant_ nullSpan . NInt . fromIntegral
+
+instance ToExpr Integer where
+ toExpr = Fix . NConstant_ nullSpan . NInt
+
+instance ToExpr Float where
+ toExpr = Fix . NConstant_ nullSpan . NFloat
+
+metaExp :: Set VarName -> NExprLoc -> Maybe ExpQ
+metaExp fvs (Fix (NSym_ _ x)) | x `Set.member` fvs =
+ Just [| toExpr $(varE (mkName (Text.unpack x))) |]
metaExp _ _ = Nothing
+metaPat :: Set VarName -> NExprLoc -> Maybe PatQ
+metaPat fvs (Fix (NSym_ _ x)) | x `Set.member` fvs =
+ Just (varP (mkName (Text.unpack x)))
+metaPat _ _ = Nothing
+
nix :: QuasiQuoter
nix = QuasiQuoter
{ quoteExp = quoteExprExp
+ , quotePat = quoteExprPat
}
diff --git a/src/Nix/Type/Infer.hs b/src/Nix/Type/Infer.hs
--- a/src/Nix/Type/Infer.hs
+++ b/src/Nix/Type/Infer.hs
@@ -98,7 +98,7 @@
apply s (TSet b a) = TSet b (M.map (apply s) a)
apply s (TList a) = TList (map (apply s) a)
apply (Subst s) t@(TVar a) = Map.findWithDefault t a s
- apply s (t1 `TArr` t2) = apply s t1 `TArr` apply s t2
+ apply s (t1 :~> t2) = apply s t1 :~> apply s t2
apply s (TMany ts) = TMany (map (apply s) ts)
instance Substitutable Scheme where
@@ -121,12 +121,12 @@
ftv :: a -> Set.Set TVar
instance FreeTypeVars Type where
- ftv TCon{} = Set.empty
- ftv (TVar a) = Set.singleton a
- ftv (TSet _ a) = Set.unions (map ftv (M.elems a))
- ftv (TList a) = Set.unions (map ftv a)
- ftv (t1 `TArr` t2) = ftv t1 `Set.union` ftv t2
- ftv (TMany ts) = Set.unions (map ftv ts)
+ ftv TCon{} = Set.empty
+ ftv (TVar a) = Set.singleton a
+ ftv (TSet _ a) = Set.unions (map ftv (M.elems a))
+ ftv (TList a) = Set.unions (map ftv a)
+ ftv (t1 :~> t2) = ftv t1 `Set.union` ftv t2
+ ftv (TMany ts) = Set.unions (map ftv ts)
instance FreeTypeVars TVar where
ftv = Set.singleton
@@ -365,14 +365,14 @@
evalUnary op (Judgment as1 cs1 t1) = do
tv <- fresh
- return $ Judgment as1 (cs1 ++ unops (t1 `TArr` tv) op) tv
+ return $ Judgment as1 (cs1 ++ unops (t1 :~> tv) op) tv
evalBinary op (Judgment as1 cs1 t1) e2 = do
Judgment as2 cs2 t2 <- e2
tv <- fresh
return $ Judgment
(as1 `As.merge` as2)
- (cs1 ++ cs2 ++ binops (t1 `TArr` (t2 `TArr` tv)) op)
+ (cs1 ++ cs2 ++ binops (t1 :~> t2 :~> tv) op)
tv
evalWith = Eval.evalWithAttrSet
@@ -397,7 +397,7 @@
tv <- fresh
return $ Judgment
(as1 `As.merge` as2)
- (cs1 ++ cs2 ++ [EqConst t1 (t2 `TArr` tv)])
+ (cs1 ++ cs2 ++ [EqConst t1 (t2 :~> tv)])
tv
evalAbs (Param x) k = do
@@ -408,7 +408,7 @@
return $ Judgment
(as `As.remove` x)
(cs ++ [EqConst t' tv | t' <- As.lookup x as])
- (tv `TArr` t)
+ (tv :~> t)
evalAbs (ParamSet ps variadic _mname) k = do
js <- fmap concat $ forM ps $ \(name, _) -> do
@@ -432,7 +432,7 @@
(cs ++ [ EqConst t' (tys M.! x)
| x <- names
, t' <- As.lookup x as])
- (ty `TArr` t)
+ (ty :~> t)
evalError = throwError . EvaluationError
@@ -490,18 +490,18 @@
ord = zip (nub $ fv body) (map TV letters)
fv (TVar a) = [a]
- fv (TArr a b) = fv a ++ fv b
+ fv (a :~> b) = fv a ++ fv b
fv (TCon _) = []
fv (TSet _ a) = concatMap fv (M.elems a)
fv (TList a) = concatMap fv a
fv (TMany ts) = concatMap fv ts
- normtype (TArr a b) = TArr (normtype a) (normtype b)
- normtype (TCon a) = TCon a
- normtype (TSet b a) = TSet b (M.map normtype a)
- normtype (TList a) = TList (map normtype a)
- normtype (TMany ts) = TMany (map normtype ts)
- normtype (TVar a) =
+ normtype (a :~> b) = normtype a :~> normtype b
+ normtype (TCon a) = TCon a
+ normtype (TSet b a) = TSet b (M.map normtype a)
+ normtype (TList a) = TList (map normtype a)
+ normtype (TMany ts) = TMany (map normtype ts)
+ normtype (TVar a) =
case Prelude.lookup a ord of
Just x -> TVar x
Nothing -> error "type variable not in signature"
@@ -569,7 +569,7 @@
| M.keys b `intersect` M.keys s == M.keys b = return emptySubst
unifies (TSet False s) (TSet False b)
| null (M.keys b \\ M.keys s) = return emptySubst
-unifies (TArr t1 t2) (TArr t3 t4) = unifyMany [t1, t2] [t3, t4]
+unifies (t1 :~> t2) (t3 :~> t4) = unifyMany [t1, t2] [t3, t4]
unifies (TMany t1s) t2 = considering t1s >>- unifies ?? t2
unifies t1 (TMany t2s) = considering t2s >>- unifies t1
unifies t1 t2 = throwError $ UnificationFail t1 t2
diff --git a/src/Nix/Type/Type.hs b/src/Nix/Type/Type.hs
--- a/src/Nix/Type/Type.hs
+++ b/src/Nix/Type/Type.hs
@@ -12,7 +12,7 @@
| TCon String -- known type
| TSet Bool (AttrSet Type) -- heterogenous map, bool if variadic
| TList [Type] -- heterogenous list
- | TArr Type Type -- type -> type
+ | (:~>) Type Type -- type -> type
| TMany [Type] -- variant type
deriving (Show, Eq, Ord)
@@ -26,8 +26,10 @@
typeList :: Type
typeList = TList []
+infixr 1 :~>
+
typeFun :: [Type] -> Type
-typeFun = foldr1 TArr
+typeFun = foldr1 (:~>)
typeInt, typeFloat, typeBool, typeString, typePath, typeNull :: Type
typeInt = TCon "integer"
diff --git a/tests/EvalTests.hs b/tests/EvalTests.hs
--- a/tests/EvalTests.hs
+++ b/tests/EvalTests.hs
@@ -8,6 +8,7 @@
module EvalTests (tests, genEvalCompareTests) where
+import Control.Monad.Catch
import Control.Monad (when)
import Control.Monad.IO.Class
import qualified Data.HashMap.Lazy as M
@@ -30,6 +31,12 @@
case_basic_div =
constantEqualText "3" "builtins.div 6 2"
+case_zero_div = do
+ assertNixEvalThrows "builtins.div 1 0"
+ assertNixEvalThrows "builtins.div 1.0 0"
+ assertNixEvalThrows "builtins.div 1 0.0"
+ assertNixEvalThrows "builtins.div 1.0 0.0"
+
case_basic_function =
constantEqualText "2" "(a: a) 2"
@@ -88,6 +95,30 @@
case_match_failure_null =
constantEqualText "null" "builtins.match \"ab\" \"abc\""
+case_find_file_success_no_prefix =
+ constantEqualText "./tests/files/findFile.nix"
+ "builtins.findFile [{ path=\"./tests/files\"; prefix=\"\"; }] \"findFile.nix\""
+
+case_find_file_success_with_prefix =
+ constantEqualText "./tests/files/findFile.nix"
+ "builtins.findFile [{ path=\"./tests/files\"; prefix=\"nix\"; }] \"nix/findFile.nix\""
+
+case_find_file_success_folder =
+ constantEqualText "./tests/files"
+ "builtins.findFile [{ path=\"./tests\"; prefix=\"\"; }] \"files\""
+
+case_find_file_failure_not_found =
+ assertNixEvalThrows "builtins.findFile [{ path=\"./tests/files\"; prefix=\"\"; }] \"not_found.nix\""
+
+case_find_file_failure_invalid_arg_1 =
+ assertNixEvalThrows "builtins.findFile 1 \"files\""
+
+case_find_file_failure_invalid_arg_2 =
+ assertNixEvalThrows "builtins.findFile [{ path=\"./tests/files\"; prefix=\"\"; }] 2"
+
+case_find_file_failure_invalid_arg_no_path =
+ assertNixEvalThrows "builtins.findFile [{ prefix=\"\"; }] \"files\""
+
case_inherit_in_rec_set =
constantEqualText "1" "let x = 1; in (rec { inherit x; }).x"
@@ -112,7 +143,7 @@
|]
case_unsafegetattrpos1 =
- constantEqualText "[ 6 21 ]" [i|
+ constantEqualText "[ 6 20 ]" [i|
let e = 1;
f = 1;
t = {};
@@ -127,7 +158,7 @@
|]
case_unsafegetattrpos2 =
- constantEqualText "[ 6 21 ]" [i|
+ constantEqualText "[ 6 20 ]" [i|
let e = 1;
f = 1;
t = {};
@@ -239,6 +270,13 @@
in [ (fix toFixFold) (fix toFix) ]
|]
+case_fixed_points_attrsets =
+ constantEqualText "{ x = { y = { z = 100; }; z = { y = 100; }; }; }" [i|
+ let fix = f: let x = f x; in x;
+ f = self: { x.z.y = 100; x.y.z = self.x.z.y; };
+ in fix f
+ |]
+
-- jww (2018-05-02): This constantly changes!
-- case_placeholder =
-- constantEqualText
@@ -264,6 +302,7 @@
NVSetF x _ == NVSetF y _ =
M.keys x == M.keys y &&
and (zipWith (==) (M.elems x) (M.elems y))
+ NVPathF x == NVPathF y = x == y
x == y = error $ "Need to add comparison for values: "
++ show x ++ " == " ++ show y
@@ -289,3 +328,17 @@
mres <- liftIO $ lookupEnv "MATCHING_TESTS"
when (isJust mres) $
assertEvalMatchesNix b
+
+assertNixEvalThrows :: Text -> Assertion
+assertNixEvalThrows a = do
+ let Success a' = parseNixTextLoc a
+ time <- liftIO getCurrentTime
+ let opts = defaultOptions time
+ errored <- catch ((runLazyM opts $ normalForm =<< nixEvalExprLoc Nothing a') >> pure False) handler
+ if errored then
+ pure ()
+ else
+ assertFailure "Did not catch nix exception"
+ where
+ handler :: NixException -> IO Bool
+ handler _ = pure True
diff --git a/tests/Main.hs b/tests/Main.hs
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -7,11 +7,12 @@
import Control.DeepSeq
import qualified Control.Exception as Exc
+import Control.Applicative ((<|>))
import Control.Monad
import Control.Monad.IO.Class
import Data.Fix
import Data.List (isInfixOf)
-import Data.Maybe (isJust, fromMaybe)
+import Data.Maybe
import Data.String.Interpolate.IsString
import Data.Text (unpack)
import Data.Time
@@ -25,7 +26,8 @@
import qualified NixLanguageTests
import qualified ParserTests
import qualified PrettyTests
-import qualified PrettyParseTests
+import qualified ReduceExprTests
+-- import qualified PrettyParseTests
import System.Directory
import System.Environment
import System.FilePath.Glob
@@ -84,18 +86,23 @@
main = do
nixLanguageTests <- NixLanguageTests.genTests
evalComparisonTests <- EvalTests.genEvalCompareTests
- nixpkgsTestsEnv <- lookupEnv "NIXPKGS_TESTS"
- prettyTestsEnv <- lookupEnv "PRETTY_TESTS"
+ let allOrLookup var = lookupEnv "ALL_TESTS" <|> lookupEnv var
+ nixpkgsTestsEnv <- allOrLookup "NIXPKGS_TESTS"
+ -- prettyTestsEnv <- lookupEnv "PRETTY_TESTS"
+ hpackTestsEnv <- allOrLookup "HPACK_TESTS"
pwd <- getCurrentDirectory
setEnv "NIX_REMOTE" ("local?root=" ++ pwd ++ "/")
defaultMain $ testGroup "hnix" $
- [ testCase "hnix.cabal correctly generated" cabalCorrectlyGenerated ] ++
+ [ testCase "hnix.cabal correctly generated" cabalCorrectlyGenerated
+ | isJust hpackTestsEnv ] ++
[ ParserTests.tests
, EvalTests.tests
- , PrettyTests.tests ] ++
- [ PrettyParseTests.tests (read (fromMaybe "0" prettyTestsEnv)) ] ++
+ , PrettyTests.tests
+ , ReduceExprTests.tests] ++
+ -- [ PrettyParseTests.tests
+ -- (fromIntegral (read (fromMaybe "0" prettyTestsEnv) :: Int)) ] ++
[ evalComparisonTests ] ++
[ testCase "Nix language tests present" ensureLangTestsPresent
, nixLanguageTests ] ++
diff --git a/tests/PrettyParseTests.hs b/tests/PrettyParseTests.hs
--- a/tests/PrettyParseTests.hs
+++ b/tests/PrettyParseTests.hs
@@ -11,149 +11,137 @@
module PrettyParseTests where
-import Control.Monad
import Data.Algorithm.Diff
import Data.Algorithm.DiffOutput
import Data.Char
import Data.Fix
import qualified Data.List.NonEmpty as NE
import Data.Text (Text, pack)
-import Generic.Random
+import Hedgehog
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
import Nix.Atoms
import Nix.Expr
import Nix.Parser
import Nix.Pretty
-import Test.QuickCheck.Instances.Semigroup ()
-import Test.QuickCheck.Instances.Text ()
-import qualified Test.QuickCheck.Property as P
import Test.Tasty
-import Test.Tasty.QuickCheck hiding (Success, Failure)
+import Test.Tasty.Hedgehog
import Text.Megaparsec (Pos, SourcePos, mkPos)
import Text.PrettyPrint.ANSI.Leijen ((), text)
import qualified Text.PrettyPrint.ANSI.Leijen as P
import qualified Text.Show.Pretty as PS
--- Instead of using the Generic arbitrary instance (which doesn't exist anyway
--- for Text), we use a different generator which just prints sensible looking
--- variable names
-custom :: GenList '[Text]
-custom = asciiText :@ Nil
-
-asciiString :: Gen String
-asciiString = do
- n <- choose (1, 15)
- replicateM n (elements ['a'..'z'])
+asciiString :: MonadGen m => m String
+asciiString = Gen.list (Range.linear 1 15) Gen.lower
asciiText :: Gen Text
asciiText = pack <$> asciiString
-pcustom :: GenList '[Pos]
-pcustom = arbitrary :@ Nil
-
--- | This generator generates selects one of the constructors uniformly and
--- also decreases the size of the generator by dividing by the branching
--- factor. This ensures sensible termination.
-genArb :: (GArbitrary (Options 'Sized '[Text]) a, GUniformWeight a) => Gen a
-genArb = genericArbitraryWith (setGenerators custom sizedOpts) uniform
-
-- Might want to replace this instance with a constant value
-instance Arbitrary Pos where
- arbitrary = mkPos <$> (getSmall <$> arbitrary `suchThat` (> 0))
-
-instance Arbitrary (f (Fix f)) => Arbitrary (Fix f) where
- arbitrary = genArb
-
-instance Arbitrary f => Arbitrary (NString f) where
- arbitrary = genArb
-
-instance Arbitrary SourcePos where
- arbitrary = genericArbitraryWith (setGenerators pcustom sizedOpts) uniform
+genPos :: Gen Pos
+genPos = mkPos <$> Gen.int (Range.linear 1 256)
-instance Arbitrary f => Arbitrary (Binding f) where
- arbitrary = genArb
+genSourcePos :: Gen SourcePos
+genSourcePos = SourcePos <$> asciiString <*> genPos <*> genPos
-instance Arbitrary f => Arbitrary (NKeyName f) where
- arbitrary = oneof [ DynamicKey <$> arbitrary
- , StaticKey <$> asciiText ]
+genKeyName :: Gen (NKeyName NExpr)
+genKeyName = Gen.choice [ DynamicKey <$> genAntiquoted genString
+ , StaticKey <$> asciiText ]
-instance Arbitrary f => Arbitrary (Params f) where
- arbitrary =
- oneof [ Param <$> asciiText
- , ParamSet <$> listOf ((,) <$> asciiText <*> arbitrary) <*> arbitrary
- <*> oneof [pure Nothing, Just <$> asciiText]
- ]
+genAntiquoted :: Gen a -> Gen (Antiquoted a NExpr)
+genAntiquoted gen = Gen.choice
+ [ Plain <$> gen
+ , pure EscapedNewline
+ , Antiquoted <$> genExpr
+ ]
-instance Arbitrary NAtom where
- arbitrary =
- oneof [ NInt <$> arbitrary `suchThat` (>= 0)
- , NFloat <$> arbitrary `suchThat` (>= 0)
- , NBool <$> arbitrary
- , pure NNull ]
+genBinding :: Gen (Binding NExpr)
+genBinding = Gen.choice
+ [ NamedVar <$> genAttrPath <*> genExpr <*> genSourcePos
+ , Inherit <$> Gen.maybe genExpr
+ <*> Gen.list (Range.linear 0 5) genKeyName
+ <*> genSourcePos
+ ]
-instance Arbitrary NUnaryOp where
- arbitrary = genArb
+genString :: Gen (NString NExpr)
+genString = Gen.choice
+ [ DoubleQuoted <$> Gen.list (Range.linear 0 5) (genAntiquoted asciiText)
+ , Indented <$> Gen.int (Range.linear 0 10)
+ <*> Gen.list (Range.linear 0 5) (genAntiquoted asciiText)
+ ]
-instance Arbitrary NBinaryOp where
- arbitrary = genArb
+genAttrPath :: Gen (NAttrPath NExpr)
+genAttrPath = (NE.:|) <$> genKeyName
+ <*> Gen.list (Range.linear 0 4) genKeyName
-instance (Arbitrary f) => Arbitrary (Antiquoted Text f) where
- arbitrary = genArb
+genParams :: Gen (Params NExpr)
+genParams = Gen.choice
+ [ Param <$> asciiText
+ , ParamSet <$> Gen.list (Range.linear 0 10) ((,) <$> asciiText
+ <*> Gen.maybe genExpr)
+ <*> Gen.bool
+ <*> Gen.choice [pure Nothing, Just <$> asciiText]
+ ]
-instance (Arbitrary f) => Arbitrary (Antiquoted (NString f) f) where
- arbitrary = genArb
+genAtom :: Gen NAtom
+genAtom = Gen.choice
+ [ NInt <$> Gen.integral (Range.linear 0 1000)
+ , NFloat <$> Gen.float (Range.linearFrac 0.0 1000.0)
+ , NBool <$> Gen.bool
+ , pure NNull ]
-- This is written by hand so we can use `fairList` rather than the normal
-- list Arbitrary instance which makes the generator terminate. The
-- distribution is not scientifically chosen.
-instance Arbitrary f => Arbitrary (NExprF f) where
- arbitrary =
- sized $ \n ->
- if n < 2
- then oneof [genConstant, genStr, genSym, genLiteralPath, genEnvPath ]
- else
- frequency
- [ ( 1, genConstant)
- , ( 1, genSym)
- , ( 4, resize (n `div` 3) genIf)
- , (10, genRecSet )
- , (20, genSet )
- , ( 5, genList )
- , ( 2, genUnary )
- , ( 2, resize (n `div` 3) genBinary )
- , ( 3, resize (n `div` 3) genSelect )
- , (20, resize (n `div` 2) genAbs )
- , ( 2, resize (n `div` 2) genHasAttr )
- , (10, resize (n `div` 2) genLet )
- , (10, resize (n `div` 2) genWith )
- , ( 1, resize (n `div` 2) genAssert)
- ]
- where
- genConstant = NConstant <$> arbitrary
- genStr = NStr <$> arbitrary
- genSym = NSym <$> asciiText
- genList = NList <$> fairList arbitrary
- genSet = NSet <$> fairList arbitrary
- genRecSet = NRecSet <$> fairList arbitrary
- genLiteralPath = NLiteralPath . ("./" ++) <$> asciiString
- genEnvPath = NEnvPath <$> asciiString
- genUnary = NUnary <$> arbitrary <*> arbitrary
- genBinary = NBinary <$> arbitrary <*> arbitrary <*> arbitrary
- genSelect = NSelect <$> arbitrary <*> arbitrary <*> arbitrary
- genHasAttr = NHasAttr <$> arbitrary <*> arbitrary
- genAbs = NAbs <$> arbitrary <*> arbitrary
- genLet = NLet <$> fairList arbitrary <*> arbitrary
- genIf = NIf <$> arbitrary <*> arbitrary <*> arbitrary
- genWith = NWith <$> arbitrary <*> arbitrary
- genAssert = NAssert <$> arbitrary <*> arbitrary
+genExpr :: Gen NExpr
+genExpr = Gen.sized $ \(Size n) ->
+ Fix <$>
+ if n < 2
+ then Gen.choice
+ [genConstant, genStr, genSym, genLiteralPath, genEnvPath ]
+ else
+ Gen.frequency
+ [ ( 1, genConstant)
+ , ( 1, genSym)
+ , ( 4, Gen.resize (Size (n `div` 3)) genIf)
+ , (10, genRecSet )
+ , (20, genSet )
+ , ( 5, genList )
+ , ( 2, genUnary )
+ , ( 2, Gen.resize (Size (n `div` 3)) genBinary )
+ , ( 3, Gen.resize (Size (n `div` 3)) genSelect )
+ , (20, Gen.resize (Size (n `div` 2)) genAbs )
+ , ( 2, Gen.resize (Size (n `div` 2)) genHasAttr )
+ , (10, Gen.resize (Size (n `div` 2)) genLet )
+ , (10, Gen.resize (Size (n `div` 2)) genWith )
+ , ( 1, Gen.resize (Size (n `div` 2)) genAssert)
+ ]
+ where
+ genConstant = NConstant <$> genAtom
+ genStr = NStr <$> genString
+ genSym = NSym <$> asciiText
+ genList = NList <$> fairList genExpr
+ genSet = NSet <$> fairList genBinding
+ genRecSet = NRecSet <$> fairList genBinding
+ genLiteralPath = NLiteralPath . ("./" ++) <$> asciiString
+ genEnvPath = NEnvPath <$> asciiString
+ genUnary = NUnary <$> Gen.enumBounded <*> genExpr
+ genBinary = NBinary <$> Gen.enumBounded <*> genExpr <*> genExpr
+ genSelect = NSelect <$> genExpr <*> genAttrPath <*> Gen.maybe genExpr
+ genHasAttr = NHasAttr <$> genExpr <*> genAttrPath
+ genAbs = NAbs <$> genParams <*> genExpr
+ genLet = NLet <$> fairList genBinding <*> genExpr
+ genIf = NIf <$> genExpr <*> genExpr <*> genExpr
+ genWith = NWith <$> genExpr <*> genExpr
+ genAssert = NAssert <$> genExpr <*> genExpr
-- | Useful when there are recursive positions at each element of the list as
-- it divides the size by the length of the generated list.
fairList :: Gen a -> Gen [a]
-fairList g = do
- s <- getSize
- k <- choose (0, s)
+fairList g = Gen.sized $ \s -> do
+ k <- Gen.int (Range.linear 0 (unSize s))
-- Use max here to avoid dividing by zero when there is the empty list
- resize (s `div` max 1 k) $ vectorOf k g
+ Gen.resize (Size (unSize s `div` max 1 k)) $ Gen.list (Range.singleton k) g
equivUpToNormalization :: NExpr -> NExpr -> Bool
equivUpToNormalization x y = normalize x == normalize y
@@ -198,38 +186,38 @@
normParams r = r
-- | Test that parse . pretty == id up to attribute position information.
-prop_prettyparse :: NExpr -> P.Result
-prop_prettyparse p =
+prop_prettyparse :: Monad m => NExpr -> PropertyT m ()
+prop_prettyparse p = do
let prog = show (pretty p)
- in case parse (pack prog) of
- Failure s -> P.rejected
- { P.reason = show $
+ case parse (pack prog) of
+ Failure s -> do
+ footnote $ show $
text "Parse failed:" text (show s)
- P.<$> P.indent 2 (pretty p) }
+ P.<$> P.indent 2 (pretty p)
+ discard
Success v
- | equivUpToNormalization p v -> P.succeeded
- | otherwise ->
+ | equivUpToNormalization p v -> success
+ | otherwise -> do
let pp = normalise prog
pv = normalise (show (pretty v))
- in (P.liftBool (pp == pv))
- { P.reason = show $
- text "----------------------------------------"
- P.<$> text "Expr before:" P.<$> P.indent 2 (text (PS.ppShow p))
- P.<$> text "----------------------------------------"
- P.<$> text "Expr after:" P.<$> P.indent 2 (text (PS.ppShow v))
- P.<$> text "----------------------------------------"
- P.<$> text "Pretty before:" P.<$> P.indent 2 (text prog)
- P.<$> text "----------------------------------------"
- P.<$> text "Pretty after:" P.<$> P.indent 2 (pretty v)
- P.<$> text "----------------------------------------"
- P.<$> text "Normalised before:" P.<$> P.indent 2 (text pp)
- P.<$> text "----------------------------------------"
- P.<$> text "Normalised after:" P.<$> P.indent 2 (text pv)
- P.<$> text "========================================"
- P.<$> text "Normalised diff:"
- P.<$> text (ppDiff (diff pp pv))
- P.<$> text "========================================"
- }
+ footnote $ show $
+ text "----------------------------------------"
+ P.<$> text "Expr before:" P.<$> P.indent 2 (text (PS.ppShow p))
+ P.<$> text "----------------------------------------"
+ P.<$> text "Expr after:" P.<$> P.indent 2 (text (PS.ppShow v))
+ P.<$> text "----------------------------------------"
+ P.<$> text "Pretty before:" P.<$> P.indent 2 (text prog)
+ P.<$> text "----------------------------------------"
+ P.<$> text "Pretty after:" P.<$> P.indent 2 (pretty v)
+ P.<$> text "----------------------------------------"
+ P.<$> text "Normalised before:" P.<$> P.indent 2 (text pp)
+ P.<$> text "----------------------------------------"
+ P.<$> text "Normalised after:" P.<$> P.indent 2 (text pv)
+ P.<$> text "========================================"
+ P.<$> text "Normalised diff:"
+ P.<$> text (ppDiff (diff pp pv))
+ P.<$> text "========================================"
+ assert (pp == pv)
where
pretty = prettyNix
parse = parseNixText
@@ -239,6 +227,7 @@
diff :: String -> String -> [Diff [String]]
diff s1 s2 = getDiff (map (:[]) (lines s1)) (map (:[]) (lines s2))
-tests :: Int -> TestTree
-tests n = testProperty "Pretty/Parse Property" $
- withMaxSuccess n prop_prettyparse
+tests :: TestLimit -> TestTree
+tests n = testProperty "Pretty/Parse Property" $ withTests n $ property $ do
+ x <- forAll genExpr
+ prop_prettyparse x
diff --git a/tests/ReduceExprTests.hs b/tests/ReduceExprTests.hs
new file mode 100644
--- /dev/null
+++ b/tests/ReduceExprTests.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+module ReduceExprTests (tests) where
+import Data.Fix
+import Test.Tasty
+import Test.Tasty.HUnit
+
+import Nix.Atoms
+import Nix.Expr.Types
+import Nix.Expr.Types.Annotated
+import Nix.Parser
+import Nix.Reduce (reduceExpr)
+
+
+tests :: TestTree
+tests = testGroup "Expr Reductions"
+ [ testCase "Non nested NSelect on set should be reduced" $
+ cmpReduceResult selectBasic selectBasicExpect,
+ testCase "Nested NSelect on set should be reduced" $
+ cmpReduceResult selectNested selectNestedExpect,
+ testCase "Non nested NSelect with incorrect attrpath shouldn't be reduced" $
+ shouldntReduce selectIncorrectAttrPath,
+ testCase "Nested NSelect with incorrect attrpath shouldn't be reduced" $
+ shouldntReduce selectNestedIncorrectAttrPath
+ ]
+
+assertSucc :: Result a -> IO a
+assertSucc (Success a) = pure a
+assertSucc (Failure d) = assertFailure $ show d
+
+cmpReduceResult :: Result NExprLoc -> NExpr -> Assertion
+cmpReduceResult r e = do
+ r <- assertSucc r
+ r <- stripAnnotation <$> reduceExpr Nothing r
+ r @?= e
+
+shouldntReduce :: Result NExprLoc -> Assertion
+shouldntReduce r = do
+ r <- assertSucc r
+ rReduced <- reduceExpr Nothing r
+ r @?= rReduced
+
+selectBasic :: Result NExprLoc
+selectBasic = parseNixTextLoc "{b=2;a=42;}.a"
+
+selectBasicExpect :: NExpr
+selectBasicExpect = Fix . NConstant $ NInt 42
+
+selectNested :: Result NExprLoc
+selectNested = parseNixTextLoc "{a={b=2;a=42;};b={a=2;};}.a.a"
+
+selectNestedExpect :: NExpr
+selectNestedExpect = Fix . NConstant $ NInt 42
+
+selectIncorrectAttrPath :: Result NExprLoc
+selectIncorrectAttrPath = parseNixTextLoc "{a=42;}.b"
+
+selectNestedIncorrectAttrPath :: Result NExprLoc
+selectNestedIncorrectAttrPath = parseNixTextLoc "{a={a=42;};}.a.b"