hnix 0.5.1 → 0.5.2

raw patch · 25 files changed

+800/−492 lines, 25 filesdep +compactdep +ghc-datasizedep +hedgehogdep −QuickCheckdep −quickcheck-instancesdep ~deriving-compatdep ~lens-familydep ~lens-family-corePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: compact, ghc-datasize, hedgehog, tasty-hedgehog

Dependencies removed: QuickCheck, quickcheck-instances

Dependency ranges changed: deriving-compat, lens-family, lens-family-core, megaparsec

API changes (from Hackage documentation)

Files

• README.md +19/−5
• hnix.cabal +51/−11
• main/Main.hs +1/−1
• main/Repl.hs +1/−1
• package.yaml +32/−23
• src/Nix/Atoms.hs +2/−2
• src/Nix/Builtins.hs +72/−20
• src/Nix/Cache.hs +3/−3
• src/Nix/Effects.hs +7/−0
• src/Nix/Eval.hs +82/−148
• src/Nix/Exec.hs +112/−62
• src/Nix/Expr/Types.hs +23/−14
• src/Nix/Expr/Types/Annotated.hs +9/−8
• src/Nix/Options.hs +0/−2
• src/Nix/Options/Parser.hs +0/−3
• src/Nix/Parser.hs +4/−1
• src/Nix/Reduce.hs +60/−14
• src/Nix/Render/Frame.hs +2/−2
• src/Nix/TH.hs +44/−6
• src/Nix/Type/Infer.hs +20/−20
• src/Nix/Type/Type.hs +4/−2
• tests/EvalTests.hs +55/−2
• tests/Main.hs +14/−7
• tests/PrettyParseTests.hs +124/−135
• tests/ReduceExprTests.hs +59/−0

@@ -2,6 +2,7 @@  [![Build Status](https://api.travis-ci.org/haskell-nix/hnix.svg)](https://travis-ci.org/haskell-nix/hnix) [![Chat](https://badges.gitter.im/Join%20Chat.svg)](https://gitter.im/haskell-nix/Lobby)+<sup>([Hackage Matrix Builder](https://matrix.hackage.haskell.org/package/hnix))</sup>  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 <args> +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 <args> +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 

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

@@ -144,7 +144,7 @@                      . A.encodingToLazyByteString                      . toEncodingSorted                      <=< fromNix-            | normalize opts =+            | strict opts =               liftIO . print . prettyNValueNF <=< normalForm             | values opts  =               liftIO . print <=< prettyNValueProv

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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