diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,37 @@ # ChangeLog +## [(diff)](https://github.com/haskell-nix/hnix/compare/0.15.0...0.16.0#files_bucket) 0.16.0 + +On update problems, please reach out to us. For support refere to: https://github.com/haskell-nix/hnix/issues/984 + +Partial log (for now): + +* Breaking: + * Where `coerce` should work, removed `newtype` accessors. + * [(link)](https://github.com/haskell-nix/hnix/pull/1006/files), [(link)](https://github.com/haskell-nix/hnix/pull/1009/files) Incomprehensible record accessors zoo like: `arg`, `options`, `unStore`, `scFlavor`, `nsContext` `_provenance` - was organized, now all record accessors start with `get*`, and their names tend to have according unique sematic meaning of data action they do. + * Builder names got unified. Now they all start with `mk*`. So a lof of `nvSet` became `mkNVSet`. + * `Nix.String` builders/destructors instead of `make` use `mk`, & where mentioning of `string` is superflous - dropped it from the name, so `stringIgnoreContext`, became `ignoreContext`. + * Type system: + * Things that are paths are now `newtype Path = Path String`. + * Things that are indentifier names are now `newtype VarName = VarName Text`. + * Function signatures changed accordingly. + +* Additional: + * [(link)](https://github.com/haskell-nix/hnix/pull/1019) Matched expression escaping & its representation to breaking changes in Nix `2.4`. + * `Builtins` (`builtins` function set) gained functions: + * [(link)](https://github.com/haskell-nix/hnix/pull/1032) `path` + * [(link)](https://github.com/haskell-nix/hnix/pull/1020) `isPathNix` + * [(link)](https://github.com/haskell-nix/hnix/pull/1032) `unsafeDiscardOutputDependency` + * [(link)](https://github.com/haskell-nix/hnix/pull/1031) `ceil` + * [(link)](https://github.com/haskell-nix/hnix/pull/1031) `floor` + * [(link)](https://github.com/haskell-nix/hnix/pull/1021) `hashFile` + * [(link)](https://github.com/haskell-nix/hnix/pull/1033) `groupBy` + * [(link)](https://github.com/haskell-nix/hnix/pull/1029) `data/nix` submodule (& its tests) updated to 2022-01-17. + +* Other notes: + * `Shorthands` was kept untouched. + ## [(diff)](https://github.com/haskell-nix/hnix/compare/0.14.0...0.15.0#files_bucket) 0.15.0 For support refere to: https://github.com/haskell-nix/hnix/issues/984 diff --git a/benchmarks/Main.hs b/benchmarks/Main.hs --- a/benchmarks/Main.hs +++ b/benchmarks/Main.hs @@ -1,5 +1,6 @@ module Main where +import Nix.Prelude import Criterion.Main import qualified ParserBench diff --git a/benchmarks/ParserBench.hs b/benchmarks/ParserBench.hs --- a/benchmarks/ParserBench.hs +++ b/benchmarks/ParserBench.hs @@ -1,5 +1,6 @@ module ParserBench (benchmarks) where +import Nix.Prelude import Nix.Parser import Criterion diff --git a/data/nix/corepkgs/buildenv.nix b/data/nix/corepkgs/buildenv.nix deleted file mode 100644 --- a/data/nix/corepkgs/buildenv.nix +++ /dev/null @@ -1,25 +0,0 @@ -{ derivations, manifest }: - -derivation { - name = "user-environment"; - system = "builtin"; - builder = "builtin:buildenv"; - - inherit manifest; - - # !!! grmbl, need structured data for passing this in a clean way. - derivations = - map (d: - [ (d.meta.active or "true") - (d.meta.priority or 5) - (builtins.length d.outputs) - ] ++ map (output: builtins.getAttr output d) d.outputs) - derivations; - - # Building user environments remotely just causes huge amounts of - # network traffic, so don't do that. - preferLocalBuild = true; - - # Also don't bother substituting. - allowSubstitutes = false; -} diff --git a/data/nix/corepkgs/derivation.nix b/data/nix/corepkgs/derivation.nix deleted file mode 100644 --- a/data/nix/corepkgs/derivation.nix +++ /dev/null @@ -1,27 +0,0 @@ -/* 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 diff --git a/data/nix/corepkgs/fetchurl.nix b/data/nix/corepkgs/fetchurl.nix deleted file mode 100644 --- a/data/nix/corepkgs/fetchurl.nix +++ /dev/null @@ -1,41 +0,0 @@ -{ system ? "" # obsolete -, url -, hash ? "" # an SRI ash - -# Legacy hash specification -, md5 ? "", sha1 ? "", sha256 ? "", sha512 ? "" -, outputHash ? - if hash != "" then hash else if sha512 != "" then sha512 else if sha1 != "" then sha1 else if md5 != "" then md5 else sha256 -, outputHashAlgo ? - if hash != "" then "" else if sha512 != "" then "sha512" else if sha1 != "" then "sha1" else if md5 != "" then "md5" else "sha256" - -, executable ? false -, unpack ? false -, name ? baseNameOf (toString url) -}: - -derivation { - builder = "builtin:fetchurl"; - - # New-style output content requirements. - inherit outputHashAlgo outputHash; - outputHashMode = if unpack || executable then "recursive" else "flat"; - - inherit name url executable unpack; - - system = "builtin"; - - # No need to double the amount of network traffic - preferLocalBuild = true; - - impureEnvVars = [ - # We borrow these environment variables from the caller to allow - # easy proxy configuration. This is impure, but a fixed-output - # derivation like fetchurl is allowed to do so since its result is - # by definition pure. - "http_proxy" "https_proxy" "ftp_proxy" "all_proxy" "no_proxy" - ]; - - # To make "nix-prefetch-url" work. - urls = [ url ]; -} diff --git a/data/nix/corepkgs/imported-drv-to-derivation.nix b/data/nix/corepkgs/imported-drv-to-derivation.nix deleted file mode 100644 --- a/data/nix/corepkgs/imported-drv-to-derivation.nix +++ /dev/null @@ -1,21 +0,0 @@ -attrs @ { drvPath, outputs, name, ... }: - -let - - commonAttrs = (builtins.listToAttrs outputsList) // - { all = map (x: x.value) outputsList; - inherit drvPath name; - type = "derivation"; - }; - - outputToAttrListElement = outputName: - { name = outputName; - value = commonAttrs // { - outPath = builtins.getAttr outputName attrs; - inherit outputName; - }; - }; - - outputsList = map outputToAttrListElement outputs; - -in (builtins.head outputsList).value diff --git a/data/nix/corepkgs/unpack-channel.nix b/data/nix/corepkgs/unpack-channel.nix deleted file mode 100644 --- a/data/nix/corepkgs/unpack-channel.nix +++ /dev/null @@ -1,39 +0,0 @@ -with import ; - -let - - builder = builtins.toFile "unpack-channel.sh" - '' - mkdir $out - cd $out - xzpat="\.xz\$" - gzpat="\.gz\$" - if [[ "$src" =~ $xzpat ]]; then - ${xz} -d < $src | ${tar} xf - ${tarFlags} - elif [[ "$src" =~ $gzpat ]]; then - ${gzip} -d < $src | ${tar} xf - ${tarFlags} - else - ${bzip2} -d < $src | ${tar} xf - ${tarFlags} - fi - if [ * != $channelName ]; then - mv * $out/$channelName - fi - ''; - -in - -{ name, channelName, src }: - -derivation { - system = builtins.currentSystem; - builder = shell; - args = [ "-e" builder ]; - inherit name channelName src; - - PATH = "${nixBinDir}:${coreutils}"; - - # No point in doing this remotely. - preferLocalBuild = true; - - inherit chrootDeps; -} diff --git a/data/nix/tests/lang/eval-fail-antiquoted-path.nix b/data/nix/tests/lang/eval-fail-antiquoted-path.nix deleted file mode 100644 --- a/data/nix/tests/lang/eval-fail-antiquoted-path.nix +++ /dev/null @@ -1,4 +0,0 @@ -# This must fail to evaluate, since ./fnord doesn't exist. If it did -# exist, it would produce "/nix/store/-fnord/xyzzy" (with an -# appropriate context). -"${./fnord}/xyzzy" diff --git a/data/nix/tests/lang/eval-okay-ind-string.exp b/data/nix/tests/lang/eval-okay-ind-string.exp --- a/data/nix/tests/lang/eval-okay-ind-string.exp +++ b/data/nix/tests/lang/eval-okay-ind-string.exp @@ -1,1 +1,1 @@ -"This is an indented multi-line string\nliteral. An amount of whitespace at\nthe start of each line matching the minimum\nindentation of all lines in the string\nliteral together will be removed. Thus,\nin this case four spaces will be\nstripped from each line, even though\n THIS LINE is indented six spaces.\n\nAlso, empty lines don't count in the\ndetermination of the indentation level (the\nprevious empty line has indentation 0, but\nit doesn't matter).\nIf the string starts with whitespace\n followed by a newline, it's stripped, but\n that's not the case here. Two spaces are\n stripped because of the \" \" at the start. \nThis line is indented\na bit further.\nAnti-quotations, like so, are\nalso allowed.\n The \\ is not special here.\n' can be followed by any character except another ', e.g. 'x'.\nLikewise for $, e.g. $$ or $varName.\nBut ' followed by ' is special, as is $ followed by {.\nIf you want them, use anti-quotations: '', ${.\n Tabs are not interpreted as whitespace (since we can't guess\n what tab settings are intended), so don't use them.\n\tThis line starts with a space and a tab, so only one\n space will be stripped from each line.\nAlso note that if the last line (just before the closing ' ')\nconsists only of whitespace, it's ignored. But here there is\nsome non-whitespace stuff, so the line isn't removed. \nThis shows a hacky way to preserve an empty line after the start.\nBut there's no reason to do so: you could just repeat the empty\nline.\n Similarly you can force an indentation level,\n in this case to 2 spaces. This works because the anti-quote\n is significant (not whitespace).\nstart on network-interfaces\n\nstart script\n\n rm -f /var/run/opengl-driver\n ln -sf 123 /var/run/opengl-driver\n\n rm -f /var/log/slim.log\n \nend script\n\nenv SLIM_CFGFILE=abc\nenv SLIM_THEMESDIR=def\nenv FONTCONFIG_FILE=/etc/fonts/fonts.conf \t\t\t\t# !!! cleanup\nenv XKB_BINDIR=foo/bin \t\t\t\t# Needed for the Xkb extension.\nenv LD_LIBRARY_PATH=libX11/lib:libXext/lib:/usr/lib/ # related to xorg-sys-opengl - needed to load libglx for (AI)GLX support (for compiz)\n\nenv XORG_DRI_DRIVER_PATH=nvidiaDrivers/X11R6/lib/modules/drivers/ \n\nexec slim/bin/slim\nEscaping of ' followed by ': ''\nEscaping of $ followed by {: ${\nAnd finally to interpret \\n etc. as in a string: \n, \r, \t.\nfoo\n'bla'\nbar\ncut -d $'\\t' -f 1\nending dollar $$\n" +"This is an indented multi-line string\nliteral. An amount of whitespace at\nthe start of each line matching the minimum\nindentation of all lines in the string\nliteral together will be removed. Thus,\nin this case four spaces will be\nstripped from each line, even though\n THIS LINE is indented six spaces.\n\nAlso, empty lines don't count in the\ndetermination of the indentation level (the\nprevious empty line has indentation 0, but\nit doesn't matter).\nIf the string starts with whitespace\n followed by a newline, it's stripped, but\n that's not the case here. Two spaces are\n stripped because of the \" \" at the start. \nThis line is indented\na bit further.\nAnti-quotations, like so, are\nalso allowed.\n The \\ is not special here.\n' can be followed by any character except another ', e.g. 'x'.\nLikewise for $, e.g. $$ or $varName.\nBut ' followed by ' is special, as is $ followed by {.\nIf you want them, use anti-quotations: '', \${.\n Tabs are not interpreted as whitespace (since we can't guess\n what tab settings are intended), so don't use them.\n\tThis line starts with a space and a tab, so only one\n space will be stripped from each line.\nAlso note that if the last line (just before the closing ' ')\nconsists only of whitespace, it's ignored. But here there is\nsome non-whitespace stuff, so the line isn't removed. \nThis shows a hacky way to preserve an empty line after the start.\nBut there's no reason to do so: you could just repeat the empty\nline.\n Similarly you can force an indentation level,\n in this case to 2 spaces. This works because the anti-quote\n is significant (not whitespace).\nstart on network-interfaces\n\nstart script\n\n rm -f /var/run/opengl-driver\n ln -sf 123 /var/run/opengl-driver\n\n rm -f /var/log/slim.log\n \nend script\n\nenv SLIM_CFGFILE=abc\nenv SLIM_THEMESDIR=def\nenv FONTCONFIG_FILE=/etc/fonts/fonts.conf \t\t\t\t# !!! cleanup\nenv XKB_BINDIR=foo/bin \t\t\t\t# Needed for the Xkb extension.\nenv LD_LIBRARY_PATH=libX11/lib:libXext/lib:/usr/lib/ # related to xorg-sys-opengl - needed to load libglx for (AI)GLX support (for compiz)\n\nenv XORG_DRI_DRIVER_PATH=nvidiaDrivers/X11R6/lib/modules/drivers/ \n\nexec slim/bin/slim\nEscaping of ' followed by ': ''\nEscaping of $ followed by {: \${\nAnd finally to interpret \\n etc. as in a string: \n, \r, \t.\nfoo\n'bla'\nbar\ncut -d $'\\t' -f 1\nending dollar $$\n" diff --git a/data/nix/tests/lang/eval-okay-search-path.nix b/data/nix/tests/lang/eval-okay-search-path.nix --- a/data/nix/tests/lang/eval-okay-search-path.nix +++ b/data/nix/tests/lang/eval-okay-search-path.nix @@ -1,10 +1,9 @@ with import ./lib.nix; with builtins; -assert pathExists ; +assert isFunction (import ); -assert length __nixPath == 6; -assert length (filter (x: x.prefix == "nix") __nixPath) == 1; +assert length __nixPath == 5; assert length (filter (x: baseNameOf x.path == "dir4") __nixPath) == 1; import + import + import + import diff --git a/data/nix/tests/lang/eval-okay-sort.exp b/data/nix/tests/lang/eval-okay-sort.exp --- a/data/nix/tests/lang/eval-okay-sort.exp +++ b/data/nix/tests/lang/eval-okay-sort.exp @@ -1,1 +1,1 @@ -[ [ 42 77 147 249 483 526 ] [ 526 483 249 147 77 42 ] [ "bar" "fnord" "foo" "xyzzy" ] [ { key = 1; value = "foo"; } { key = 1; value = "fnord"; } { key = 2; value = "bar"; } ] ] +[ [ 42 77 147 249 483 526 ] [ 526 483 249 147 77 42 ] [ "bar" "fnord" "foo" "xyzzy" ] [ { key = 1; value = "foo"; } { key = 1; value = "fnord"; } { key = 2; value = "bar"; } ] [ [ ] [ ] [ 1 ] [ 1 4 ] [ 1 5 ] [ 1 6 ] [ 2 ] [ 2 3 ] [ 3 ] [ 3 ] ] ] diff --git a/data/nix/tests/lang/eval-okay-sort.nix b/data/nix/tests/lang/eval-okay-sort.nix --- a/data/nix/tests/lang/eval-okay-sort.nix +++ b/data/nix/tests/lang/eval-okay-sort.nix @@ -4,5 +4,17 @@ (sort (x: y: y < x) [ 483 249 526 147 42 77 ]) (sort lessThan [ "foo" "bar" "xyzzy" "fnord" ]) (sort (x: y: x.key < y.key) - [ { key = 1; value = "foo"; } { key = 2; value = "bar"; } { key = 1; value = "fnord"; } ]) + [ { key = 1; value = "foo"; } { key = 2; value = "bar"; } { key = 1; value = "fnord"; } ]) + (sort lessThan [ + [ 1 6 ] + [ ] + [ 2 3 ] + [ 3 ] + [ 1 5 ] + [ 2 ] + [ 1 ] + [ ] + [ 1 4 ] + [ 3 ] + ]) ] diff --git a/data/nix/tests/lang/eval-okay-tojson.exp b/data/nix/tests/lang/eval-okay-tojson.exp --- a/data/nix/tests/lang/eval-okay-tojson.exp +++ b/data/nix/tests/lang/eval-okay-tojson.exp @@ -1,1 +1,1 @@ -"{\"a\":123,\"b\":-456,\"c\":\"foo\",\"d\":\"foo\\n\\\"bar\\\"\",\"e\":true,\"f\":false,\"g\":[1,2,3],\"h\":[\"a\",[\"b\",{\"foo\\nbar\":{}}]],\"i\":3,\"j\":1.44}" +"{\"a\":123,\"b\":-456,\"c\":\"foo\",\"d\":\"foo\\n\\\"bar\\\"\",\"e\":true,\"f\":false,\"g\":[1,2,3],\"h\":[\"a\",[\"b\",{\"foo\\nbar\":{}}]],\"i\":3,\"j\":1.44,\"k\":\"foo\"}" diff --git a/data/nix/tests/lang/eval-okay-tojson.nix b/data/nix/tests/lang/eval-okay-tojson.nix --- a/data/nix/tests/lang/eval-okay-tojson.nix +++ b/data/nix/tests/lang/eval-okay-tojson.nix @@ -9,4 +9,5 @@ h = [ "a" [ "b" { "foo\nbar" = {}; } ] ]; i = 1 + 2; j = 1.44; + k = { __toString = self: self.a; a = "foo"; }; } diff --git a/data/nix/tests/lang/parse-okay-url.nix b/data/nix/tests/lang/parse-okay-url.nix --- a/data/nix/tests/lang/parse-okay-url.nix +++ b/data/nix/tests/lang/parse-okay-url.nix @@ -3,5 +3,6 @@ http://www2.mplayerhq.hu/MPlayer/releases/fonts/font-arial-iso-8859-1.tar.bz2 http://losser.st-lab.cs.uu.nl/~armijn/.nix/gcc-3.3.4-static-nix.tar.gz http://fpdownload.macromedia.com/get/shockwave/flash/english/linux/7.0r25/install_flash_player_7_linux.tar.gz + https://ftp5.gwdg.de/pub/linux/archlinux/extra/os/x86_64/unzip-6.0-14-x86_64.pkg.tar.zst ftp://ftp.gtk.org/pub/gtk/v1.2/gtk+-1.2.10.tar.gz ] diff --git a/data/nix/tests/local.mk b/data/nix/tests/local.mk --- a/data/nix/tests/local.mk +++ b/data/nix/tests/local.mk @@ -1,42 +1,77 @@ -check: - @echo "Warning: Nix has no 'make check'. Please install Nix and run 'make installcheck' instead." - nix_tests = \ - init.sh hash.sh lang.sh add.sh simple.sh dependencies.sh \ + hash.sh lang.sh add.sh simple.sh dependencies.sh \ + config.sh \ gc.sh \ + ca/gc.sh \ gc-concurrent.sh \ + gc-non-blocking.sh \ gc-auto.sh \ referrers.sh user-envs.sh logging.sh nix-build.sh misc.sh fixed.sh \ gc-runtime.sh check-refs.sh filter-source.sh \ - remote-store.sh export.sh export-graph.sh \ + local-store.sh remote-store.sh export.sh export-graph.sh \ + db-migration.sh \ timeout.sh secure-drv-outputs.sh nix-channel.sh \ - multiple-outputs.sh import-derivation.sh fetchurl.sh optimise-store.sh \ - binary-cache.sh nix-profile.sh repair.sh dump-db.sh case-hack.sh \ + multiple-outputs.sh import-derivation.sh ca/import-derivation.sh fetchurl.sh optimise-store.sh \ + binary-cache.sh \ + substitute-with-invalid-ca.sh \ + binary-cache-build-remote.sh \ + nix-profile.sh repair.sh dump-db.sh case-hack.sh \ check-reqs.sh pass-as-file.sh tarball.sh restricted.sh \ placeholders.sh nix-shell.sh \ linux-sandbox.sh \ build-dry.sh \ - build-remote.sh \ + build-remote-input-addressed.sh \ + build-remote-content-addressed-fixed.sh \ + build-remote-content-addressed-floating.sh \ + ssh-relay.sh \ nar-access.sh \ structured-attrs.sh \ fetchGit.sh \ + fetchGitRefs.sh \ + fetchGitSubmodules.sh \ fetchMercurial.sh \ signing.sh \ - run.sh \ + shell.sh \ brotli.sh \ + zstd.sh \ + compression-levels.sh \ pure-eval.sh \ check.sh \ plugins.sh \ search.sh \ nix-copy-ssh.sh \ post-hook.sh \ - function-trace.sh + ca/post-hook.sh \ + function-trace.sh \ + recursive.sh \ + describe-stores.sh \ + flakes.sh \ + flake-local-settings.sh \ + flake-searching.sh \ + build.sh \ + repl.sh ca/repl.sh \ + ca/build.sh \ + ca/build-with-garbage-path.sh \ + ca/duplicate-realisation-in-closure.sh \ + ca/substitute.sh \ + ca/signatures.sh \ + ca/nix-shell.sh \ + ca/nix-run.sh \ + ca/recursive.sh \ + ca/concurrent-builds.sh \ + ca/nix-copy.sh \ + eval-store.sh \ + readfile-context.sh # parallel.sh +ifeq ($(HAVE_LIBCPUID), 1) + nix_tests += compute-levels.sh +endif + install-tests += $(foreach x, $(nix_tests), tests/$(x)) tests-environment = NIX_REMOTE= $(bash) -e -clean-files += $(d)/common.sh +clean-files += $(d)/common.sh $(d)/config.nix $(d)/ca/config.nix -installcheck: $(d)/common.sh $(d)/plugins/libplugintest.$(SO_EXT) +test-deps += tests/common.sh tests/config.nix tests/ca/config.nix tests/plugins/libplugintest.$(SO_EXT) diff --git a/hnix.cabal b/hnix.cabal --- a/hnix.cabal +++ b/hnix.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: hnix -version: 0.15.0 +version: 0.16.0 synopsis: Haskell implementation of the Nix language description: Haskell implementation of the Nix language. category: System, Data, Nix @@ -12,21 +12,10 @@ license-file: License build-type: Simple data-dir: data/ -data-files: - nix/corepkgs/buildenv.nix - nix/corepkgs/unpack-channel.nix - nix/corepkgs/derivation.nix - nix/corepkgs/fetchurl.nix - nix/corepkgs/imported-drv-to-derivation.nix extra-source-files: ChangeLog.md ReadMe.md License - data/nix/corepkgs/buildenv.nix - data/nix/corepkgs/unpack-channel.nix - data/nix/corepkgs/derivation.nix - data/nix/corepkgs/fetchurl.nix - data/nix/corepkgs/imported-drv-to-derivation.nix data/nix/tests/lang/binary-data data/nix/tests/lang/data data/nix/tests/lang/dir1/a.nix @@ -38,7 +27,6 @@ data/nix/tests/lang/dir4/a.nix data/nix/tests/lang/dir4/c.nix data/nix/tests/lang/eval-fail-abort.nix - data/nix/tests/lang/eval-fail-antiquoted-path.nix data/nix/tests/lang/eval-fail-assert.nix data/nix/tests/lang/eval-fail-bad-antiquote-1.nix data/nix/tests/lang/eval-fail-bad-antiquote-2.nix @@ -341,8 +329,8 @@ library exposed-modules: - Prelude Nix + Nix.Prelude Nix.Utils Nix.Atoms Nix.Builtins @@ -398,16 +386,13 @@ Paths_hnix hs-source-dirs: src - mixins: - base hiding (Prelude) - , relude ghc-options: -Wall -fprint-potential-instances build-depends: aeson >= 1.4.2 && < 1.6 || >= 2.0 && < 2.1 , array >= 0.4 && < 0.6 - , base >= 4.12 && < 5 + , base >= 4.12 && < 4.16 , base16-bytestring >= 0.1.1 && < 1.1 , binary >= 0.8.5 && < 0.9 , bytestring >= 0.10.8 && < 0.12 @@ -422,7 +407,7 @@ , filepath >= 1.4.2 && < 1.5 , free >= 5.1 && < 5.2 , gitrev >= 1.1.0 && < 1.4 - , hashable >= 1.2.5 && < 1.4 + , hashable >= 1.2.5 && < 1.5 , hashing >= 0.1.0 && < 0.2 , hnix-store-core >= 0.5.0 && < 0.6 , hnix-store-remote >= 0.5.0 && < 0.6 @@ -469,7 +454,8 @@ , vector >= 0.12.0 && < 0.13 , xml >= 1.3.14 && < 1.4 default-extensions: - OverloadedStrings + NoImplicitPrelude + , OverloadedStrings , DeriveGeneric , DeriveDataTypeable , DeriveFunctor @@ -532,11 +518,9 @@ , serialise , template-haskell , time - mixins: - base hiding (Prelude) - , relude default-extensions: - OverloadedStrings + NoImplicitPrelude + , OverloadedStrings , DeriveGeneric , DeriveDataTypeable , DeriveFunctor @@ -579,9 +563,6 @@ PrettyTests ReduceExprTests TestCommon - mixins: - base hiding (Prelude) - , relude hs-source-dirs: tests ghc-options: @@ -615,7 +596,8 @@ , time , unix-compat default-extensions: - OverloadedStrings + NoImplicitPrelude + , OverloadedStrings , DeriveGeneric , DeriveDataTypeable , DeriveFunctor @@ -650,9 +632,6 @@ ParserBench hs-source-dirs: benchmarks - mixins: - base hiding (Prelude) - , relude ghc-options: -Wall build-depends: @@ -668,7 +647,8 @@ , template-haskell , time default-extensions: - OverloadedStrings + NoImplicitPrelude + , OverloadedStrings , DeriveGeneric , DeriveDataTypeable , DeriveFunctor diff --git a/main/Main.hs b/main/Main.hs --- a/main/Main.hs +++ b/main/Main.hs @@ -4,6 +4,7 @@ module Main ( main ) where +import Nix.Prelude import Relude as Prelude ( force ) import Control.Comonad ( extract ) import qualified Control.Exception as Exception @@ -19,7 +20,6 @@ import Text.Show.Pretty ( ppShow ) import Nix hiding ( force ) import Nix.Convert -import Nix.Fresh.Basic import Nix.Json import Nix.Options.Parser import Nix.Standard @@ -37,8 +37,8 @@ main :: IO () main = do - time <- getCurrentTime - opts <- execParser $ nixOptionsInfo time + currentTime <- getCurrentTime + opts <- execParser $ nixOptionsInfo currentTime main' opts @@ -47,18 +47,18 @@ where -- 2021-07-15: NOTE: This logic should be weaved stronger through CLI options logic (OptParse-Applicative code) -- As this logic is not stated in the CLI documentation, for example. So user has no knowledge of these. - execContentsFilesOrRepl :: StandardT (StdIdT IO) () + execContentsFilesOrRepl :: StdIO execContentsFilesOrRepl = fromMaybe loadFromCliFilePathList - ( loadBinaryCacheFile <|> + $ loadBinaryCacheFile <|> loadLiteralExpression <|> loadExpressionFromFile - ) where -- | The base case: read expressions from the last CLI directive (@[FILE]@) listed on the command line. + loadFromCliFilePathList :: StdIO loadFromCliFilePathList = - case filePaths of + case getFilePaths of [] -> runRepl ["-"] -> readExpressionFromStdin _paths -> processSeveralFiles (coerce _paths) @@ -67,27 +67,28 @@ runRepl = withEmptyNixContext Repl.main readExpressionFromStdin = - do - expr <- liftIO Text.getContents - processExpr expr + processExpr =<< liftIO Text.getContents - processSeveralFiles :: [Path] -> StandardT (StdIdT IO) () + processSeveralFiles :: [Path] -> StdIO processSeveralFiles = traverse_ processFile where processFile path = handleResult (pure path) =<< parseNixFileLoc path -- | The `--read` option: load expression from a serialized file. + loadBinaryCacheFile :: Maybe StdIO loadBinaryCacheFile = (\ (binaryCacheFile :: Path) -> do let file = replaceExtension binaryCacheFile "nixc" - processCLIOptions (Just file) =<< liftIO (readCache binaryCacheFile) - ) <$> readFrom + processCLIOptions (pure file) =<< liftIO (readCache binaryCacheFile) + ) <$> getReadFrom -- | The `--expr` option: read expression from the argument string - loadLiteralExpression = processExpr <$> expression + loadLiteralExpression :: Maybe StdIO + loadLiteralExpression = processExpr <$> getExpression -- | The `--file` argument: read expressions from the files listed in the argument file + loadExpressionFromFile :: Maybe StdIO loadExpressionFromFile = -- We can start use Text as in the base case, requires changing Path -> Text -- But that is a gradual process: @@ -96,9 +97,10 @@ (\case "-" -> Text.getContents _fp -> readFile _fp - ) <$> fromFile + ) <$> getFromFile - processExpr text = handleResult Nothing $ parseNixTextLoc text + processExpr :: Text -> StdIO + processExpr = handleResult mempty . parseNixTextLoc withEmptyNixContext = withNixContext mempty @@ -109,21 +111,21 @@ bool errorWithoutStackTrace (liftIO . hPutStrLn stderr) - ignoreErrors + isIgnoreErrors $ "Parse failed: " <> show err ) (\ expr -> do - when check $ + when isCheck $ do expr' <- liftIO $ reduceExpr mpath expr either (\ err -> errorWithoutStackTrace $ "Type error: " <> ppShow err) - (\ ty -> liftIO $ putStrLn $ "Type of expression: " <> - ppShow (maybeToMonoid $ Map.lookup @VarName @[Scheme] "it" $ coerce ty) + (liftIO . putStrLn . (<>) "Type of expression: " . + ppShow . maybeToMonoid . Map.lookup @VarName @[Scheme] "it" . coerce ) - (HM.inferTop mempty (one ("it", stripAnnotation expr'))) + $ HM.inferTop mempty $ curry one "it" $ stripAnnotation expr' -- liftIO $ putStrLn $ runST $ -- runLintM opts . renderSymbolic =<< lint opts expr @@ -133,36 +135,33 @@ NixException frames -> errorWithoutStackTrace . show =<< renderFrames - @(StdValue (StandardT (StdIdT IO))) - @(StdThunk (StandardT (StdIdT IO))) + @StdVal + @StdThun frames - when repl $ + when isRepl $ withEmptyNixContext $ bool Repl.main - (do - val <- nixEvalExprLoc (coerce mpath) expr - Repl.main' $ pure val - ) - evaluate + ((Repl.main' . pure) =<< nixEvalExprLoc (coerce mpath) expr) + isEvaluate ) -- 2021-07-15: NOTE: Logic of CLI Option processing is scattered over several functions, needs to be consolicated. - processCLIOptions :: Maybe Path -> NExprLoc -> StandardT (StdIdT IO) () + processCLIOptions :: Maybe Path -> NExprLoc -> StdIO processCLIOptions mpath expr - | evaluate = + | isEvaluate = if - | tracing -> evaluateExprWithEvaluator nixTracingEvalExprLoc expr - | Just path <- reduce -> evaluateExprWithEvaluator (reduction path . coerce) expr - | null arg || null argstr -> evaluateExprWithEvaluator nixEvalExprLoc expr + | isTrace -> evaluateExprWith nixTracingEvalExprLoc expr + | Just path <- getReduce -> evaluateExprWith (reduction path . coerce) expr + | null getArg || null getArgstr -> evaluateExprWith nixEvalExprLoc expr | otherwise -> processResult printer <=< nixEvalExprLoc (coerce mpath) $ expr - | xml = fail "Rendering expression trees to XML is not yet implemented" - | json = fail "Rendering expression trees to JSON is not implemented" - | verbose >= DebugInfo = liftIO . putStr . ppShow . stripAnnotation $ expr - | cache , Just path <- mpath = liftIO . writeCache (replaceExtension path "nixc") $ expr - | parseOnly = void . liftIO . Exception.evaluate . force $ expr - | otherwise = + | isXml = fail "Rendering expression trees to XML is not yet implemented" + | isJson = fail "Rendering expression trees to JSON is not implemented" + | getVerbosity >= DebugInfo = liftIO . putStr . ppShow . stripAnnotation $ expr + | isCache , Just path <- mpath = liftIO . writeCache (replaceExtension path "nixc") $ expr + | isParseOnly = void . liftIO . Exception.evaluate . force $ expr + | otherwise = liftIO . renderIO stdout @@ -171,40 +170,60 @@ . stripAnnotation $ expr where - evaluateExprWithEvaluator evaluator = evaluateExpression (coerce mpath) evaluator printer + evaluateExprWith evaluator = evaluateExpression (coerce mpath) evaluator printer printer - | finder = findAttrs <=< fromValue @(AttrSet (StdValue (StandardT (StdIdT IO)))) + :: StdVal + -> StdIO + printer + | isFinder = findAttrs <=< fromValue @(AttrSet StdVal) | otherwise = printer' where + -- 2021-05-27: NOTE: With naive fix of the #941 + -- This is overall a naive printer implementation, as options should interact/respect one another. + -- A nice question: "Should respect one another to what degree?": Go full combinator way, for which + -- old Nix CLI is nototrious for (and that would mean to reimplement the old Nix CLI), + -- OR: https://github.com/haskell-nix/hnix/issues/172 and have some sane standart/default behaviour for (most) keys. printer' - | xml = go (stringIgnoreContext . toXML) normalForm - -- 2021-05-27: NOTE: With naive fix of the #941 - -- This is overall a naive printer implementation, as options should interact/respect one another. - -- A nice question: "Should respect one another to what degree?": Go full combinator way, for which - -- old Nix CLI is nototrious for (and that would mean to reimplement the old Nix CLI), - -- OR: https://github.com/haskell-nix/hnix/issues/172 and have some sane standart/default behaviour for (most) keys. - | json = go (stringIgnoreContext . mempty . nvalueToJSONNixString) normalForm - | strict = go (show . prettyNValue) normalForm - | values = go (show . prettyNValueProv) removeEffects - | otherwise = go (show . prettyNValue) removeEffects + | isXml = out (ignoreContext . toXML) normalForm + | isJson = out (ignoreContext . mempty . toJSONNixString) normalForm + | isStrict = out (show . prettyNValue) normalForm + | isValues = out (show . prettyNValueProv) removeEffects + | otherwise = out (show . prettyNValue) removeEffects where - go + out :: (b -> Text) - -> (a -> StandardT (StdIdT IO) b) + -> (a -> StandardIO b) -> a - -> StandardT (StdIdT IO) () - go g f = liftIO . Text.putStrLn . g <=< f + -> StdIO + out transform val = liftIO . Text.putStrLn . transform <=< val findAttrs - :: AttrSet (StdValue (StandardT (StdIdT IO))) - -> StandardT (StdIdT IO) () + :: AttrSet StdVal + -> StdIO findAttrs = go mempty where + go :: Text -> AttrSet StdVal -> StdIO go prefix s = - do - xs <- - traverse + traverse_ + (\ (k, mv) -> + do + let + path = prefix <> k + (report, descend) = filterEntry path k + when report $ + do + liftIO $ Text.putStrLn path + when descend $ + maybe + stub + (\case + NVSet _ s' -> go (path <> ".") s' + _ -> stub + ) + mv + ) + =<< traverse (\ (k, nv) -> (k, ) <$> free @@ -214,40 +233,21 @@ path = prefix <> k (_, descend) = filterEntry path k - val <- readRef @(StandardT (StdIdT IO)) ref + val <- readRef @StandardIO ref bool (pure Nothing) (forceEntry path nv) (descend && - deferred - (const False) - (const True) - val + deferred + (const False) + (const True) + val ) ) (pure . pure . Free) nv ) (sortWith fst $ M.toList $ M.mapKeys coerce s) - traverse_ - (\ (k, mv) -> - do - let - path = prefix <> k - (report, descend) = filterEntry path k - when report $ - do - liftIO $ Text.putStrLn path - when descend $ - maybe - stub - (\case - NVSet _ s' -> go (path <> ".") s' - _ -> stub - ) - mv - ) - xs where filterEntry path k = case (path, k) of ("stdenv", "stdenv" ) -> (True , True ) @@ -267,36 +267,37 @@ _ -> (True , True ) forceEntry - :: MonadValue a (StandardT (StdIdT IO)) + :: MonadValue a StandardIO => Text -> a - -> StandardT (StdIdT IO) (Maybe a) + -> StandardIO (Maybe a) forceEntry k v = catch (pure <$> demand v) - (\ (NixException frames) -> - do - liftIO - . Text.putStrLn - . (("Exception forcing " <> k <> ": ") <>) - . show =<< - renderFrames - @(StdValue (StandardT (StdIdT IO))) - @(StdThunk (StandardT (StdIdT IO))) - frames - pure Nothing - ) + fun + where + fun :: NixException -> StandardIO (Maybe a) + fun (coerce -> frames) = + do + liftIO + . Text.putStrLn + . (("Exception forcing " <> k <> ": ") <>) + . show =<< + renderFrames + @StdVal + @StdThun + frames + pure Nothing reduction path mpathToContext annExpr = do eres <- withNixContext mpathToContext - (reducingEvalExpr - evalContent - mpathToContext - annExpr - ) + $ reducingEvalExpr + evalContent + mpathToContext + annExpr handleReduced path eres handleReduced diff --git a/main/Repl.hs b/main/Repl.hs --- a/main/Repl.hs +++ b/main/Repl.hs @@ -14,16 +14,16 @@ , main' ) where -import Prelude hiding ( state ) +import Nix.Prelude hiding ( state ) import Nix hiding ( exec ) import Nix.Scope import Nix.Value.Monad ( demand ) -import qualified Data.HashMap.Lazy as M +import qualified Data.HashMap.Lazy as M import Data.Char ( isSpace ) import Data.List ( dropWhileEnd ) -import qualified Data.Text as Text -import qualified Data.Text.IO as Text +import qualified Data.Text as Text +import qualified Data.Text.IO as Text import Data.Version ( showVersion ) import Paths_hnix ( version ) @@ -33,7 +33,7 @@ , space ) import qualified Prettyprinter -import qualified Prettyprinter.Render.Text as Prettyprinter +import qualified Prettyprinter.Render.Text as Prettyprinter import System.Console.Haskeline.Completion ( Completion(isFinished) @@ -49,9 +49,9 @@ , HaskelineT , evalRepl ) -import qualified System.Console.Repline as Console -import qualified System.Exit as Exit -import qualified System.IO.Error as Error +import qualified System.Console.Repline as Console +import qualified System.Exit as Exit +import qualified System.IO.Error as Error -- | Repl entry point main :: (MonadNix e t f m, MonadIO m, MonadMask m) => m () @@ -111,7 +111,7 @@ (words <$> lines f) handleMissing e - | Error.isDoesNotExistError e = pure mempty + | Error.isDoesNotExistError e = stub | otherwise = throwM e -- Replicated and slightly adjusted `optMatcher` from `System.Console.Repline` @@ -161,15 +161,15 @@ M.fromList $ ("builtins", builtins) : fmap ("input",) (maybeToList mIni) - opts :: Nix.Options <- asks $ view hasLens + opts <- askOptions pure $ IState Nothing scope defReplConfig - { cfgStrict = strict opts - , cfgValues = values opts + { cfgStrict = isStrict opts + , cfgValues = isValues opts } where evalText :: (MonadNix e t f m) => Text -> m (NValue t f m) @@ -190,65 +190,71 @@ => Bool -> Text -> Repl e t f m (Maybe (NValue t f m)) -exec update source = do - -- Get the current interpreter state - state <- get +exec update source = + do + -- Get the current interpreter state + state <- get - when (cfgDebug $ replCfg state) $ liftIO $ print state + when (cfgDebug $ replCfg state) $ liftIO $ print state - -- Parser ( returns AST as `NExprLoc` ) - case parseExprOrBinding source of - (Left err, _) -> do - liftIO $ print err - pure Nothing - (Right expr, isBinding) -> do + -- Parser ( returns AST as `NExprLoc` ) + case parseExprOrBinding source of + (Left err, _) -> + do + liftIO $ print err + pure Nothing + (Right expr, isBinding) -> + do - -- Type Inference ( returns Typing Environment ) - -- - -- import qualified Nix.Type.Env as Env - -- import Nix.Type.Infer - -- - -- let tyctx' = inferTop mempty [("repl", stripAnnotation expr)] - -- liftIO $ print tyctx' + -- Type Inference ( returns Typing Environment ) + -- + -- import qualified Nix.Type.Env as Env + -- import Nix.Type.Infer + -- + -- let tyctx' = inferTop mempty [("repl", stripAnnotation expr)] + -- liftIO $ print tyctx' - mVal <- lift $ lift $ try $ pushScope (replCtx state) (evalExprLoc expr) + mVal <- lift $ lift $ try $ pushScope (replCtx state) (evalExprLoc expr) - either - (\ (NixException frames) -> do - lift $ lift $ liftIO . print =<< renderFrames @(NValue t f m) @t frames - pure Nothing) - (\ val -> do - -- Update the interpreter state - when (update && isBinding) $ do - -- Set `replIt` to last entered expression - put state { replIt = pure expr } + either + (\ (NixException frames) -> + do + lift $ lift $ liftIO . print =<< renderFrames @(NValue t f m) @t frames + pure Nothing + ) + (\ val -> + do + -- Update the interpreter state + when (update && isBinding) $ do + -- Set `replIt` to last entered expression + put state { replIt = pure expr } - -- If the result value is a set, update our context with it - case val of - NVSet _ (coerce -> scope) -> put state { replCtx = scope <> replCtx state } - _ -> stub + -- If the result value is a set, update our context with it + case val of + NVSet _ (coerce -> scope) -> put state { replCtx = scope <> replCtx state } + _ -> stub - pure $ pure val - ) - mVal - where - -- If parsing fails, turn the input into singleton attribute set - -- and try again. - -- - -- This allows us to handle assignments like @a = 42@ - -- which get turned into @{ a = 42; }@ - parseExprOrBinding i = - either - (\ e -> - either - (const (Left e, False)) -- return the first parsing failure - (\ e' -> (pure e', True)) - (parseNixTextLoc $ toAttrSet i)) - (\ expr -> (pure expr, False)) - (parseNixTextLoc i) + pure $ pure val + ) + mVal + where + -- If parsing fails, turn the input into singleton attribute set + -- and try again. + -- + -- This allows us to handle assignments like @a = 42@ + -- which get turned into @{ a = 42; }@ + parseExprOrBinding i = + either + (\ e -> + either + (const (Left e, False)) -- return the first parsing failure + (\ e' -> (pure e', True)) + (parseNixTextLoc $ toAttrSet i)) + (\ expr -> (pure expr, False)) + (parseNixTextLoc i) - toAttrSet i = - "{" <> i <> whenFalse ";" (Text.isSuffixOf ";" i) <> "}" + toAttrSet i = + "{" <> i <> whenFalse ";" (Text.isSuffixOf ";" i) <> "}" cmd :: (MonadNix e t f m, MonadIO m) @@ -299,7 +305,6 @@ -- | @:load@ command load :: (MonadNix e t f m, MonadIO m) - -- This one does I String -> O String pretty fast, it is ugly to double marshall here. => Path -> Repl e t f m () load path = @@ -316,22 +321,18 @@ :: (MonadNix e t f m, MonadIO m) => Text -> Repl e t f m () -typeof args = do +typeof src = do state <- get mVal <- maybe - (exec False line) + (exec False src) (pure . pure) - (M.lookup (coerce line) (coerce $ replCtx state)) + (M.lookup (coerce src) (coerce $ replCtx state)) traverse_ printValueType mVal where - line = args - printValueType val = - do - s <- lift . lift . showValueType $ val - liftIO $ Text.putStrLn s + printValueType = liftIO . Text.putStrLn <=< lift . lift . showValueType -- | @:quit@ command @@ -361,12 +362,13 @@ completion :: (MonadNix e t f m, MonadIO m) => CompleterStyle (StateT (IState t f m) m) -completion = System.Console.Repline.Prefix - (completeWordWithPrev (pure '\\') separators completeFunc) - defaultMatcher - where - separators :: String - separators = " \t[(,=+*&|}#?>:" +completion = + System.Console.Repline.Prefix + (completeWordWithPrev (pure '\\') separators completeFunc) + defaultMatcher + where + separators :: String + separators = " \t[(,=+*&|}#?>:" -- | Main completion function -- @@ -587,4 +589,4 @@ options :: (MonadNix e t f m, MonadIO m) => Console.Options (Repl e t f m) -options = (\h -> (toString $ helpOptionName h, helpOptionFunction h)) <$> helpOptions +options = (\ h -> (toString $ helpOptionName h, helpOptionFunction h)) <$> helpOptions diff --git a/src/Nix.hs b/src/Nix.hs --- a/src/Nix.hs +++ b/src/Nix.hs @@ -1,4 +1,3 @@ - module Nix ( module Nix.Cache , module Nix.Exec @@ -25,6 +24,7 @@ ) where +import Nix.Prelude import Relude.Unsafe ( (!!) ) import GHC.Err ( errorWithoutStackTrace ) import Data.Fix ( Fix ) @@ -104,17 +104,17 @@ -> m a evaluateExpression mpath evaluator handler expr = do - opts :: Options <- asks $ view hasLens + opts <- askOptions (coerce -> args) <- (traverse . traverse) eval' - $ (second parseArg <$> arg opts) - <> (second mkStr <$> argstr opts) + $ (second parseArg <$> getArg opts) + <> (second mkStr <$> getArgstr opts) f <- evaluator mpath expr f' <- demand f val <- case f' of - NVClosure _ g -> g $ argmap args + NVClosure _ g -> g $ mkNVSet mempty $ M.fromList args _ -> pure f processResult handler val where @@ -126,20 +126,19 @@ eval' = normalForm <=< nixEvalExpr mpath - argmap args = nvSet mempty $ M.fromList args - processResult :: forall e t f m a . (MonadNix e t f m, Has e Options) => (NValue t f m -> m a) -> NValue t f m -> m a -processResult h val = do - opts :: Options <- asks $ view hasLens - maybe - (h val) - (\ (coerce . Text.splitOn "." -> keys) -> processKeys keys val) - (attr opts) +processResult h val = + do + opts <- askOptions + maybe + (h val) + (\ (coerce . Text.splitOn "." -> keys) -> processKeys keys val) + (getAttr opts) where processKeys :: [VarName] -> NValue t f m -> m a processKeys kys v = diff --git a/src/Nix/Atoms.hs b/src/Nix/Atoms.hs --- a/src/Nix/Atoms.hs +++ b/src/Nix/Atoms.hs @@ -1,8 +1,9 @@ -{-# language CPP #-} -{-# language DeriveAnyClass #-} +{-# language CPP #-} +{-# language DeriveAnyClass #-} module Nix.Atoms where +import Nix.Prelude import Codec.Serialise ( Serialise ) import Data.Data ( Data) @@ -11,7 +12,7 @@ import Data.Aeson.Types ( FromJSON , ToJSON ) --- 2021-08-01: NOTE: Check the order efficience of NAtom constructors. +-- 2021-08-01: NOTE: Check the order effectiveness of NAtom constructors. -- | Atoms are values that evaluate to themselves. -- In other words - this is a constructors that are literals in Nix. diff --git a/src/Nix/Builtins.hs b/src/Nix/Builtins.hs --- a/src/Nix/Builtins.hs +++ b/src/Nix/Builtins.hs @@ -13,6 +13,7 @@ {-# options_ghc -fno-warn-name-shadowing #-} + -- | Code that implements Nix builtins. Lists the functions that are built into the Nix expression evaluator. Some built-ins (aka `derivation`), are always in the scope, so they can be accessed by the name. To keap the namespace clean, most built-ins are inside the `builtins` scope - a set that contains all what is a built-in. module Nix.Builtins ( withNixContext @@ -20,7 +21,7 @@ ) where - +import Nix.Prelude import GHC.Exception ( ErrorCall(ErrorCall) ) import Control.Comonad ( Comonad ) import Control.Monad ( foldM ) @@ -45,6 +46,7 @@ import Data.Foldable ( foldrM ) import Data.Fix ( foldFix ) import Data.List ( partition ) +import qualified Data.HashSet as HS import qualified Data.HashMap.Lazy as M import Data.Scientific import qualified Data.Set as S @@ -87,7 +89,6 @@ , matchAllText ) - -- This is a big module. There is recursive reuse: -- @builtins -> builtinsList -> scopedImport -> withNixContext -> builtins@, -- since @builtins@ is self-recursive: aka we ship @builtins.builtins.builtins...@. @@ -125,7 +126,7 @@ ) => ToBuiltin t f m (a -> b) where toBuiltin name f = - pure $ nvBuiltin (coerce name) $ toBuiltin name . f <=< fromValue . Deeper + pure $ mkNVBuiltin (coerce name) $ toBuiltin name . f <=< fromValue . Deeper -- *** @WValue@ closure wrapper to have @Ord@ @@ -141,7 +142,7 @@ WValue (NVConstant (NFloat x)) == WValue (NVConstant (NFloat y)) = x == y WValue (NVPath x ) == WValue (NVPath y ) = x == y WValue (NVStr x) == WValue (NVStr y) = - stringIgnoreContext x == stringIgnoreContext y + ignoreContext x == ignoreContext y _ == _ = False instance Comonad f => Ord (WValue t f m) where @@ -153,21 +154,16 @@ WValue (NVConstant (NFloat x)) <= WValue (NVConstant (NFloat y)) = x <= y WValue (NVPath x ) <= WValue (NVPath y ) = x <= y WValue (NVStr x) <= WValue (NVStr y) = - stringIgnoreContext x <= stringIgnoreContext y + ignoreContext x <= ignoreContext y _ <= _ = False -- ** Helpers -nvNull - :: MonadNix e t f m - => NValue t f m -nvNull = nvConstant NNull - mkNVBool :: MonadNix e t f m => Bool -> NValue t f m -mkNVBool = nvConstant . NBool +mkNVBool = mkNVConstant . NBool data NixPathEntryType = PathEntryPath @@ -209,9 +205,9 @@ mDataDir foldrM - go + fun z - $ (fromInclude . stringIgnoreContext <$> dirs) + $ (fromInclude . ignoreContext <$> dirs) <> uriAwareSplit `whenJust` mPath <> one (fromInclude $ "nix=" <> fromString (coerce dataDir) <> "/nix/corepkgs") where @@ -224,8 +220,8 @@ PathEntryURI ("://" `Text.isInfixOf` x) - go :: (Text, NixPathEntryType) -> r -> m r - go (x, ty) rest = + fun :: (Text, NixPathEntryType) -> r -> m r + fun (x, ty) rest = case Text.splitOn "=" x of [p] -> f (coerce $ toString p) mempty ty rest [n, p] -> f (coerce $ toString p) (pure n) ty rest @@ -253,22 +249,20 @@ splitVersion :: Text -> [VersionComponent] splitVersion s = - whenJust - (\ (x, xs) -> if - | isRight eDigitsPart -> - either - (\ e -> error $ "splitVersion: did hit impossible: '" <> toText e <> "' while parsing '" <> s <> "'.") - (\ res -> - one (VersionComponentNumber $ fst res) - <> splitVersion (snd res) - ) - eDigitsPart + (\ (x, xs) -> if + | isRight eDigitsPart -> + either + (\ e -> error $ "splitVersion: did hit impossible: '" <> fromString e <> "' while parsing '" <> s <> "'.") + (\ res -> + one (VersionComponentNumber $ fst res) + <> splitVersion (snd res) + ) + eDigitsPart - | x `elem` separators -> splitVersion xs + | x `elem` separators -> splitVersion xs - | otherwise -> one charsPart <> splitVersion rest2 - ) - (Text.uncons s) + | otherwise -> one charsPart <> splitVersion rest2 + ) `whenJust` Text.uncons s where -- | Based on https://github.com/NixOS/nix/blob/4ee4fda521137fed6af0446948b3877e0c5db803/src/libexpr/names.cc#L44 separators :: String @@ -337,7 +331,7 @@ relStart = max 0 start - numDropped (before, rest) = B.splitAt relStart haystack caps :: NValue t f m - caps = nvList (f <$> captures) + caps = mkNVList (f <$> captures) f :: (ByteString, (Int, b)) -> NValue t f m f (a, (s, _)) = bool @@ -346,7 +340,7 @@ (s >= 0) thunkStr :: Applicative f => ByteString -> NValue t f m -thunkStr s = nvStrWithoutContext $ decodeUtf8 s +thunkStr s = mkNVStrWithoutContext $ decodeUtf8 s hasKind :: forall a e t f m @@ -364,7 +358,7 @@ NVStr ns -> do let - path = coerce . toString $ stringIgnoreContext ns + path = coerce . toString $ ignoreContext ns unless (isAbsolute path) $ throwError $ ErrorCall $ "string " <> show path <> " doesn't represent an absolute path" pure path @@ -428,26 +422,26 @@ nixPathNix :: forall e t f m . MonadNix e t f m => m (NValue t f m) nixPathNix = fmap - nvList + mkNVList $ foldNixPath mempty $ \p mn ty rest -> pure $ pure - (nvSet + (mkNVSet mempty (M.fromList [case ty of - PathEntryPath -> ("path", nvPath p) - PathEntryURI -> ( "uri", nvStrWithoutContext $ fromString $ coerce p) + PathEntryPath -> ("path", mkNVPath p) + PathEntryURI -> ( "uri", mkNVStrWithoutContext $ fromString $ coerce p) - , ( "prefix", nvStrWithoutContext $ maybeToMonoid mn) + , ( "prefix", mkNVStrWithoutContext $ maybeToMonoid mn) ] ) ) <> rest toStringNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -toStringNix = toValue <=< coerceToString callFunc DontCopyToStore CoerceAny +toStringNix = toValue <=< coerceAnyToNixString callFunc DontCopyToStore hasAttrNix :: forall e t f m @@ -463,7 +457,7 @@ toValue $ M.member key aset hasContextNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -hasContextNix = inHask stringHasContext +hasContextNix = inHask hasContext getAttrNix :: forall e t f m @@ -478,6 +472,20 @@ attrsetGet key aset +unsafeDiscardOutputDependencyNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> m (NValue t f m) +unsafeDiscardOutputDependencyNix nv = + do + (nc, ns) <- (getStringContext &&& ignoreContext) <$> fromValue nv + toValue $ mkNixString (HS.map discard nc) ns + where + discard :: StringContext -> StringContext + discard (StringContext AllOutputs a) = StringContext DirectPath a + discard x = x + unsafeGetAttrPosNix :: forall e t f m . MonadNix e t f m @@ -494,7 +502,7 @@ maybe (pure nvNull) toValue - (M.lookup @VarName (coerce $ stringIgnoreContext ns) apos) + (M.lookup @VarName (coerce $ ignoreContext ns) apos) _xy -> throwError $ ErrorCall $ "Invalid types for builtins.unsafeGetAttrPosNix: " <> show _xy -- This function is a bit special in that it doesn't care about the contents @@ -605,7 +613,7 @@ tailNix = maybe (throwError $ ErrorCall "builtins.tail: empty list") - (pure . nvList) + (pure . mkNVList) . viaNonEmpty tail <=< fromValue @[NValue t f m] splitVersionNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) @@ -613,8 +621,8 @@ do version <- fromStringNoContext =<< fromValue v pure $ - nvList $ - nvStrWithoutContext . show <$> + mkNVList $ + mkNVStrWithoutContext . show <$> splitVersion version compareVersionsNix @@ -634,7 +642,7 @@ EQ -> 0 GT -> 1 - pure $ nvConstant $ NInt cmpVers + pure $ mkNVConstant $ NInt cmpVers where mkText = fromStringNoContext <=< fromValue @@ -659,7 +667,7 @@ ] where - mkNVStr = nvStrWithoutContext + mkNVStr = mkNVStrWithoutContext matchNix :: forall e t f m @@ -677,11 +685,11 @@ -- going to preserve the behavior here until it is fixed upstream. -- Relevant issue: https://github.com/NixOS/nix/issues/2547 let - s = stringIgnoreContext ns + s = ignoreContext ns re = makeRegex p :: Regex mkMatch t = bool - (toValue ()) -- Shorthand for Null + (pure nvNull) (toValue $ mkNixStringWithoutContext t) (not $ Text.null t) @@ -689,7 +697,7 @@ Just ("", sarr, "") -> do let submatches = fst <$> elems sarr - nvList <$> + mkNVList <$> traverse mkMatch (case submatches of @@ -714,11 +722,11 @@ -- going to preserve the behavior here until it is fixed upstream. -- Relevant issue: https://github.com/NixOS/nix/issues/2547 let - s = stringIgnoreContext ns + s = ignoreContext ns regex = makeRegex p :: Regex haystack = encodeUtf8 s - pure $ nvList $ splitMatches 0 (elems <$> matchAllText regex haystack) haystack + pure $ mkNVList $ splitMatches 0 (elems <$> matchAllText regex haystack) haystack substringNix :: forall e t f m. MonadNix e t f m => Int -> Int -> NixString -> Prim m NixString substringNix start len str = @@ -783,7 +791,7 @@ applyFunToKeyVal (key, val) = do - runFunForKey <- callFunc f $ nvStrWithoutContext (coerce key) + runFunForKey <- callFunc f $ mkNVStrWithoutContext (coerce key) callFunc runFunForKey val newVals <- @@ -817,7 +825,7 @@ n <- fromStringNoContext =<< fromValue attrName l <- fromValue @[NValue t f m] xs - nvList . catMaybes <$> + mkNVList . catMaybes <$> traverse (fmap (M.lookup @VarName $ coerce n) . fromValue <=< demand) l @@ -825,9 +833,9 @@ baseNameOfNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) baseNameOfNix x = do - ns <- coerceToString callFunc DontCopyToStore CoerceStringy x + ns <- coerceStringlikeToNixString DontCopyToStore x pure $ - nvStr $ + mkNVStr $ modifyNixContents (fromString . coerce takeFileName . toString) ns @@ -877,21 +885,57 @@ => m (NValue t f m) builtinsBuiltinNix = throwError $ ErrorCall "HNix does not provide builtins.builtins at the moment. Using builtins directly should be preferred" +-- a safer version of `attrsetGet` +attrGetOr + :: forall e t f m v a + . (MonadNix e t f m, FromValue v m (NValue t f m)) + => a + -> (v -> m a) + -> VarName + -> AttrSet (NValue t f m) + -> m a +attrGetOr fallback fun name attrs = + maybe + (pure fallback) + (fun <=< fromValue) + (M.lookup name attrs) + + +-- NOTE: It is a part of the implementation taken from: +-- https://github.com/haskell-nix/hnix/pull/755 +-- look there for `sha256` and/or `filterSource` +pathNix :: forall e t f m. MonadNix e t f m => NValue t f m -> m (NValue t f m) +pathNix arg = + do + attrs <- fromValue @(AttrSet (NValue t f m)) arg + path <- fmap (coerce . toString) $ fromStringNoContext =<< coerceToPath =<< attrsetGet "path" attrs + + -- TODO: Fail on extra args + -- XXX: This is a very common pattern, we could factor it out + name <- toText <$> attrGetOr (takeFileName path) (fmap (coerce . toString) . fromStringNoContext) "name" attrs + recursive <- attrGetOr True pure "recursive" attrs + + Right (coerce . toText . coerce @StorePath @String -> s) <- addToStore name path recursive False + -- TODO: Ensure that s matches sha256 when not empty + pure $ mkNVStr $ mkNixStringWithSingletonContext (StringContext DirectPath s) s + where + coerceToPath = coerceToString callFunc DontCopyToStore CoerceAny + dirOfNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) dirOfNix nvdir = do dir <- demand nvdir case dir of - NVStr ns -> pure $ nvStr $ modifyNixContents (fromString . coerce takeDirectory . toString) ns - NVPath path -> pure $ nvPath $ takeDirectory path + NVStr ns -> pure $ mkNVStr $ modifyNixContents (fromString . coerce takeDirectory . toString) ns + NVPath path -> pure $ mkNVPath $ takeDirectory path v -> throwError $ ErrorCall $ "dirOf: expected string or path, got " <> show v -- jww (2018-04-28): This should only be a string argument, and not coerced? unsafeDiscardStringContextNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) unsafeDiscardStringContextNix = - inHask (mkNixStringWithoutContext . stringIgnoreContext) + inHask (mkNixStringWithoutContext . ignoreContext) -- | Evaluate `a` to WHNF to collect its topmost effect. seqNix @@ -1038,7 +1082,7 @@ where formMatchReplaceTailInfo (m, r) = (m, r, Text.drop (Text.length m) input) - fromKeysToValsMap = zip (stringIgnoreContext <$> fromKeys) toVals + fromKeysToValsMap = zip (ignoreContext <$> fromKeys) toVals -- Not passing args => It is constant that gets embedded into `go` => It is simple `go` tail recursion passOneChar = @@ -1049,7 +1093,7 @@ -- 2021-02-18: NOTE: rly?: toStrict . toLazyText -- Maybe `text-builder`, `text-show`? - finish ctx output = mkNixString (toStrict $ Builder.toLazyText output) ctx + finish ctx output = mkNixString ctx (toStrict $ Builder.toLazyText output) replace (key, replacementNS, unprocessedInput) = replaceWithNixBug unprocessedInput updatedOutput @@ -1073,8 +1117,8 @@ updatedOutput = output <> replacement updatedCtx = ctx <> replacementCtx - replacement = Builder.fromText $ stringIgnoreContext replacementNS - replacementCtx = getContext replacementNS + replacement = Builder.fromText $ ignoreContext replacementNS + replacementCtx = getStringContext replacementNS -- The bug modifies the content => bug demands `pass` to be a real function => -- `go` calls `pass` function && `pass` calls `go` function @@ -1085,7 +1129,7 @@ (\(c, i) -> go updatedCtx i $ output <> Builder.singleton c) -- If there are chars - pass one char & continue (Text.uncons input) -- chip first char - toValue $ go (getContext string) (stringIgnoreContext string) mempty + toValue $ go (getStringContext string) (ignoreContext string) mempty removeAttrsNix :: forall e t f m @@ -1098,10 +1142,10 @@ (m, p) <- fromValue @(AttrSet (NValue t f m), PositionSet) set (nsToRemove :: [NixString]) <- fromValue $ Deeper v (coerce -> toRemove) <- traverse fromStringNoContext nsToRemove - toValue (go m toRemove, go p toRemove) + toValue (fun m toRemove, fun p toRemove) where - go :: forall k v . (Eq k, Hashable k) => HashMap k v -> [k] -> HashMap k v - go = foldl' (flip M.delete) + fun :: forall k v . (Eq k, Hashable k) => HashMap k v -> [k] -> HashMap k v + fun = foldl' (flip M.delete) intersectAttrsNix :: forall e t f m @@ -1114,7 +1158,7 @@ (s1, p1) <- fromValue @(AttrSet (NValue t f m), PositionSet) set1 (s2, p2) <- fromValue @(AttrSet (NValue t f m), PositionSet) set2 - pure $ nvSet (p2 `M.intersection` p1) (s2 `M.intersection` s1) + pure $ mkNVSet (p2 `M.intersection` p1) (s2 `M.intersection` s1) functionArgsNix :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) @@ -1141,13 +1185,13 @@ mres <- toFile_ (coerce $ toString name') - (stringIgnoreContext s') + (ignoreContext s') let storepath = coerce (fromString @Text) mres - sc = StringContext storepath DirectPath + sc = StringContext DirectPath storepath - toValue $ mkNixStringWithSingletonContext storepath sc + toValue $ mkNixStringWithSingletonContext sc storepath toPathNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) toPathNix = inHask @Path id @@ -1159,9 +1203,13 @@ toValue =<< case path of NVPath p -> doesPathExist p - NVStr ns -> doesPathExist $ coerce $ toString $ stringIgnoreContext ns + NVStr ns -> doesPathExist $ coerce $ toString $ ignoreContext ns _v -> throwError $ ErrorCall $ "builtins.pathExists: expected path, got " <> show _v +isPathNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +isPathNix = hasKind @Path + isAttrsNix :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) isAttrsNix = hasKind @(AttrSet (NValue t f m)) @@ -1208,11 +1256,9 @@ _ -> False throwNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -throwNix mnv = - do - ns <- coerceToString callFunc CopyToStore CoerceStringy mnv - - throwError . ErrorCall . toString $ stringIgnoreContext ns +throwNix = + throwError . ErrorCall . toString . ignoreContext + <=< coerceStringlikeToNixString CopyToStore -- | Implementation of Nix @import@ clause. -- @@ -1226,7 +1272,7 @@ -- importNix :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -importNix = scopedImportNix $ nvSet mempty mempty +importNix = scopedImportNix $ mkNVSet mempty mempty -- | @scopedImport scope path@ -- An undocumented secret powerful function. @@ -1346,7 +1392,7 @@ (NFloat a, NInt b) -> pure $ a < fromInteger b (NFloat a, NFloat b) -> pure $ a < b _ -> badType - (NVStr a, NVStr b) -> pure $ stringIgnoreContext a < stringIgnoreContext b + (NVStr a, NVStr b) -> pure $ ignoreContext a < ignoreContext b _ -> badType -- | Helper function, generalization of @concat@ operations. @@ -1387,7 +1433,7 @@ do l <- fromValue @[NValue t f m] lst fmap - (nvSet mempty . M.fromList . reverse) + (mkNVSet mempty . M.fromList . reverse) (traverse (\ nvattrset -> do @@ -1428,6 +1474,49 @@ mkHash s = hash $ encodeUtf8 s +-- | hashFileNix +-- use hashStringNix to hash file content +hashFileNix + :: forall e t f m . MonadNix e t f m => NixString -> Path -> Prim m NixString +hashFileNix nsAlgo nvfilepath = Prim $ hash =<< fileContent + where + hash = outPrim . hashStringNix nsAlgo + outPrim (Prim x) = x + fileContent :: m NixString + fileContent = mkNixStringWithoutContext <$> Nix.Render.readFile nvfilepath + + +-- | groupByNix +-- Groups elements of list together by the string returned from the function f called on +-- each element. It returns an attribute set where each attribute value contains the +-- elements of list that are mapped to the same corresponding attribute name returned by f. +groupByNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +groupByNix nvfun nvlist = do + list <- demand nvlist + fun <- demand nvfun + (f, l) <- extractP (fun, list) + mkNVSet mempty + . fmap (mkNVList . reverse) + . M.fromListWith (<>) + <$> traverse (app f) l + where + app f x = do + name <- fromValue @Text =<< f x + pure (VarName name, one x) + extractP (NVBuiltin _ f, NVList l) = pure (f, l) + extractP (NVClosure _ f, NVList l) = pure (f, l) + extractP _v = + throwError + $ ErrorCall + $ "builtins.groupBy: expected function and list, got " + <> show _v + + placeHolderNix :: forall t f m e . MonadNix e t f m => NValue t f m -> m (NValue t f m) placeHolderNix p = do @@ -1455,7 +1544,7 @@ bytes :: NixString -> ByteString bytes = encodeUtf8 . body - body = stringIgnoreContext + body = ignoreContext readFileNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) readFileNix = toValue <=< Nix.Render.readFile <=< absolutePathFromValue <=< demand @@ -1474,9 +1563,9 @@ case (aset, filePath) of (NVList x, NVStr ns) -> do - mres <- findPath @t @f @m x $ coerce $ toString $ stringIgnoreContext ns + mres <- findPath @t @f @m x $ coerce $ toString $ ignoreContext ns - pure $ nvPath mres + pure $ mkNVPath mres (NVList _, _y ) -> throwError $ ErrorCall $ "expected a string, got " <> show _y (_x , NVStr _) -> throwError $ ErrorCall $ "expected a list, got " <> show _x @@ -1490,6 +1579,7 @@ items <- listDirectory path let + -- | Function indeed binds filepaths as keys ('VarNames') in Nix attrset. detectFileTypes :: Path -> m (VarName, FileType) detectFileTypes item = do @@ -1502,7 +1592,7 @@ | isSymbolicLink s -> FileTypeSymlink | otherwise -> FileTypeUnknown - pure (coerce @Text @VarName $ toText item, t) -- function indeed binds filepaths as keys (VarNames) in Nix attrset. + pure (coerce @(String -> Text) fromString item, t) itemsWithTypes <- traverse @@ -1530,17 +1620,17 @@ \case A.Object m -> traverseToNValue - (nvSet mempty) + (mkNVSet mempty) #if MIN_VERSION_aeson(2,0,0) (M.mapKeys (coerce . AKM.toText) $ AKM.toHashMap m) #else (M.mapKeys coerce m) #endif - A.Array l -> traverseToNValue nvList (V.toList l) - A.String s -> pure $ nvStrWithoutContext s + A.Array l -> traverseToNValue mkNVList (V.toList l) + A.String s -> pure $ mkNVStrWithoutContext s A.Number n -> pure $ - nvConstant $ + mkNVConstant $ either NFloat NInt @@ -1552,10 +1642,10 @@ traverseToNValue f v = f <$> traverse jsonToNValue v toJSONNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -toJSONNix = (fmap nvStr . nvalueToJSONNixString) <=< demand +toJSONNix = (fmap mkNVStr . toJSONNixString) <=< demand toXMLNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -toXMLNix = (fmap (nvStr . toXML) . normalForm) <=< demand +toXMLNix = (fmap (mkNVStr . toXML) . normalForm) <=< demand typeOfNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) typeOfNix nvv = @@ -1587,7 +1677,7 @@ (onSuccess <$> demand e) where onSuccess v = - nvSet + mkNVSet mempty $ M.fromList [ ("success", mkNVBool True) @@ -1596,7 +1686,7 @@ onError :: SomeException -> NValue t f m onError _ = - nvSet + mkNVSet mempty $ M.fromList $ (, mkNVBool False) <$> @@ -1612,7 +1702,7 @@ -> m (NValue t f m) traceNix msg action = do - traceEffect @t @f @m . toString . stringIgnoreContext =<< fromValue msg + traceEffect @t @f @m . toString . ignoreContext =<< fromValue msg pure action -- Please, can function remember fail context @@ -1628,12 +1718,11 @@ :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) execNix xs = do - ls <- fromValue @[NValue t f m] xs - xs <- traverse (coerceToString callFunc DontCopyToStore CoerceStringy) ls + xs' <- traverse (coerceStringlikeToNixString DontCopyToStore) =<< fromValue @[NValue t f m] xs -- 2018-11-19: NOTE: Still need to do something with the context here -- See prim_exec in nix/src/libexpr/primops.cc -- Requires the implementation of EvalState::realiseContext - exec $ stringIgnoreContext <$> xs + exec $ ignoreContext <$> xs' fetchurlNix :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) @@ -1677,7 +1766,7 @@ let (right, wrong) = partition fst selection - makeSide = nvList . fmap snd + makeSide = mkNVList . fmap snd toValue @(AttrSet (NValue t f m)) $ M.fromList @@ -1691,31 +1780,28 @@ os <- getCurrentSystemOS arch <- getCurrentSystemArch - pure $ nvStrWithoutContext $ arch <> "-" <> os + pure $ mkNVStrWithoutContext $ arch <> "-" <> os currentTimeNix :: MonadNix e t f m => m (NValue t f m) currentTimeNix = do - opts :: Options <- asks $ view hasLens - toValue @Integer $ round $ Time.utcTimeToPOSIXSeconds $ currentTime opts + opts <- askOptions + toValue @Integer $ round $ Time.utcTimeToPOSIXSeconds $ getTime opts derivationStrictNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) derivationStrictNix = derivationStrict getRecursiveSizeNix :: (MonadIntrospect m, Applicative f) => a -> m (NValue t f m) -getRecursiveSizeNix = fmap (nvConstant . NInt . fromIntegral) . recursiveSize +getRecursiveSizeNix = fmap (mkNVConstant . NInt . fromIntegral) . recursiveSize getContextNix :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -getContextNix v = - do - v' <- demand v - case v' of - (NVStr ns) -> do - let context = getNixLikeContext $ toNixLikeContext $ getContext ns - valued :: AttrSet (NValue t f m) <- traverseToValue context - pure $ nvSet mempty valued - x -> throwError $ ErrorCall $ "Invalid type for builtins.getContext: " <> show x +getContextNix = + \case + (NVStr ns) -> + mkNVSet mempty <$> traverseToValue (getNixLikeContext $ toNixLikeContext $ getStringContext ns) + x -> throwError $ ErrorCall $ "Invalid type for builtins.getContext: " <> show x + <=< demand appendContextNix :: forall e t f m @@ -1731,63 +1817,64 @@ case (x, y) of (NVStr ns, NVSet _ attrs) -> do - newContextValues <- traverse getPathNOuts attrs + let + getPathNOuts :: NValue t f m -> m NixLikeContextValue + getPathNOuts tx = + do + x <- demand tx - toValue $ addContext ns newContextValues + case x of + NVSet _ atts -> + do + -- TODO: Fail for unexpected keys. - _xy -> throwError $ ErrorCall $ "Invalid types for builtins.appendContext: " <> show _xy + let + getK :: VarName -> m Bool + getK k = + maybe + (pure False) + (fromValue <=< demand) + $ M.lookup k atts - where - getPathNOuts tx = - do - x <- demand tx + getOutputs :: m [Text] + getOutputs = + maybe + stub + (\ touts -> + do + outs <- demand touts - case x of - NVSet _ attrs-> - do - -- TODO: Fail for unexpected keys. + case outs of + NVList vs -> traverse (fmap ignoreContext . fromValue) vs + _x -> throwError $ ErrorCall $ "Invalid types for context value outputs in builtins.appendContext: " <> show _x + ) + (M.lookup "outputs" atts) - let - getK k = - maybe - (pure False) - (fromValue <=< demand) - (M.lookup k attrs) + path <- getK "path" + allOutputs <- getK "allOutputs" - getOutputs = - maybe - stub - (\ touts -> - do - outs <- demand touts + NixLikeContextValue path allOutputs <$> getOutputs - case outs of - NVList vs -> traverse (fmap stringIgnoreContext . fromValue) vs - _x -> throwError $ ErrorCall $ "Invalid types for context value outputs in builtins.appendContext: " <> show _x - ) - (M.lookup "outputs" attrs) + _x -> throwError $ ErrorCall $ "Invalid types for context value in builtins.appendContext: " <> show _x + addContext :: HashMap VarName NixLikeContextValue -> NixString + addContext newContextValues = + mkNixString + (fromNixLikeContext $ + NixLikeContext $ + M.unionWith + (<>) + newContextValues + $ getNixLikeContext $ + toNixLikeContext $ + getStringContext ns + ) + $ ignoreContext ns - path <- getK "path" - allOutputs <- getK "allOutputs" + toValue . addContext =<< traverse getPathNOuts attrs - NixLikeContextValue path allOutputs <$> getOutputs + _xy -> throwError $ ErrorCall $ "Invalid types for builtins.appendContext: " <> show _xy - _x -> throwError $ ErrorCall $ "Invalid types for context value in builtins.appendContext: " <> show _x - addContext ns newContextValues = - mkNixString - (stringIgnoreContext ns) - (fromNixLikeContext $ - NixLikeContext $ - M.unionWith - (<>) - newContextValues - (getNixLikeContext $ - toNixLikeContext $ - getContext ns - ) - ) - nixVersionNix :: MonadNix e t f m => m (NValue t f m) nixVersionNix = toValue $ mkNixStringWithoutContext "2.3" @@ -1797,112 +1884,118 @@ -- ** @builtinsList@ builtinsList :: forall e t f m . MonadNix e t f m => m [Builtin (NValue t f m)] -builtinsList = sequenceA - [ add0 Normal "nixVersion" nixVersionNix - , add0 Normal "langVersion" langVersionNix - , add TopLevel "abort" throwNix -- for now - , add2 Normal "add" addNix - , add2 Normal "addErrorContext" addErrorContextNix - , add2 Normal "all" allNix - , add2 Normal "any" anyNix - , add2 Normal "appendContext" appendContextNix - , add Normal "attrNames" attrNamesNix - , add Normal "attrValues" attrValuesNix - , add TopLevel "baseNameOf" baseNameOfNix - , add2 Normal "bitAnd" bitAndNix - , add2 Normal "bitOr" bitOrNix - , add2 Normal "bitXor" bitXorNix - , add0 Normal "builtins" builtinsBuiltinNix - , add2 Normal "catAttrs" catAttrsNix - , add2 Normal "compareVersions" compareVersionsNix - , add Normal "concatLists" concatListsNix - , add2 Normal "concatMap" concatMapNix - , add' Normal "concatStringsSep" (arity2 intercalateNixString) - , add0 Normal "currentSystem" currentSystemNix - , add0 Normal "currentTime" currentTimeNix - , add2 Normal "deepSeq" deepSeqNix - , add0 TopLevel "derivation" derivationNix - , add TopLevel "derivationStrict" derivationStrictNix - , add TopLevel "dirOf" dirOfNix - , add2 Normal "div" divNix - , add2 Normal "elem" elemNix - , add2 Normal "elemAt" elemAtNix - , add Normal "exec" execNix - , add0 Normal "false" (pure $ mkNVBool False) - --, add Normal "fetchGit" fetchGit - --, add Normal "fetchMercurial" fetchMercurial - , add Normal "fetchTarball" fetchTarball - , add Normal "fetchurl" fetchurlNix - , add2 Normal "filter" filterNix - --, add Normal "filterSource" filterSource - , add2 Normal "findFile" findFileNix - , add3 Normal "foldl'" foldl'Nix - , add Normal "fromJSON" fromJSONNix - --, add Normal "fromTOML" fromTOML - , add Normal "functionArgs" functionArgsNix - , add Normal "genericClosure" genericClosureNix - , add2 Normal "genList" genListNix - , add2 Normal "getAttr" getAttrNix - , add Normal "getContext" getContextNix - , add Normal "getEnv" getEnvNix - , add2 Normal "hasAttr" hasAttrNix - , add Normal "hasContext" hasContextNix - , add' Normal "hashString" (hashStringNix @e @t @f @m) - , add Normal "head" headNix - , add TopLevel "import" importNix - , add2 Normal "intersectAttrs" intersectAttrsNix - , add Normal "isAttrs" isAttrsNix - , add Normal "isBool" isBoolNix - , add Normal "isFloat" isFloatNix - , add Normal "isFunction" isFunctionNix - , add Normal "isInt" isIntNix - , add Normal "isList" isListNix - , add TopLevel "isNull" isNullNix - , add Normal "isString" isStringNix - , add Normal "length" lengthNix - , add2 Normal "lessThan" lessThanNix - , add Normal "listToAttrs" listToAttrsNix - , add2 TopLevel "map" mapNix - , add2 TopLevel "mapAttrs" mapAttrsNix - , add2 Normal "match" matchNix - , add2 Normal "mul" mulNix - , add0 Normal "nixPath" nixPathNix - , add0 Normal "null" (pure nvNull) - , add Normal "parseDrvName" parseDrvNameNix - , add2 Normal "partition" partitionNix - --, add Normal "path" path - , add Normal "pathExists" pathExistsNix - , add TopLevel "placeholder" placeHolderNix - , add Normal "readDir" readDirNix - , add Normal "readFile" readFileNix - , add2 TopLevel "removeAttrs" removeAttrsNix - , add3 Normal "replaceStrings" replaceStringsNix - , add2 TopLevel "scopedImport" scopedImportNix - , add2 Normal "seq" seqNix - , add2 Normal "sort" sortNix - , add2 Normal "split" splitNix - , add Normal "splitVersion" splitVersionNix - , add0 Normal "storeDir" (pure $ nvStrWithoutContext "/nix/store") - --, add Normal "storePath" storePath - , add' Normal "stringLength" (arity1 $ Text.length . stringIgnoreContext) - , add' Normal "sub" (arity2 ((-) @Integer)) - , add' Normal "substring" substringNix - , add Normal "tail" tailNix - , add TopLevel "throw" throwNix - , add2 Normal "toFile" toFileNix - , add Normal "toJSON" toJSONNix - , add Normal "toPath" toPathNix - , add TopLevel "toString" toStringNix - , add Normal "toXML" toXMLNix - , add2 TopLevel "trace" traceNix - , add0 Normal "true" (pure $ mkNVBool True) - , add Normal "tryEval" tryEvalNix - , add Normal "typeOf" typeOfNix - --, add0 Normal "unsafeDiscardOutputDependency" unsafeDiscardOutputDependency - , add Normal "unsafeDiscardStringContext" unsafeDiscardStringContextNix - , add2 Normal "unsafeGetAttrPos" unsafeGetAttrPosNix - , add Normal "valueSize" getRecursiveSizeNix - ] +builtinsList = + sequenceA + [ add TopLevel "abort" throwNix -- for now + , add TopLevel "baseNameOf" baseNameOfNix + , add0 TopLevel "derivation" derivationNix + , add TopLevel "derivationStrict" derivationStrictNix + , add TopLevel "dirOf" dirOfNix + , add TopLevel "import" importNix + , add TopLevel "isNull" isNullNix + , add2 TopLevel "map" mapNix + , add2 TopLevel "mapAttrs" mapAttrsNix + , add TopLevel "placeholder" placeHolderNix + , add2 TopLevel "removeAttrs" removeAttrsNix + , add2 TopLevel "scopedImport" scopedImportNix + , add TopLevel "throw" throwNix + , add TopLevel "toString" toStringNix + , add2 TopLevel "trace" traceNix + , add0 Normal "nixVersion" nixVersionNix + , add0 Normal "langVersion" langVersionNix + , add2 Normal "add" addNix + , add2 Normal "addErrorContext" addErrorContextNix + , add2 Normal "all" allNix + , add2 Normal "any" anyNix + , add2 Normal "appendContext" appendContextNix + , add Normal "attrNames" attrNamesNix + , add Normal "attrValues" attrValuesNix + , add2 Normal "bitAnd" bitAndNix + , add2 Normal "bitOr" bitOrNix + , add2 Normal "bitXor" bitXorNix + , add0 Normal "builtins" builtinsBuiltinNix + , add2 Normal "catAttrs" catAttrsNix + , add' Normal "ceil" (arity1 (ceiling @Float @Integer)) + , add2 Normal "compareVersions" compareVersionsNix + , add Normal "concatLists" concatListsNix + , add2 Normal "concatMap" concatMapNix + , add' Normal "concatStringsSep" (arity2 intercalateNixString) + , add0 Normal "currentSystem" currentSystemNix + , add0 Normal "currentTime" currentTimeNix + , add2 Normal "deepSeq" deepSeqNix + , add2 Normal "div" divNix + , add2 Normal "elem" elemNix + , add2 Normal "elemAt" elemAtNix + , add Normal "exec" execNix + , add0 Normal "false" (pure $ mkNVBool False) + --, add Normal "fetchGit" fetchGit + --, add Normal "fetchMercurial" fetchMercurial + , add Normal "fetchTarball" fetchTarball + , add Normal "fetchurl" fetchurlNix + , add2 Normal "filter" filterNix + --, add Normal "filterSource" filterSource + , add2 Normal "findFile" findFileNix + , add' Normal "floor" (arity1 (floor @Float @Integer)) + , add3 Normal "foldl'" foldl'Nix + , add Normal "fromJSON" fromJSONNix + --, add Normal "fromTOML" fromTOML + , add Normal "functionArgs" functionArgsNix + , add Normal "genericClosure" genericClosureNix + , add2 Normal "genList" genListNix + , add2 Normal "getAttr" getAttrNix + , add Normal "getContext" getContextNix + , add Normal "getEnv" getEnvNix + , add2 Normal "groupBy" groupByNix + , add2 Normal "hasAttr" hasAttrNix + , add Normal "hasContext" hasContextNix + , add' Normal "hashString" (hashStringNix @e @t @f @m) + , add' Normal "hashFile" hashFileNix + , add Normal "head" headNix + , add2 Normal "intersectAttrs" intersectAttrsNix + , add Normal "isAttrs" isAttrsNix + , add Normal "isBool" isBoolNix + , add Normal "isFloat" isFloatNix + , add Normal "isFunction" isFunctionNix + , add Normal "isInt" isIntNix + , add Normal "isList" isListNix + , add Normal "isString" isStringNix + , add Normal "isPath" isPathNix + , add Normal "length" lengthNix + , add2 Normal "lessThan" lessThanNix + , add Normal "listToAttrs" listToAttrsNix + , add2 Normal "match" matchNix + , add2 Normal "mul" mulNix + , add0 Normal "nixPath" nixPathNix + , add0 Normal "null" (pure nvNull) + , add Normal "parseDrvName" parseDrvNameNix + , add2 Normal "partition" partitionNix + , add Normal "path" pathNix + , add Normal "pathExists" pathExistsNix + , add Normal "readDir" readDirNix + , add Normal "readFile" readFileNix + , add3 Normal "replaceStrings" replaceStringsNix + , add2 Normal "seq" seqNix + , add2 Normal "sort" sortNix + , add2 Normal "split" splitNix + , add Normal "splitVersion" splitVersionNix + , add0 Normal "storeDir" (pure $ mkNVStrWithoutContext "/nix/store") + --, add Normal "storePath" storePath + , add' Normal "stringLength" (arity1 $ Text.length . ignoreContext) + , add' Normal "sub" (arity2 ((-) @Integer)) + , add' Normal "substring" substringNix + , add Normal "tail" tailNix + , add2 Normal "toFile" toFileNix + , add Normal "toJSON" toJSONNix + , add Normal "toPath" toPathNix + , add Normal "toXML" toXMLNix + , add0 Normal "true" (pure $ mkNVBool True) + , add Normal "tryEval" tryEvalNix + , add Normal "typeOf" typeOfNix + , add Normal "unsafeDiscardOutputDependency" unsafeDiscardOutputDependencyNix + , add Normal "unsafeDiscardStringContext" unsafeDiscardStringContextNix + , add2 Normal "unsafeGetAttrPos" unsafeGetAttrPosNix + , add Normal "valueSize" getRecursiveSizeNix + ] where arity0 :: a -> Prim m a @@ -1991,13 +2084,11 @@ -> m r withNixContext mpath action = do - base <- builtins - opts :: Options <- asks $ view hasLens - let - i = nvList $ nvStrWithoutContext . toText <$> include opts + base <- builtins + opts <- askOptions pushScope - (coerce $ M.fromList $ one ("__includes", i)) + (one ("__includes", mkNVList $ mkNVStrWithoutContext . fromString . coerce <$> getInclude opts)) (pushScopes base $ maybe @@ -2005,8 +2096,7 @@ (\ path act -> do traceM $ "Setting __cur_file = " <> show path - let ref = nvPath path - pushScope (coerce $ M.fromList $ one ("__cur_file", ref)) act + pushScope (one ("__cur_file", mkNVPath path)) act ) mpath action @@ -2020,9 +2110,8 @@ => m (Scopes m (NValue t f m)) builtins = do - ref <- defer $ nvSet mempty <$> buildMap - lst <- (one ("builtins", ref) <>) <$> topLevelBuiltins - pushScope (coerce (M.fromList lst)) currentScopes + ref <- defer $ mkNVSet mempty <$> buildMap + (`pushScope` askScopes) . coerce . M.fromList . (one ("builtins", ref) <>) =<< topLevelBuiltins where buildMap :: m (HashMap VarName (NValue t f m)) buildMap = M.fromList . (mapping <$>) <$> builtinsList @@ -2036,5 +2125,5 @@ nameBuiltins :: Builtin v -> Builtin v nameBuiltins b@(Builtin TopLevel _) = b nameBuiltins (Builtin Normal nB) = - Builtin TopLevel $ first (coerce @Text . ("__" <>) . coerce @VarName) nB + Builtin TopLevel $ first (coerce @(Text -> Text) ("__" <>)) nB diff --git a/src/Nix/Cache.hs b/src/Nix/Cache.hs --- a/src/Nix/Cache.hs +++ b/src/Nix/Cache.hs @@ -3,6 +3,7 @@ -- | Reading and writing Nix cache files module Nix.Cache where +import Nix.Prelude import qualified Data.ByteString.Lazy as BSL import Nix.Expr.Types.Annotated diff --git a/src/Nix/Cited.hs b/src/Nix/Cited.hs --- a/src/Nix/Cited.hs +++ b/src/Nix/Cited.hs @@ -5,6 +5,7 @@ module Nix.Cited where +import Nix.Prelude import Control.Comonad import Control.Comonad.Env import Lens.Family2.TH @@ -16,8 +17,9 @@ data Provenance m v = Provenance - { _lexicalScope :: Scopes m v - , _originExpr :: NExprLocF (Maybe v) + { getLexicalScope :: Scopes m v + -- 2021-11-09: NOTE: Better name? + , getOriginExpr :: NExprLocF (Maybe v) -- ^ When calling the function x: x + 2 with argument x = 3, the -- 'originExpr' for the resulting value will be 3 + 2, while the -- 'contextExpr' will be @(x: x + 2) 3@, preserving not only the @@ -27,8 +29,8 @@ data NCited m v a = NCited - { _provenance :: [Provenance m v] - , _cited :: a + { getProvenance :: [Provenance m v] + , getCited :: a } deriving (Generic, Typeable, Functor, Foldable, Traversable, Show) @@ -37,11 +39,11 @@ (<*>) (NCited xs f) (NCited ys x) = NCited (xs <> ys) (f x) instance Comonad (NCited m v) where - duplicate p = NCited (_provenance p) p - extract = _cited + duplicate p = NCited (getProvenance p) p + extract = getCited instance ComonadEnv [Provenance m v] (NCited m v) where - ask = _provenance + ask = getProvenance $(makeLenses ''Provenance) $(makeLenses ''NCited) @@ -55,7 +57,7 @@ addProvenance :: Provenance m v -> a -> a instance HasCitations m v (NCited m v a) where - citations = _provenance + citations = getProvenance addProvenance x (NCited p v) = NCited (x : p) v instance HasCitations1 m v f diff --git a/src/Nix/Cited/Basic.hs b/src/Nix/Cited/Basic.hs --- a/src/Nix/Cited/Basic.hs +++ b/src/Nix/Cited/Basic.hs @@ -4,6 +4,7 @@ module Nix.Cited.Basic where +import Nix.Prelude import Control.Comonad ( Comonad ) import Control.Comonad.Env ( ComonadEnv ) import Control.Monad.Catch hiding ( catchJust ) @@ -79,26 +80,28 @@ thunk :: m v -> m (Cited u f m t) thunk mv = do - opts :: Options <- asks $ view hasLens + opts <- askOptions bool (cite mempty) - (\ t -> + (\ mt -> do - frames :: Frames <- asks $ view hasLens + frames <- askFrames -- Gather the current evaluation context at the time of thunk -- creation, and record it along with the thunk. let - go :: SomeException -> [Provenance m (NValue u f m)] - go (fromException -> Just (EvaluatingExpr scope (Ann s e))) = + fun :: SomeException -> [Provenance m (NValue u f m)] + fun (fromException -> Just (EvaluatingExpr scope (Ann s e))) = one $ Provenance scope $ AnnF s (Nothing <$ e) - go _ = mempty - ps = foldMap (go . frame) frames + fun _ = mempty - cite ps t + ps :: [Provenance m (NValue u f m)] + ps = foldMap (fun . frame) frames + + cite ps mt ) - (thunks opts) + (isThunks opts) (thunk mv) thunkId :: Cited u f m t -> ThunkId m diff --git a/src/Nix/Context.hs b/src/Nix/Context.hs --- a/src/Nix/Context.hs +++ b/src/Nix/Context.hs @@ -1,6 +1,6 @@ - module Nix.Context where +import Nix.Prelude import Nix.Options ( Options ) import Nix.Scope ( Scopes ) import Nix.Frames ( Frames ) @@ -9,24 +9,25 @@ ) -- 2021-07-18: NOTE: It should be Options -> Scopes -> Frames -> Source(span) -data Context m t = Context - { scopes :: Scopes m t - , source :: SrcSpan - , frames :: Frames - , options :: Options +data Context m t = + Context + { getOptions :: Options + , getScopes :: Scopes m t + , getSource :: SrcSpan + , getFrames :: Frames } instance Has (Context m t) (Scopes m t) where - hasLens f a = (\x -> a { scopes = x }) <$> f (scopes a) + hasLens f a = (\x -> a { getScopes = x }) <$> f (getScopes a) instance Has (Context m t) SrcSpan where - hasLens f a = (\x -> a { source = x }) <$> f (source a) + hasLens f a = (\x -> a { getSource = x }) <$> f (getSource a) instance Has (Context m t) Frames where - hasLens f a = (\x -> a { frames = x }) <$> f (frames a) + hasLens f a = (\x -> a { getFrames = x }) <$> f (getFrames a) instance Has (Context m t) Options where - hasLens f a = (\x -> a { options = x }) <$> f (options a) + hasLens f a = (\x -> a { getOptions = x }) <$> f (getOptions a) newContext :: Options -> Context m t -newContext = Context mempty nullSpan mempty +newContext o = Context o mempty nullSpan mempty diff --git a/src/Nix/Convert.hs b/src/Nix/Convert.hs --- a/src/Nix/Convert.hs +++ b/src/Nix/Convert.hs @@ -15,6 +15,7 @@ module Nix.Convert where +import Nix.Prelude import Control.Monad.Free import qualified Data.HashMap.Lazy as M import Nix.Atoms @@ -68,16 +69,22 @@ fromValue :: v -> m a fromValueMay :: v -> m (Maybe a) -traverseFromM +traverseFromValue :: ( Applicative m , Traversable t , FromValue b m a ) => t a -> m (Maybe (t b)) -traverseFromM = traverseM fromValueMay +traverseFromValue = traverse2 fromValueMay -traverseToValue :: ((Traversable t, Applicative f, ToValue a f b) => t a -> f (t b)) +traverseToValue + :: ( Traversable t + , Applicative f + , ToValue a f b + ) + => t a + -> f (t b) traverseToValue = traverse toValue -- Please, hide these helper function from export, to be sure they get optimized away. @@ -133,9 +140,10 @@ ) => FromValue a m (Deeper (NValue t f m)) where + fromValueMay :: Deeper (NValue t f m) -> m (Maybe a) fromValueMay (Deeper v) = free - ((fromValueMay . Deeper) <=< force) + ((fromValueMay . Deeper) <=< force) -- these places are complex in types (fromValueMay . Deeper) =<< demand v @@ -211,7 +219,7 @@ \case NVStr' ns -> pure $ pure ns NVPath' p -> - (\path -> pure $ mkNixStringWithSingletonContext path (StringContext path DirectPath)) . fromString . coerce <$> + (\path -> pure $ mkNixStringWithSingletonContext (StringContext DirectPath path) path) . fromString . coerce <$> addPath p NVSet' _ s -> maybe @@ -281,7 +289,7 @@ => FromValue [a] m (Deeper (NValue' t f m (NValue t f m))) where fromValueMay = \case - Deeper (NVList' l) -> traverseFromM l + Deeper (NVList' l) -> traverseFromValue l _ -> stub @@ -305,7 +313,7 @@ fromValueMay = \case - Deeper (NVSet' _ s) -> traverseFromM s + Deeper (NVSet' _ s) -> traverseFromValue s _ -> stub fromValue = fromMayToDeeperValue TSet @@ -330,7 +338,7 @@ fromValueMay = \case - Deeper (NVSet' p s) -> (, p) <<$>> traverseFromM s + Deeper (NVSet' p s) -> (, p) <<$>> traverseFromValue s _ -> stub fromValue = fromMayToDeeperValue TSet @@ -363,39 +371,39 @@ instance Convertible e t f m => ToValue () m (NValue' t f m (NValue t f m)) where - toValue _ = pure . nvConstant' $ NNull + toValue = const $ pure nvNull' instance Convertible e t f m => ToValue Bool m (NValue' t f m (NValue t f m)) where - toValue = pure . nvConstant' . NBool + toValue = pure . mkNVConstant' . NBool instance Convertible e t f m => ToValue Int m (NValue' t f m (NValue t f m)) where - toValue = pure . nvConstant' . NInt . toInteger + toValue = pure . mkNVConstant' . NInt . toInteger instance Convertible e t f m => ToValue Integer m (NValue' t f m (NValue t f m)) where - toValue = pure . nvConstant' . NInt + toValue = pure . mkNVConstant' . NInt instance Convertible e t f m => ToValue Float m (NValue' t f m (NValue t f m)) where - toValue = pure . nvConstant' . NFloat + toValue = pure . mkNVConstant' . NFloat instance Convertible e t f m => ToValue NixString m (NValue' t f m (NValue t f m)) where - toValue = pure . nvStr' + toValue = pure . mkNVStr' instance Convertible e t f m => ToValue ByteString m (NValue' t f m (NValue t f m)) where - toValue = pure . nvStr' . mkNixStringWithoutContext . decodeUtf8 + toValue = pure . mkNVStr' . mkNixStringWithoutContext . decodeUtf8 instance Convertible e t f m => ToValue Text m (NValue' t f m (NValue t f m)) where - toValue = pure . nvStr' . mkNixStringWithoutContext + toValue = pure . mkNVStr' . mkNixStringWithoutContext instance Convertible e t f m => ToValue Path m (NValue' t f m (NValue t f m)) where - toValue = pure . nvPath' . coerce + toValue = pure . mkNVPath' . coerce instance Convertible e t f m => ToValue StorePath m (NValue' t f m (NValue t f m)) where @@ -408,40 +416,40 @@ l' <- toValue $ unPos l c' <- toValue $ unPos c let pos = M.fromList [("file" :: VarName, f'), ("line", l'), ("column", c')] - pure $ nvSet' mempty pos + pure $ mkNVSet' mempty pos -- | With 'ToValue', we can always act recursively instance Convertible e t f m => ToValue [NValue t f m] m (NValue' t f m (NValue t f m)) where - toValue = pure . nvList' + toValue = pure . mkNVList' instance (Convertible e t f m , ToValue a m (NValue t f m) ) => ToValue [a] m (Deeper (NValue' t f m (NValue t f m))) where - toValue l = Deeper . nvList' <$> traverseToValue l + toValue l = Deeper . mkNVList' <$> traverseToValue l instance Convertible e t f m => ToValue (AttrSet (NValue t f m)) m (NValue' t f m (NValue t f m)) where - toValue s = pure $ nvSet' mempty s + toValue s = pure $ mkNVSet' mempty s instance (Convertible e t f m, ToValue a m (NValue t f m)) => ToValue (AttrSet a) m (Deeper (NValue' t f m (NValue t f m))) where toValue s = - liftA2 (\ v s -> Deeper $ nvSet' s v) + liftA2 (\ v s -> Deeper $ mkNVSet' s v) (traverseToValue s) stub instance Convertible e t f m => ToValue (AttrSet (NValue t f m), PositionSet) m (NValue' t f m (NValue t f m)) where - toValue (s, p) = pure $ nvSet' p s + toValue (s, p) = pure $ mkNVSet' p s instance (Convertible e t f m, ToValue a m (NValue t f m)) => ToValue (AttrSet a, PositionSet) m (Deeper (NValue' t f m (NValue t f m))) where toValue (s, p) = - liftA2 (\ v s -> Deeper $ nvSet' s v) + liftA2 (\ v s -> Deeper $ mkNVSet' s v) (traverseToValue s) (pure p) @@ -465,14 +473,14 @@ (pure Nothing) (fmap pure . toValue) ts - pure $ nvSet' mempty $ M.fromList $ catMaybes + pure $ mkNVSet' mempty $ M.fromList $ catMaybes [ ("path" ,) <$> path , ("allOutputs",) <$> allOutputs , ("outputs" ,) <$> outputs ] instance Convertible e t f m => ToValue () m (NExprF (NValue t f m)) where - toValue _ = pure . NConstant $ NNull + toValue = const . pure . NConstant $ NNull instance Convertible e t f m => ToValue Bool m (NExprF (NValue t f m)) where toValue = pure . NConstant . NBool diff --git a/src/Nix/Effects.hs b/src/Nix/Effects.hs --- a/src/Nix/Effects.hs +++ b/src/Nix/Effects.hs @@ -12,9 +12,10 @@ module Nix.Effects where -import Prelude hiding ( putStrLn +import Nix.Prelude hiding ( putStrLn , print ) +import qualified Nix.Prelude as Prelude import GHC.Exception ( ErrorCall(ErrorCall) ) import qualified Data.HashSet as HS import qualified Data.Text as Text @@ -432,6 +433,8 @@ pure =<< addTextToStore' a b c d +-- 2021-10-30: NOTE: Misleading name, please rename. +-- | Add @Path@ into the Nix Store addPath :: (Framed e m, MonadStore m) => Path -> m StorePath addPath p = either @@ -440,4 +443,4 @@ =<< addToStore (fromString $ coerce takeFileName p) p True False toFile_ :: (Framed e m, MonadStore m) => Path -> Text -> m StorePath -toFile_ p contents = addTextToStore (toText p) contents mempty False +toFile_ p contents = addTextToStore (fromString $ coerce p) contents mempty False diff --git a/src/Nix/Effects/Basic.hs b/src/Nix/Effects/Basic.hs --- a/src/Nix/Effects/Basic.hs +++ b/src/Nix/Effects/Basic.hs @@ -2,7 +2,7 @@ module Nix.Effects.Basic where -import Prelude hiding ( head +import Nix.Prelude hiding ( head ) import Relude.Unsafe ( head ) import GHC.Exception ( ErrorCall(ErrorCall) ) @@ -144,7 +144,7 @@ tryPath path $ whenJust (\ nsPfx -> - let pfx = stringIgnoreContext nsPfx in + let pfx = ignoreContext nsPfx in pure $ coerce $ toString pfx `whenFalse` Text.null pfx ) mns @@ -191,7 +191,7 @@ -> m (NValue t f m) fetchFromString msha = \case - NVStr ns -> fetch (stringIgnoreContext ns) msha + NVStr ns -> fetch (ignoreContext ns) msha v -> throwError $ ErrorCall $ "builtins.fetchTarball: Expected URI or string, got " <> show v {- jww (2018-04-11): This should be written using pipes in another module @@ -216,7 +216,7 @@ do nsSha <- fromValue =<< demand v - let sha = stringIgnoreContext nsSha + let sha = ignoreContext nsSha nixInstantiateExpr $ "builtins.fetchTarball { " <> "url = \"" <> uri <> "\"; " <> "sha256 = \"" <> sha <> "\"; }" diff --git a/src/Nix/Effects/Derivation.hs b/src/Nix/Effects/Derivation.hs --- a/src/Nix/Effects/Derivation.hs +++ b/src/Nix/Effects/Derivation.hs @@ -5,7 +5,7 @@ module Nix.Effects.Derivation ( defaultDerivationStrict ) where -import Prelude hiding ( readFile ) +import Nix.Prelude hiding ( readFile ) import GHC.Exception ( ErrorCall(ErrorCall) ) import Data.Char ( isAscii , isAlphaNum @@ -31,7 +31,7 @@ , callFunc ) import Nix.Frames -import Nix.Json ( nvalueToJSONNixString ) +import Nix.Json ( toJSONNixString ) import Nix.Render import Nix.String import Nix.String.Coerce @@ -289,13 +289,13 @@ let outputsWithContext = Map.mapWithKey - (\out (coerce -> path) -> mkNixStringWithSingletonContext path $ StringContext drvPath $ DerivationOutput out) + (\out (coerce -> path) -> mkNixStringWithSingletonContext (StringContext (DerivationOutput out) drvPath) path) (outputs drv') - drvPathWithContext = mkNixStringWithSingletonContext drvPath $ StringContext drvPath AllOutputs - attrSet = nvStr <$> M.fromList (("drvPath", drvPathWithContext) : Map.toList outputsWithContext) + drvPathWithContext = mkNixStringWithSingletonContext (StringContext AllOutputs drvPath) drvPath + attrSet = mkNVStr <$> M.fromList (("drvPath", drvPathWithContext) : Map.toList outputsWithContext) -- TODO: Add location information for all the entries. -- here --v - pure $ nvSet mempty (M.mapKeys coerce attrSet) + pure $ mkNVSet mempty $ M.mapKeys coerce attrSet where @@ -309,13 +309,14 @@ toStorePaths = foldl (flip addToInputs) mempty addToInputs :: Bifunctor p => StringContext -> p (Set Text) (Map Text [Text]) -> p (Set Text) (Map Text [Text]) - addToInputs (StringContext path kind) = case kind of - DirectPath -> first (Set.insert (coerce path)) - DerivationOutput o -> second (Map.insertWith (<>) (coerce path) $ one o) - AllOutputs -> - -- TODO: recursive lookup. See prim_derivationStrict - -- XXX: When is this really used ? - error "Not implemented: derivations depending on a .drv file are not yet supported." + addToInputs (StringContext kind (coerce -> path)) = + case kind of + DirectPath -> first $ Set.insert path + DerivationOutput o -> second $ Map.insertWith (<>) path $ one o + AllOutputs -> + -- TODO: recursive lookup. See prim_derivationStrict + -- XXX: When is this really used ? + error "Not implemented: derivations depending on a .drv file are not yet supported." -- | Build a derivation in a context collecting string contexts. @@ -367,12 +368,12 @@ env <- if useJson then do - jsonString :: NixString <- lift $ nvalueToJSONNixString $ nvSet mempty $ M.mapKeys coerce $ + jsonString :: NixString <- lift $ toJSONNixString $ mkNVSet mempty $ M.mapKeys coerce $ deleteKeys [ "args", "__ignoreNulls", "__structuredAttrs" ] attrs rawString :: Text <- extractNixString jsonString pure $ one ("__json", rawString) else - traverse (extractNixString <=< lift . coerceToString callFunc CopyToStore CoerceAny) $ + traverse (extractNixString <=< lift . coerceAnyToNixString callFunc CopyToStore) $ Map.fromList $ M.toList $ deleteKeys [ "args", "__ignoreNulls" ] attrs pure $ Derivation { platform, builder, args, env, hashMode, useJson diff --git a/src/Nix/Eval.hs b/src/Nix/Eval.hs --- a/src/Nix/Eval.hs +++ b/src/Nix/Eval.hs @@ -3,9 +3,9 @@ {-# language RankNTypes #-} - module Nix.Eval where +import Nix.Prelude import Relude.Extra ( set ) import Control.Monad ( foldM ) import Control.Monad.Fix ( MonadFix ) @@ -84,7 +84,7 @@ data EvalFrame m v = EvaluatingExpr (Scopes m v) NExprLoc | ForcingExpr (Scopes m v) NExprLoc - | Calling Text SrcSpan + | Calling VarName SrcSpan | SynHole (SynHoleInfo m v) deriving (Show, Typeable) @@ -122,7 +122,7 @@ eval (NBinary NApp fun arg) = do f <- fun - scope <- currentScopes :: m (Scopes m v) + scope <- askScopes evalApp f $ withScopes scope arg eval (NBinary op larg rarg) = @@ -144,7 +144,7 @@ eval (NList l ) = do - scope <- currentScopes + scope <- askScopes toValue =<< traverse (defer @v @m . withScopes @v scope) l eval (NSet r binds) = @@ -174,7 +174,7 @@ -- needs to be used when evaluating the body and default arguments, hence we -- defer here so the present scope is restored when the parameters and body -- are forced during application. - curScope <- currentScopes + curScope <- askScopes let withCurScope = withScopes curScope @@ -199,7 +199,7 @@ -- this implementation may be used as an implementation for 'evalWith'. evalWithAttrSet :: forall v m . MonadNixEval v m => m v -> m v -> m v evalWithAttrSet aset body = do - scopes <- currentScopes :: m (Scopes m v) + scopes <- askScopes -- The scope is deliberately wrapped in a thunk here, since it is demanded -- 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 @@ -259,39 +259,40 @@ , AttrSet (m v) ) recurse p'' m'' = - fmap - (insertVal . (=<<) (toValue @(AttrSet v, PositionSet)) . fmap (,mempty) . sequenceA . snd) - (go p'' m'' ks) + insertVal . ((toValue @(AttrSet v, PositionSet)) <=< ((,mempty) <$>) . sequenceA . snd) <$> go p'' m'' ks desugarBinds :: forall r . ([Binding r] -> r) -> [Binding r] -> [Binding r] -desugarBinds embed binds = evalState (traverse (findBinding <=< collect) binds) mempty +desugarBinds embed = (`evalState` mempty) . traverse (findBinding <=< collect) where collect :: Binding r -> State - (HashMap VarName (SourcePos, [Binding r])) + (AttrSet (SourcePos, [Binding r])) (Either VarName (Binding r)) - collect (NamedVar (StaticKey x :| y : ys) val p) = + collect (NamedVar (StaticKey x :| y : ys) val oldPosition) = do - m <- get - put $ - join - (M.insert - x - . maybe - (p, one $ bindValAt p) - (\ (sp, bnd) -> (sp, one (bindValAt sp) <> bnd)) - . M.lookup x - ) - m + modify updateBindingInformation pure $ Left x where - bindValAt = NamedVar (y :| ys) val + updateBindingInformation + :: AttrSet (SourcePos, [Binding r]) + -> AttrSet (SourcePos, [Binding r]) + updateBindingInformation = + M.insert x + =<< maybe + (mkBindingSingleton oldPosition) + (\ (foundPosition, newBindings) -> second (<> newBindings) $ mkBindingSingleton foundPosition) + . M.lookup x + mkBindingSingleton :: SourcePos -> (SourcePos, [Binding r]) + mkBindingSingleton np = (np , one $ bindValAt np) + where + bindValAt :: SourcePos -> Binding r + bindValAt = NamedVar (y :| ys) val collect x = pure $ pure x findBinding :: Either VarName (Binding r) - -> State (HashMap VarName (SourcePos, [Binding r])) (Binding r) + -> State (AttrSet (SourcePos, [Binding r])) (Binding r) findBinding = either (\ x -> @@ -312,7 +313,7 @@ -> m (AttrSet v, PositionSet) evalBinds isRecursive binds = do - scope <- currentScopes :: m (Scopes m v) + scope <- askScopes buildResult scope . fold =<< (`traverse` moveOverridesLast binds) (applyBindToAdt scope) @@ -466,8 +467,7 @@ \case StaticKey k -> pure $ pure k DynamicKey k -> - (coerce . stringIgnoreContext) <<$>> - runAntiquoted "\n" assembleString (fromValueMay =<<) k + coerce . ignoreContext <<$>> runAntiquoted "\n" assembleString (fromValueMay =<<) k assembleString :: forall v m @@ -477,7 +477,7 @@ assembleString = fromParts . stringParts where fromParts :: [Antiquoted Text (m v)] -> m (Maybe NixString) - fromParts xs = fold <<$>> traverseM fun xs + fromParts xs = fold <<$>> traverse2 fun xs fun :: Antiquoted Text (m v) -> m (Maybe NixString) fun = @@ -490,7 +490,7 @@ :: forall v m . MonadNixEval v m => Params (m v) -> m v -> m (AttrSet v) buildArgument params arg = do - scope <- currentScopes :: m (Scopes m v) + scope <- askScopes let argThunk = defer $ withScopes scope arg case params of @@ -548,7 +548,7 @@ => TransformF NExprLoc (m a) addStackFrames f v = do - scopes <- currentScopes :: m (Scopes m v) + scopes <- askScopes -- sectioning gives GHC optimization -- If opimization question would arrive again, check the @(`withFrameInfo` f v) $ EvaluatingExpr scopes v@ @@ -557,15 +557,15 @@ where withFrameInfo = withFrame Info -framedEvalExprLoc +evalWithMetaInfo :: forall e v m . (MonadNixEval v m, Framed e m, Has e SrcSpan, Typeable m, Typeable v) => NExprLoc -> m v -framedEvalExprLoc = +evalWithMetaInfo = adi addMetaInfo evalContent --- | Add source postionss & frame context system. +-- | Add source positions & frame context system. addMetaInfo :: forall v m e a . (Framed e m, Scoped v m, Has e SrcSpan, Typeable m, Typeable v) diff --git a/src/Nix/Exec.hs b/src/Nix/Exec.hs --- a/src/Nix/Exec.hs +++ b/src/Nix/Exec.hs @@ -12,7 +12,7 @@ module Nix.Exec where -import Prelude hiding ( putStr +import Nix.Prelude hiding ( putStr , putStrLn , print ) @@ -44,7 +44,7 @@ import Prettyprinter import qualified Text.Show.Pretty as PS -#ifdef MIN_VERSION_ghc_datasize +#ifdef MIN_VERSION_ghc_datasize import GHC.DataSize #endif @@ -54,57 +54,66 @@ , MonadDataContext f m ) -nvConstantP +mkNVConstantWithProvenance :: MonadCited t f m - => Provenance m (NValue t f m) + => Scopes m (NValue t f m) + -> SrcSpan -> NAtom -> NValue t f m -nvConstantP p x = addProvenance p $ nvConstant x +mkNVConstantWithProvenance scopes span x = + addProvenance (Provenance scopes . NConstantAnnF span $ x) $ mkNVConstant x -nvStrP +mkNVStrWithProvenance :: MonadCited t f m - => Provenance m (NValue t f m) + => Scopes m (NValue t f m) + -> SrcSpan -> NixString -> NValue t f m -nvStrP p ns = addProvenance p $ nvStr ns +mkNVStrWithProvenance scopes span x = + addProvenance (Provenance scopes . NStrAnnF span . DoubleQuoted . one . Plain . ignoreContext $ x) $ mkNVStr x -nvPathP +mkNVPathWithProvenance :: MonadCited t f m - => Provenance m (NValue t f m) + => Scopes m (NValue t f m) + -> SrcSpan -> Path + -> Path -> NValue t f m -nvPathP p x = addProvenance p $ nvPath x +mkNVPathWithProvenance scope span lit real = + addProvenance (Provenance scope . NLiteralPathAnnF span $ lit) $ mkNVPath real -nvListP +mkNVClosureWithProvenance :: MonadCited t f m - => Provenance m (NValue t f m) - -> [NValue t f m] + => Scopes m (NValue t f m) + -> SrcSpan + -> Params () + -> (NValue t f m -> m (NValue t f m)) -> NValue t f m -nvListP p l = addProvenance p $ nvList l +mkNVClosureWithProvenance scopes span x f = + addProvenance (Provenance scopes $ NAbsAnnF span (Nothing <$ x) Nothing) $ mkNVClosure x f -nvSetP +mkNVUnaryOpWithProvenance :: MonadCited t f m - => Provenance m (NValue t f m) - -> PositionSet - -> AttrSet (NValue t f m) + => Scopes m (NValue t f m) + -> SrcSpan + -> NUnaryOp + -> Maybe (NValue t f m) -> NValue t f m -nvSetP p x s = addProvenance p $ nvSet x s - -nvClosureP - :: MonadCited t f m - => Provenance m (NValue t f m) - -> Params () - -> (NValue t f m -> m (NValue t f m)) -> NValue t f m -nvClosureP p x f = addProvenance p $ nvClosure x f +mkNVUnaryOpWithProvenance scope span op val = + addProvenance (Provenance scope $ NUnaryAnnF span op val) -nvBuiltinP +mkNVBinaryOpWithProvenance :: MonadCited t f m - => Provenance m (NValue t f m) - -> VarName - -> (NValue t f m -> m (NValue t f m)) + => Scopes m (NValue t f m) + -> SrcSpan + -> NBinaryOp + -> Maybe (NValue t f m) + -> Maybe (NValue t f m) -> NValue t f m -nvBuiltinP p name f = addProvenance p $ nvBuiltin name f + -> NValue t f m +mkNVBinaryOpWithProvenance scope span op lval rval = + addProvenance (Provenance scope $ NBinaryAnnF span op lval rval) type MonadCitedThunks t f m = ( MonadThunk t m (NValue t f m) @@ -135,8 +144,8 @@ nverr :: forall e t f s m a . (MonadNix e t f m, Exception s) => s -> m a nverr = evalError @(NValue t f m) -currentPos :: forall e m . (MonadReader e m, Has e SrcSpan) => m SrcSpan -currentPos = asks $ view hasLens +askSpan :: forall e m . (MonadReader e m, Has e SrcSpan) => m SrcSpan +askSpan = askLocal wrapExprLoc :: SrcSpan -> NExprLocF r -> NExprLoc wrapExprLoc span x = Fix $ NSymAnn span "" <$ x @@ -148,147 +157,141 @@ freeVariable var = nverr @e @t @f $ ErrorCall $ toString @Text $ "Undefined variable '" <> coerce var <> "'" - synHole name = do - span <- currentPos - scope <- currentScopes - evalError @(NValue t f m) $ SynHole $ - SynHoleInfo - { _synHoleInfo_expr = NSynHoleAnn span name - , _synHoleInfo_scope = scope - } + synHole name = + do + span <- askSpan + scope <- askScopes + evalError @(NValue t f m) $ SynHole $ + SynHoleInfo + { _synHoleInfo_expr = NSynHoleAnn span name + , _synHoleInfo_scope = scope + } attrMissing ks ms = evalError @(NValue t f m) $ ErrorCall $ toString $ maybe ("Inheriting unknown attribute: " <> attr) - (\ s -> - "Could not look up attribute " <> attr <> " in " <> show (prettyNValue s) - ) + (\ s -> "Could not look up attribute " <> attr <> " in " <> show (prettyNValue s)) ms where attr = Text.intercalate "." $ NE.toList $ coerce ks - evalCurPos = do - scope <- currentScopes - span@(SrcSpan delta _) <- currentPos - addProvenance @_ @_ @(NValue t f m) - (Provenance scope $ NSymAnnF span (coerce @Text "__curPos")) <$> - toValue delta - - evaledSym name val = do - scope <- currentScopes - span <- currentPos - pure $ + evalCurPos = + do + scope <- askScopes + span@(SrcSpan delta _) <- askSpan addProvenance @_ @_ @(NValue t f m) - (Provenance scope $ NSymAnnF span name) - val + (Provenance scope . NSymAnnF span $ coerce @Text "__curPos") <$> + toValue delta - evalConstant c = do - scope <- currentScopes - span <- currentPos - pure $ join (nvConstantP . Provenance scope . NConstantAnnF span) c + evaledSym name val = + do + scope <- askScopes + span <- askSpan + pure $ + addProvenance @_ @_ @(NValue t f m) + (Provenance scope $ NSymAnnF span name) + val + evalConstant c = + do + scope <- askScopes + span <- askSpan + pure $ mkNVConstantWithProvenance scope span c + evalString = maybe (nverr $ ErrorCall "Failed to assemble string") (\ ns -> do - scope <- currentScopes - span <- currentPos - pure $ - join - (nvStrP - . Provenance - scope - . NStrAnnF span . DoubleQuoted . one . Plain . stringIgnoreContext - ) - ns + scope <- askScopes + span <- askSpan + pure $ mkNVStrWithProvenance scope span ns ) <=< assembleString - evalLiteralPath p = do - scope <- currentScopes - span <- currentPos - let - evalPath :: Path -> m (NValue t f m) - evalPath p1 = - fmap - (g p1) - (f p1) - where - g :: Path -> Path -> NValue t f m - g = nvPathP . Provenance scope . NLiteralPathAnnF span - f :: Path -> m Path - f = toAbsolutePath @t @f @m - evalPath p + evalLiteralPath p = + do + scope <- askScopes + span <- askSpan + mkNVPathWithProvenance scope span p <$> toAbsolutePath @t @f @m p - evalEnvPath p = do - scope <- currentScopes - span <- currentPos - nvPathP (Provenance scope $ NEnvPathAnnF span p) <$> - findEnvPath @t @f @m (coerce p) + evalEnvPath p = + do + scope <- askScopes + span <- askSpan + mkNVPathWithProvenance scope span p <$> findEnvPath @t @f @m (coerce p) - evalUnary op arg = do - scope <- currentScopes - span <- currentPos - execUnaryOp scope span op arg + evalUnary op arg = + do + scope <- askScopes + span <- askSpan + execUnaryOp scope span op arg - evalBinary op larg rarg = do - scope <- currentScopes - span <- currentPos - execBinaryOp scope span op larg rarg + evalBinary op larg rarg = + do + scope <- askScopes + span <- askSpan + execBinaryOp scope span op larg rarg - evalWith c b = do - scope <- currentScopes - span <- currentPos - let f = join $ addProvenance . Provenance scope . NWithAnnF span Nothing . pure - f <$> evalWithAttrSet c b + evalWith c b = + do + scope <- askScopes + span <- askSpan + let f = join $ addProvenance . Provenance scope . NWithAnnF span Nothing . pure + f <$> evalWithAttrSet c b - evalIf c tVal fVal = do - scope <- currentScopes - span <- currentPos - bl <- fromValue c + evalIf c tVal fVal = + do + scope <- askScopes + span <- askSpan + bl <- fromValue c - let - fun x y = addProvenance (Provenance scope $ NIfAnnF span (pure c) x y) - -- Note: join acts as \ f x -> f x x - falseVal = join (fun Nothing . pure) <$> fVal - trueVal = join (flip fun Nothing . pure) <$> tVal + let + fun x y = addProvenance (Provenance scope $ NIfAnnF span (pure c) x y) + falseVal = (fun Nothing =<< pure) <$> fVal + trueVal = (flip fun Nothing =<< pure) <$> tVal - bool - falseVal - trueVal - bl + bool + falseVal + trueVal + bl evalAssert c body = do - span <- currentPos + span <- askSpan b <- fromValue c bool (nverr $ Assertion span c) (do - scope <- currentScopes + scope <- askScopes join (addProvenance . Provenance scope . NAssertAnnF span (pure c) . pure) <$> body ) b - evalApp f x = do - scope <- currentScopes - span <- currentPos - addProvenance (Provenance scope $ NBinaryAnnF span NApp (pure f) Nothing) <$> - (callFunc f =<< defer x) + evalApp f x = + do + scope <- askScopes + span <- askSpan + mkNVBinaryOpWithProvenance scope span NApp (pure f) Nothing <$> (callFunc f =<< defer x) - evalAbs p k = do - let - fk = flip k - scope <- currentScopes - span <- currentPos - pure $ - nvClosureP - (Provenance scope $ NAbsAnnF span (Nothing <$ p) Nothing) - (void p) - $ fmap snd . fk (const $ fmap ((), )) . pure + evalAbs + :: Params (m (NValue t f m)) + -> ( forall a + . m (NValue t f m) + -> ( AttrSet (m (NValue t f m)) + -> m (NValue t f m) + -> m (a, NValue t f m) + ) + -> m (a, NValue t f m) + ) + -> m (NValue t f m) + evalAbs p k = + do + scope <- askScopes + span <- askSpan + pure $ mkNVClosureWithProvenance scope span (void p) (fmap snd . flip (k @()) (const (fmap (mempty ,))) . pure) evalError = throwError @@ -301,7 +304,7 @@ -> m (NValue t f m) callFunc fun arg = do - frames :: Frames <- asks $ view hasLens + frames <- askFrames when (length frames > 2000) $ throwError $ ErrorCall "Function call stack exhausted" fun' <- demand fun @@ -309,14 +312,15 @@ NVClosure _params f -> f arg NVBuiltin name f -> do - span <- currentPos - withFrame Info ((Calling @m @(NValue t f m)) (coerce name) span) $ f arg -- Is this cool? + span <- askSpan + withFrame Info ((Calling @m @(NValue t f m)) name span) $ f arg -- Is this cool? (NVSet _ m) | Just f <- M.lookup "__functor" m -> - (`callFunc` arg) =<< (`callFunc` fun') =<< demand f + (`callFunc` arg) =<< (`callFunc` fun') f _x -> throwError $ ErrorCall $ "Attempt to call non-function: " <> show _x execUnaryOp - :: (Framed e m, MonadCited t f m, Show t) + :: forall e t f m + . (Framed e m, MonadCited t f m, Show t) => Scopes m (NValue t f m) -> SrcSpan -> NUnaryOp @@ -326,15 +330,16 @@ case arg of NVConstant c -> case (op, c) of - (NNeg, NInt i) -> unaryOp $ NInt ( - i) - (NNeg, NFloat f) -> unaryOp $ NFloat ( - f) - (NNot, NBool b) -> unaryOp $ NBool (not b) + (NNeg, NInt i) -> mkUnaryOp NInt negate i + (NNeg, NFloat f) -> mkUnaryOp NFloat negate f + (NNot, NBool b) -> mkUnaryOp NBool not b _seq -> throwError $ ErrorCall $ "unsupported argument type for unary operator " <> show _seq _x -> throwError $ ErrorCall $ "argument to unary operator must evaluate to an atomic type: " <> show _x where - unaryOp = pure . nvConstantP (Provenance scope $ NUnaryAnnF span op $ pure arg) + mkUnaryOp :: (a -> NAtom) -> (a -> a) -> a -> m (NValue t f m) + mkUnaryOp c b a = pure . mkNVUnaryOpWithProvenance scope span op (pure arg) . mkNVConstant $ c (b a) execBinaryOp :: forall e t f m @@ -385,10 +390,7 @@ toBoolOp :: Maybe (NValue t f m) -> Bool -> m (NValue t f m) toBoolOp r b = - pure $ - nvConstantP - (Provenance scope $ NBinaryAnnF span op (pure lval) r) - (NBool b) + pure $ mkNVBinaryOpWithProvenance scope span op (pure lval) r $ mkNVConstant $ NBool b execBinaryOpForced :: forall e t f m @@ -400,92 +402,105 @@ -> NValue t f m -> m (NValue t f m) -execBinaryOpForced scope span op lval rval = case op of - NLt -> compare (<) - NLte -> compare (<=) - NGt -> compare (>) - NGte -> compare (>=) - NMinus -> numBinOp (-) - NMult -> numBinOp (*) - NDiv -> numBinOp' div (/) - NConcat -> - case (lval, rval) of - (NVList ls, NVList rs) -> pure $ nvListP prov $ ls <> rs - _ -> unsupportedTypes - - NUpdate -> - case (lval, rval) of - (NVSet lp ls, NVSet rp rs) -> pure $ nvSetP prov (rp <> lp) (rs <> ls) - (NVSet lp ls, NVConstant NNull) -> pure $ nvSetP prov lp ls - (NVConstant NNull, NVSet rp rs) -> pure $ nvSetP prov rp rs - _ -> unsupportedTypes +execBinaryOpForced scope span op lval rval = + case op of + NLt -> mkCmpOp (<) + NLte -> mkCmpOp (<=) + NGt -> mkCmpOp (>) + NGte -> mkCmpOp (>=) + NMinus -> mkBinNumOp (-) + NMult -> mkBinNumOp (*) + NDiv -> mkBinNumOp' div (/) + NConcat -> + case (lval, rval) of + (NVList ls, NVList rs) -> pure $ mkListP $ ls <> rs + _ -> unsupportedTypes - NPlus -> - case (lval, rval) of - (NVConstant _, NVConstant _) -> numBinOp (+) + NUpdate -> + case (lval, rval) of + (NVSet lp ls, NVSet rp rs) -> pure $ mkSetP (rp <> lp) (rs <> ls) + (NVSet lp ls, NVConstant NNull) -> pure $ mkSetP lp ls + (NVConstant NNull, NVSet rp rs) -> pure $ mkSetP rp rs + _ -> unsupportedTypes - (NVStr ls, NVStr rs) -> pure $ nvStrP prov (ls <> rs) - (NVStr ls, rs@NVPath{}) -> - (\rs2 -> nvStrP prov (ls <> rs2)) <$> - coerceToString callFunc CopyToStore CoerceStringy rs - (NVPath ls, NVStr rs) -> - maybe - (throwError $ ErrorCall "A string that refers to a store path cannot be appended to a path.") -- data/nix/src/libexpr/eval.cc:1412 - (\ rs2 -> - nvPathP prov <$> - toAbsolutePath @t @f (ls <> coerce (toString rs2)) - ) - (getStringNoContext rs) - (NVPath ls, NVPath rs) -> nvPathP prov <$> toAbsolutePath @t @f (ls <> rs) + NPlus -> + case (lval, rval) of + (NVConstant _, NVConstant _) -> mkBinNumOp (+) + (NVStr ls, NVStr rs) -> pure $ mkStrP (ls <> rs) + (NVStr ls, NVPath p) -> + mkStrP . (ls <>) <$> + coercePathToNixString CopyToStore p + (NVPath ls, NVStr rs) -> + maybe + (throwError $ ErrorCall "A string that refers to a store path cannot be appended to a path.") -- data/nix/src/libexpr/eval.cc:1412 + (\ rs2 -> mkPathP <$> toAbsolutePath @t @f (ls <> coerce (toString rs2))) + (getStringNoContext rs) + (NVPath ls, NVPath rs) -> mkPathP <$> toAbsolutePath @t @f (ls <> rs) - (ls@NVSet{}, NVStr rs) -> - (\ls2 -> nvStrP prov (ls2 <> rs)) <$> - coerceToString callFunc DontCopyToStore CoerceStringy ls - (NVStr ls, rs@NVSet{}) -> - (\rs2 -> nvStrP prov (ls <> rs2)) <$> - coerceToString callFunc DontCopyToStore CoerceStringy rs - _ -> unsupportedTypes + (ls@NVSet{}, NVStr rs) -> + mkStrP . (<> rs) <$> + coerceAnyToNixString callFunc DontCopyToStore ls + (NVStr ls, rs@NVSet{}) -> + mkStrP . (ls <>) <$> + coerceAnyToNixString callFunc DontCopyToStore rs + _ -> unsupportedTypes - NEq -> alreadyHandled - NNEq -> alreadyHandled - NAnd -> alreadyHandled - NOr -> alreadyHandled - NImpl -> alreadyHandled - NApp -> throwError $ ErrorCall "NApp should be handled by evalApp" + NApp -> throwError $ ErrorCall "NApp should be handled by evalApp" + _other -> shouldBeAlreadyHandled where - prov :: Provenance m (NValue t f m) - prov = Provenance scope $ NBinaryAnnF span op (pure lval) (pure rval) + addProv :: NValue t f m -> NValue t f m + addProv = + mkNVBinaryOpWithProvenance scope span op (pure lval) (pure rval) - toBool = pure . nvConstantP prov . NBool - compare :: (forall a. Ord a => a -> a -> Bool) -> m (NValue t f m) - compare op = case (lval, rval) of - (NVConstant l, NVConstant r) -> toBool $ l `op` r - (NVStr l, NVStr r) -> toBool $ l `op` r - _ -> unsupportedTypes + mkBoolP :: Bool -> m (NValue t f m) + mkBoolP = pure . addProv . mkNVConstant . NBool - nvInt = pure . nvConstantP prov . NInt - nvFloat = pure . nvConstantP prov . NFloat + mkIntP :: Integer -> m (NValue t f m) + mkIntP = pure . addProv . mkNVConstant . NInt - numBinOp :: (forall a. Num a => a -> a -> a) -> m (NValue t f m) - numBinOp op = numBinOp' op op + mkFloatP :: Float -> m (NValue t f m) + mkFloatP = pure . addProv . mkNVConstant . NFloat - numBinOp' + mkListP :: [NValue t f m] -> NValue t f m + mkListP = addProv . mkNVList + + mkStrP :: NixString -> NValue t f m + mkStrP = addProv . mkNVStr + + mkPathP :: Path -> NValue t f m + mkPathP = addProv . mkNVPath + + mkSetP :: (PositionSet -> AttrSet (NValue t f m) -> NValue t f m) + mkSetP x s = addProv $ mkNVSet x s + + mkCmpOp :: (forall a. Ord a => a -> a -> Bool) -> m (NValue t f m) + mkCmpOp op = case (lval, rval) of + (NVConstant l, NVConstant r) -> mkBoolP $ l `op` r + (NVStr l, NVStr r) -> mkBoolP $ l `op` r + _ -> unsupportedTypes + + mkBinNumOp :: (forall a. Num a => a -> a -> a) -> m (NValue t f m) + mkBinNumOp op = mkBinNumOp' op op + + mkBinNumOp' :: (Integer -> Integer -> Integer) -> (Float -> Float -> Float) -> m (NValue t f m) - numBinOp' intOp floatOp = case (lval, rval) of - (NVConstant l, NVConstant r) -> case (l, r) of - (NInt li, NInt ri) -> nvInt $ li `intOp` ri - (NInt li, NFloat rf) -> nvFloat $ fromInteger li `floatOp` rf - (NFloat lf, NInt ri) -> nvFloat $ lf `floatOp` fromInteger ri - (NFloat lf, NFloat rf) -> nvFloat $ lf `floatOp` rf + mkBinNumOp' intOp floatOp = + case (lval, rval) of + (NVConstant l, NVConstant r) -> + case (l, r) of + (NInt li, NInt ri) -> mkIntP $ li `intOp` ri + (NInt li, NFloat rf) -> mkFloatP $ fromInteger li `floatOp` rf + (NFloat lf, NInt ri) -> mkFloatP $ lf `floatOp` fromInteger ri + (NFloat lf, NFloat rf) -> mkFloatP $ lf `floatOp` rf + _ -> unsupportedTypes _ -> unsupportedTypes - _ -> unsupportedTypes unsupportedTypes = throwError $ ErrorCall $ "Unsupported argument types for binary operator " <> show op <> ": " <> show lval <> ", " <> show rval - alreadyHandled = throwError $ ErrorCall $ "This cannot happen: operator " <> show op <> " should have been handled in execBinaryOp." + shouldBeAlreadyHandled = throwError $ ErrorCall $ "This cannot happen: operator " <> show op <> " should have been handled in execBinaryOp." -- This function is here, rather than in 'Nix.String', because of the need to @@ -515,14 +530,13 @@ local succ $ do v'@(AnnF span x) <- sequenceA v pure $ do - opts :: Options <- asks $ view hasLens + opts <- askOptions let rendered = - if verbose opts >= Chatty - then - pretty $ - PS.ppShow $ void x - else prettyNix $ Fix $ Fix (NSym "?") <$ x + bool + (prettyNix $ Fix $ Fix (NSym "?") <$ x) + (pretty $ PS.ppShow $ void x) + (getVerbosity opts >= Chatty) msg x = pretty ("eval: " <> replicate depth ' ') <> x loc <- renderLocation span $ msg rendered <> " ...\n" putStr $ show loc @@ -530,27 +544,35 @@ print $ msg rendered <> " ...done" pure res +evalWithTracingAndMetaInfo + :: forall e t f m + . MonadNix e t f m + => NExprLoc + -> ReaderT Int m (m (NValue t f m)) +evalWithTracingAndMetaInfo = + adi + addMetaInfo + (addTracing Eval.evalContent) + where + addMetaInfo :: (NExprLoc -> ReaderT r m a) -> NExprLoc -> ReaderT r m a + addMetaInfo = (ReaderT .) . flip . (Eval.addMetaInfo .) . flip . (runReaderT .) + evalExprLoc :: forall e t f m . MonadNix e t f m => NExprLoc -> m (NValue t f m) evalExprLoc expr = do - opts :: Options <- asks $ view hasLens + opts <- askOptions let pTracedAdi = bool - Eval.framedEvalExprLoc - (join . (`runReaderT` (0 :: Int)) . - adi - (raise Eval.addMetaInfo) - (addTracing Eval.evalContent) - ) - (tracing opts) + Eval.evalWithMetaInfo + (join . (`runReaderT` (0 :: Int)) . evalWithTracingAndMetaInfo) + (isTrace opts) pTracedAdi expr - where - raise k f x = ReaderT $ \e -> k (\t -> runReaderT (f t) e) x exec :: (MonadNix e t f m, MonadInstantiate m) => [Text] -> m (NValue t f m) exec args = either throwError evalExprLoc =<< exec' args +-- Please, delete `nix` from the name nixInstantiateExpr :: (MonadNix e t f m, MonadInstantiate m) => Text -> m (NValue t f m) nixInstantiateExpr s = either throwError evalExprLoc =<< instantiateExpr s diff --git a/src/Nix/Expr/Shorthands.hs b/src/Nix/Expr/Shorthands.hs --- a/src/Nix/Expr/Shorthands.hs +++ b/src/Nix/Expr/Shorthands.hs @@ -1,10 +1,10 @@ - --- | A bunch of shorthands for making nix expressions. +-- | Shorthands for making Nix expressions. -- -- Functions with an @F@ suffix return a more general type (base functor @F a@) without the outer -- 'Fix' wrapper that creates @a@. module Nix.Expr.Shorthands where +import Nix.Prelude import Data.Fix import Nix.Atoms import Nix.Expr.Types @@ -424,13 +424,13 @@ -- | __@Deprecated@__: Please, use `mkOp` -- Put an unary operator. mkOper :: NUnaryOp -> NExpr -> NExpr -mkOper op = Fix . NUnary op +mkOper = mkOp -- NOTE: Remove after 2023-07 -- | __@Deprecated@__: Please, use `mkOp2` -- | Put a binary operator. mkOper2 :: NBinaryOp -> NExpr -> NExpr -> NExpr -mkOper2 op a = Fix . NBinary op a +mkOper2 = mkOp2 -- NOTE: Remove after 2023-07 -- | __@Deprecated@__: Please, use `mkOp2` diff --git a/src/Nix/Expr/Strings.hs b/src/Nix/Expr/Strings.hs --- a/src/Nix/Expr/Strings.hs +++ b/src/Nix/Expr/Strings.hs @@ -1,7 +1,7 @@ - -- | Functions for manipulating nix strings. module Nix.Expr.Strings where +import Nix.Prelude import Relude.Unsafe as Unsafe -- Please, switch things to NonEmpty import Data.List ( dropWhileEnd @@ -39,14 +39,16 @@ runAntiquoted _ _ k (Antiquoted r) = k r -- | Split a stream representing a string with antiquotes on line breaks. -splitLines :: [Antiquoted Text r] -> [[Antiquoted Text r]] -splitLines = uncurry (flip (:)) . go where - go (Plain t : xs) = (Plain l :) <$> foldr f (go xs) ls +splitLines :: forall r . [Antiquoted Text r] -> [[Antiquoted Text r]] +splitLines = uncurry (flip (:)) . go + where + go :: [Antiquoted Text r] -> ([[Antiquoted Text r]], [Antiquoted Text r]) + go (Plain t : xs) = (one (Plain l) <>) <$> foldr f (go xs) ls where (l : ls) = T.split (== '\n') t f prefix (finished, current) = ((Plain prefix : current) : finished, mempty) - go (Antiquoted a : xs) = (Antiquoted a :) <$> go xs - go (EscapedNewline : xs) = (EscapedNewline :) <$> go xs + go (Antiquoted a : xs) = (one (Antiquoted a) <>) <$> go xs + go (EscapedNewline : xs) = (one EscapedNewline <>) <$> go xs go [] = mempty -- | Join a stream of strings containing antiquotes again. This is the inverse @@ -108,10 +110,17 @@ escapeCodes :: [(Char, Char)] escapeCodes = - [('\n', 'n'), ('\r', 'r'), ('\t', 't'), ('\\', '\\'), ('$', '$'), ('"', '"')] + [('\n', 'n'), ('\r', 'r'), ('\t', 't'), ('"', '"'), ('$', '$'), ('\\', '\\')] fromEscapeCode :: Char -> Maybe Char fromEscapeCode = (`lookup` (swap <$> escapeCodes)) toEscapeCode :: Char -> Maybe Char toEscapeCode = (`lookup` escapeCodes) + +escapeMap :: [(Text, Text)] +escapeMap = + [("\n", "\\n"), ("\r", "\\r"), ("\t", "\\t"), ("\"", "\\\""), ("${", "\\${"), ("\\", "\\\\")] + +escapeString :: Text -> Text +escapeString = applyAll (fmap (uncurry T.replace) escapeMap) 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 @@ -7,6 +7,7 @@ {-# language TypeFamilies #-} {-# options_ghc -Wno-orphans #-} +{-# options_ghc -Wno-name-shadowing #-} {-# options_ghc -Wno-missing-signatures #-} -- | The Nix expression type and supporting types. @@ -19,17 +20,19 @@ -- (additiona info for dev): Big use of TemplateHaskell in the module requires proper (top-down) organization of declarations. module Nix.Expr.Types where -import qualified Codec.Serialise as Serialise +import Nix.Prelude +import qualified Codec.Serialise as Serialise import Codec.Serialise ( Serialise ) import Control.DeepSeq ( NFData1(..) ) import Data.Aeson import qualified Data.Binary as Binary import Data.Binary ( Binary ) import Data.Data -import Data.Fix ( Fix(Fix) ) +import Data.Fix ( Fix(..) ) import Data.Functor.Classes import Data.Hashable.Lifted import qualified Data.HashMap.Lazy as MapL +import qualified Data.Set as Set import qualified Data.List.NonEmpty as NE import qualified Text.Show import Data.Traversable ( fmapDefault, foldMapDefault ) @@ -57,14 +60,14 @@ -- * utils --- | Holds file positionng information for abstrations. --- A type synonym for @HashMap VarName SourcePos@. -type PositionSet = HashMap VarName SourcePos - -- 2021-07-16: NOTE: Should replace @ParamSet@ List -- | > Hashmap VarName -- type synonym type AttrSet = HashMap VarName +-- | Holds file positionng information for abstrations. +-- A type synonym for @HashMap VarName SourcePos@. +type PositionSet = AttrSet SourcePos + -- ** orphan instances -- Placed here because TH inference depends on declaration sequence. @@ -174,7 +177,7 @@ ( Eq, Ord, Generic, Generic1 , Typeable, Data, NFData, NFData1, Serialise, Binary, ToJSON, ToJSON1, FromJSON, FromJSON1 , Functor, Foldable, Traversable - , Show, Hashable, Hashable1 + , Show, Hashable ) instance IsString (Params r) where @@ -185,6 +188,8 @@ $(deriveEq1 ''Params) $(deriveOrd1 ''Params) +deriving instance Hashable1 Params + -- *** lens traversals $(makeTraversals ''Params) @@ -210,14 +215,9 @@ , Typeable, Data, NFData, NFData1, Serialise, Binary , ToJSON, ToJSON1, FromJSON, FromJSON1 , Functor, Foldable, Traversable - , Show, Read, Hashable, Hashable1 + , Show, Read, Hashable ) -instance Hashable2 Antiquoted where - liftHashWithSalt2 ha _ salt (Plain a) = ha (salt `hashWithSalt` (0 :: Int)) a - liftHashWithSalt2 _ _ salt EscapedNewline = salt `hashWithSalt` (1 :: Int) - liftHashWithSalt2 _ hb salt (Antiquoted b) = hb (salt `hashWithSalt` (2 :: Int)) b - $(deriveShow1 ''Antiquoted) $(deriveShow2 ''Antiquoted) $(deriveRead1 ''Antiquoted) @@ -228,7 +228,13 @@ $(deriveOrd2 ''Antiquoted) $(deriveJSON2 defaultOptions ''Antiquoted) +instance Hashable2 Antiquoted where + liftHashWithSalt2 ha _ salt (Plain a) = ha (salt `hashWithSalt` (0 :: Int)) a + liftHashWithSalt2 _ _ salt EscapedNewline = salt `hashWithSalt` (1 :: Int) + liftHashWithSalt2 _ hb salt (Antiquoted b) = hb (salt `hashWithSalt` (2 :: Int)) b +deriving instance (Hashable v) => Hashable1 (Antiquoted (v :: Type)) + -- *** lens traversals $(makeTraversals ''Antiquoted) @@ -261,19 +267,21 @@ ( Eq, Ord, Generic, Generic1 , Typeable, Data, NFData, NFData1, Serialise, Binary, ToJSON, ToJSON1, FromJSON, FromJSON1 , Functor, Foldable, Traversable - , Show, Read, Hashable, Hashable1 + , Show, Read, Hashable ) -- | For the the 'IsString' instance, we use a plain doublequoted string. instance IsString (NString r) where fromString "" = DoubleQuoted mempty - fromString string = DoubleQuoted [Plain $ fromString string] + fromString string = DoubleQuoted $ one $ Plain $ fromString string $(deriveShow1 ''NString) $(deriveRead1 ''NString) $(deriveEq1 ''NString) $(deriveOrd1 ''NString) +deriving instance Hashable1 NString + -- *** lens traversals $(makeTraversals ''NString) @@ -316,9 +324,9 @@ ) instance NFData1 NKeyName where - liftRnf _ (StaticKey !_ ) = () - liftRnf _ (DynamicKey (Plain !_) ) = () - liftRnf _ (DynamicKey EscapedNewline) = () + liftRnf _ (StaticKey !_ ) = mempty + liftRnf _ (DynamicKey (Plain !_) ) = mempty + liftRnf _ (DynamicKey EscapedNewline) = mempty liftRnf k (DynamicKey (Antiquoted r)) = k r -- | Most key names are just static text, so this instance is convenient. @@ -421,7 +429,7 @@ ( Eq, Ord, Generic, Generic1 , Typeable, Data, NFData, NFData1, Serialise, Binary, ToJSON, FromJSON , Functor, Foldable, Traversable - , Show, Hashable, Hashable1 + , Show, Hashable ) $(deriveShow1 ''Binding) @@ -429,6 +437,8 @@ $(deriveOrd1 ''Binding) --x $(deriveJSON1 defaultOptions ''Binding) +deriving instance Hashable1 Binding + -- *** lens traversals $(makeTraversals ''Binding) @@ -506,7 +516,7 @@ -- * data NExprF - Nix expressions, base functor --- | The main Nix expression type. As it is polimophic, has a functor, +-- | The main Nix expression type. As it is polimorphic, has a functor, -- which allows to traverse expressions and map functions over them. -- The actual 'NExpr' type is a fixed point of this functor, defined -- below. @@ -594,7 +604,7 @@ ( Eq, Ord, Generic, Generic1 , Typeable, Data, NFData, NFData1, Serialise, Binary, ToJSON, FromJSON , Functor, Foldable, Traversable - , Show, Hashable, Hashable1 + , Show, Hashable ) @@ -603,6 +613,8 @@ $(deriveOrd1 ''NExprF) --x $(deriveJSON1 defaultOptions ''NExprF) +deriving instance Hashable1 NExprF + -- ** lens traversals $(makeTraversals ''NExprF) @@ -739,3 +751,71 @@ ) <$> f Nothing ekey _ _ f e = fromMaybe e <$> f Nothing + + +getFreeVars :: NExpr -> Set VarName +getFreeVars e = + case unFix e of + (NConstant _ ) -> mempty + (NStr string ) -> mapFreeVars string + (NSym var ) -> one var + (NList list ) -> mapFreeVars list + (NSet NonRecursive bindings) -> bindFreeVars bindings + (NSet Recursive bindings) -> diffBetween bindFreeVars bindDefs bindings + (NLiteralPath _ ) -> mempty + (NEnvPath _ ) -> mempty + (NUnary _ expr ) -> getFreeVars expr + (NBinary _ left right ) -> collectFreeVars left right + (NSelect orExpr expr path) -> + Set.unions + [ getFreeVars expr + , pathFree path + , getFreeVars `whenJust` orExpr + ] + (NHasAttr expr path) -> getFreeVars expr <> pathFree path + (NAbs (Param varname) expr) -> Set.delete varname (getFreeVars expr) + (NAbs (ParamSet varname _ pset) expr) -> + Set.difference + -- Include all free variables from the expression and the default arguments + (getFreeVars expr <> Set.unions (getFreeVars <$> mapMaybe snd pset)) + -- But remove the argument name if existing, and all arguments in the parameter set + ((one `whenJust` varname) <> Set.fromList (fst <$> pset)) + (NLet bindings expr ) -> + Set.difference + (getFreeVars expr <> bindFreeVars bindings) + (bindDefs bindings) + (NIf cond th el ) -> Set.unions $ getFreeVars <$> [cond, th, el] + -- Evaluation is needed to find out whether x is a "real" free variable in `with y; x`, we just include it + -- This also makes sense because its value can be overridden by `x: with y; x` + (NWith set expr ) -> collectFreeVars set expr + (NAssert assertion expr ) -> collectFreeVars assertion expr + (NSynHole _ ) -> mempty + where + diffBetween :: (a -> Set VarName) -> (a -> Set VarName) -> a -> Set VarName + diffBetween g f b = Set.difference (g b) (f b) + + collectFreeVars :: NExpr -> NExpr -> Set VarName + collectFreeVars = (<>) `on` getFreeVars + + bindDefs :: Foldable t => t (Binding NExpr) -> Set VarName + bindDefs = foldMap bind1Def + where + bind1Def :: Binding r -> Set VarName + bind1Def (Inherit Nothing _ _) = mempty + bind1Def (Inherit (Just _ ) keys _) = Set.fromList keys + bind1Def (NamedVar (StaticKey varname :| _) _ _) = one varname + bind1Def (NamedVar (DynamicKey _ :| _) _ _) = mempty + + bindFreeVars :: Foldable t => t (Binding NExpr) -> Set VarName + bindFreeVars = foldMap bind1Free + where + bind1Free :: Binding NExpr -> Set VarName + bind1Free (Inherit Nothing keys _) = Set.fromList keys + bind1Free (Inherit (Just scope) _ _) = getFreeVars scope + bind1Free (NamedVar path expr _) = pathFree path <> getFreeVars expr + + pathFree :: NAttrPath NExpr -> Set VarName + pathFree = foldMap mapFreeVars + + mapFreeVars :: Foldable t => t NExpr -> Set VarName + mapFreeVars = foldMap getFreeVars 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 @@ -16,6 +16,7 @@ ) where +import Nix.Prelude import Codec.Serialise import Control.DeepSeq import Data.Aeson ( ToJSON(..) @@ -111,8 +112,6 @@ -- ** Instances -instance Hashable ann => Hashable1 (AnnUnit ann) - instance NFData ann => NFData1 (AnnUnit ann) instance (Binary ann, Binary a) => Binary (AnnUnit ann a) @@ -127,6 +126,8 @@ $(deriveShow2 ''AnnUnit) $(deriveJSON1 defaultOptions ''AnnUnit) $(deriveJSON2 defaultOptions ''AnnUnit) + +instance Hashable ann => Hashable1 (AnnUnit ann) instance (Serialise ann, Serialise a) => Serialise (AnnUnit ann a) diff --git a/src/Nix/Frames.hs b/src/Nix/Frames.hs --- a/src/Nix/Frames.hs +++ b/src/Nix/Frames.hs @@ -5,6 +5,7 @@ module Nix.Frames ( NixLevel(..) , Frames + , askFrames , Framed , NixFrame(..) , NixException(..) @@ -14,6 +15,7 @@ ) where +import Nix.Prelude import Data.Typeable hiding ( typeOf ) import Control.Monad.Catch ( MonadThrow(..) ) import qualified Text.Show @@ -21,10 +23,11 @@ data NixLevel = Fatal | Error | Warning | Info | Debug deriving (Ord, Eq, Bounded, Enum, Show) -data NixFrame = NixFrame - { frameLevel :: NixLevel - , frame :: SomeException - } +data NixFrame = + NixFrame + { frameLevel :: NixLevel + , frame :: SomeException + } instance Show NixFrame where show (NixFrame level f) = @@ -32,6 +35,9 @@ type Frames = [NixFrame] +askFrames :: forall e m . (MonadReader e m, Has e Frames) => m Frames +askFrames = askLocal + type Framed e m = (MonadReader e m, Has e Frames, MonadThrow m) newtype NixException = NixException Frames @@ -45,7 +51,8 @@ throwError :: forall s e m a . (Framed e m, Exception s, MonadThrow m) => s -> m a -throwError err = do - context <- asks (view hasLens) - traceM "Throwing fail..." - throwM $ NixException $ NixFrame Error (toException err) : context +throwError err = + do + context <- askLocal + traceM "Throwing fail..." + throwM $ NixException $ NixFrame Error (toException err) : context diff --git a/src/Nix/Fresh.hs b/src/Nix/Fresh.hs --- a/src/Nix/Fresh.hs +++ b/src/Nix/Fresh.hs @@ -8,6 +8,7 @@ module Nix.Fresh where +import Nix.Prelude import Control.Monad.Base ( MonadBase(..) ) import Control.Monad.Catch ( MonadCatch , MonadMask @@ -20,7 +21,6 @@ import Nix.Thunk --- 2021-06-02: NOTE: Remove singleton newtype accessor in favour of free coerce newtype FreshIdT i m a = FreshIdT (ReaderT (Ref m i) m a) deriving ( Functor @@ -59,5 +59,5 @@ v <- ask atomicModifyRef v (\i -> (succ i, i)) -runFreshIdT :: Functor m => Ref m i -> FreshIdT i m a -> m a -runFreshIdT i m = runReaderT (coerce m) i +runFreshIdT :: Functor m => FreshIdT i m a -> Ref m i -> m a +runFreshIdT = runReaderT . coerce diff --git a/src/Nix/Fresh/Basic.hs b/src/Nix/Fresh/Basic.hs --- a/src/Nix/Fresh/Basic.hs +++ b/src/Nix/Fresh/Basic.hs @@ -8,6 +8,7 @@ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) #endif +import Nix.Prelude import Nix.Effects import Nix.Render import Nix.Fresh @@ -28,19 +29,36 @@ instance (MonadEffects t f m, MonadDataContext f m) => MonadEffects t f (StdIdT m) where + + toAbsolutePath :: Path -> StdIdT m Path toAbsolutePath = lift . toAbsolutePath @t @f @m + + findEnvPath :: String -> StdIdT m Path findEnvPath = lift . findEnvPath @t @f @m - findPath vs path = do - i <- FreshIdT ask - let vs' = unliftNValue (runFreshIdT i) <$> vs - lift $ findPath @t @f @m vs' path - importPath path = do - i <- FreshIdT ask - p <- lift $ importPath @t @f @m path - pure $ liftNValue (runFreshIdT i) p + + findPath :: [NValue t f (StdIdT m)] -> Path -> StdIdT m Path + findPath vs path = + do + i <- FreshIdT ask + lift $ findPath @t @f @m (unliftNValue (`runFreshIdT` i) <$> vs) path + + importPath :: Path -> StdIdT m (NValue t f (StdIdT m)) + importPath path = + do + i <- FreshIdT ask + lift $ liftNValue (`runFreshIdT` i) <$> (importPath @t @f @m $ path) + + pathToDefaultNix :: Path -> StdIdT m Path pathToDefaultNix = lift . pathToDefaultNix @t @f @m - derivationStrict v = do - i <- FreshIdT ask - p <- lift $ derivationStrict @t @f @m $ unliftNValue (runFreshIdT i) v - pure $ liftNValue (runFreshIdT i) p + + derivationStrict :: NValue t f (StdIdT m) -> StdIdT m (NValue t f (StdIdT m)) + derivationStrict v = + do + i <- FreshIdT ask + let + fresh :: FreshIdT Int m a -> m a + fresh = (`runFreshIdT` i) + lift $ liftNValue fresh <$> (derivationStrict @t @f @m . unliftNValue fresh $ v) + + traceEffect :: String -> StdIdT m () traceEffect = lift . traceEffect @t @f @m diff --git a/src/Nix/Json.hs b/src/Nix/Json.hs --- a/src/Nix/Json.hs +++ b/src/Nix/Json.hs @@ -2,6 +2,7 @@ module Nix.Json where +import Nix.Prelude import qualified Data.Aeson as A import qualified Data.Aeson.Encoding as A import qualified Data.Vector as V @@ -36,8 +37,8 @@ A.Array l -> A.list toEncodingSorted $ V.toList l v -> A.toEncoding v -nvalueToJSONNixString :: MonadNix e t f m => NValue t f m -> m NixString -nvalueToJSONNixString = +toJSONNixString :: MonadNix e t f m => NValue t f m -> m NixString +toJSONNixString = runWithStringContextT . fmap ( decodeUtf8 @@ -46,10 +47,10 @@ . toEncodingSorted ) - . nvalueToJSON + . toJSON -nvalueToJSON :: MonadNix e t f m => NValue t f m -> WithStringContextT m A.Value -nvalueToJSON = \case +toJSON :: MonadNix e t f m => NValue t f m -> WithStringContextT m A.Value +toJSON = \case NVConstant (NInt n) -> pure $ A.toJSON n NVConstant (NFloat n) -> pure $ A.toJSON n NVConstant (NBool b) -> pure $ A.toJSON b @@ -72,10 +73,10 @@ NVPath p -> do fp <- lift $ coerce <$> addPath p - addSingletonStringContext $ StringContext (fromString fp) DirectPath + addSingletonStringContext $ StringContext DirectPath $ fromString fp pure $ A.toJSON fp v -> lift $ throwError $ CoercionToJson v where intoJson :: MonadNix e t f m => NValue t f m -> WithStringContextT m A.Value - intoJson nv = join $ lift $ nvalueToJSON <$> demand nv + intoJson nv = join $ lift $ toJSON <$> demand nv diff --git a/src/Nix/Lint.hs b/src/Nix/Lint.hs --- a/src/Nix/Lint.hs +++ b/src/Nix/Lint.hs @@ -11,6 +11,7 @@ module Nix.Lint where +import Nix.Prelude import Relude.Unsafe as Unsafe ( head ) import Control.Exception ( throw ) import GHC.Exception ( ErrorCall(ErrorCall) ) @@ -214,7 +215,7 @@ (pure <$> r) bool id - ((TSet (pure m) :) <$>) + ((one (TSet $ pure m) <>) <$>) (not $ M.null m) rest @@ -270,9 +271,11 @@ m <- merge context xs ys bool (do - writeRef x (NMany m) - writeRef y (NMany m) - packSymbolic (NMany m) + let + nm = NMany m + writeRef x nm + writeRef y nm + packSymbolic nm ) ( -- x' <- renderSymbolic (Symbolic x) @@ -304,16 +307,16 @@ defer = fmap ST . thunk demand :: Symbolic m -> m (Symbolic m) - demand (ST v)= demand =<< force v - demand (SV v)= pure (SV v) + demand (ST v) = demand =<< force v + demand (SV v) = pure (SV v) instance (MonadThunkId m, MonadAtomicRef m, MonadCatch m) => MonadValueF (Symbolic m) m where demandF :: (Symbolic m -> m r) -> Symbolic m -> m r - demandF f (ST v)= demandF f =<< force v - demandF f (SV v)= f (SV v) + demandF f (ST v) = demandF f =<< force v + demandF f (SV v) = f (SV v) instance MonadLint e m => MonadEval (Symbolic m) m where @@ -349,7 +352,7 @@ evalEnvPath = const $ mkSymbolic $ one TPath evalUnary op arg = - unify (void (NUnary op arg)) arg =<< mkSymbolic (one (TConstant [TInt, TBool])) + unify (void $ NUnary op arg) arg =<< mkSymbolic (one $ TConstant [TInt, TBool]) evalBinary = lintBinaryOp @@ -385,7 +388,7 @@ _ <- unify (void e) cond =<< mkSymbolic (one $ TConstant $ one TBool) pure body' - evalApp = (fmap snd .) . lintApp (NBinary NApp () ()) + evalApp = (fmap snd .) . lintApp (join (NBinary NApp) mempty) evalAbs params _ = mkSymbolic (one $ TClosure $ void params) evalError = throwError @@ -491,15 +494,15 @@ ) instance MonadThrow (Lint s) where + throwM :: forall e a . Exception e => e -> Lint s a throwM e = Lint $ ReaderT $ const (throw e) instance MonadCatch (Lint s) where catch _m _h = Lint $ ReaderT $ const (fail "Cannot catch in 'Lint s'") runLintM :: Options -> Lint s a -> ST s a -runLintM opts action = do - i <- newRef (1 :: Int) - runFreshIdT i $ (`runReaderT` newContext opts) $ runLint action +runLintM opts action = + runFreshIdT ((`runReaderT` newContext opts) $ runLint action) =<< newRef (1 :: Int) symbolicBaseEnv :: Monad m @@ -522,7 +525,7 @@ instance Scoped (Symbolic (Lint s)) (Lint s) where - currentScopes = currentScopesReader + askScopes = askScopesReader clearScopes = clearScopesReader @(Lint s) @(Symbolic (Lint s)) pushScopes = pushScopesReader lookupVar = lookupVarReader diff --git a/src/Nix/Normal.hs b/src/Nix/Normal.hs --- a/src/Nix/Normal.hs +++ b/src/Nix/Normal.hs @@ -10,6 +10,7 @@ -- And so do not converge into a normal form. module Nix.Normal where +import Nix.Prelude import Control.Monad.Free ( Free(..) ) import Data.Set ( member , insert @@ -100,7 +101,9 @@ (do i <- ask when (i > 2000) $ fail "Exceeded maximum normalization depth of 2000 levels" - lifted (lifted $ f t) $ local succ . k + (lifted . lifted) + (f t) + (local succ . k) ) (pure $ pure t) b @@ -139,7 +142,7 @@ normalForm_ t = void $ normalizeValue t opaqueVal :: Applicative f => NValue t f m -opaqueVal = nvStrWithoutContext "" +opaqueVal = mkNVStrWithoutContext "" -- | Detect cycles & stub them. stubCycles @@ -165,7 +168,7 @@ Free (NValue' cyc) = opaqueVal thunkStubVal :: Applicative f => NValue t f m -thunkStubVal = nvStrWithoutContext thunkStubText +thunkStubVal = mkNVStrWithoutContext thunkStubText -- | Check if thunk @t@ is computed, -- then bind it into first arg. diff --git a/src/Nix/Options.hs b/src/Nix/Options.hs --- a/src/Nix/Options.hs +++ b/src/Nix/Options.hs @@ -3,74 +3,79 @@ -- | Definitions & defaults for the CLI options module Nix.Options where +import Nix.Prelude import Data.Time -- 2021-07-15: NOTE: What these are? They need to be documented. -- Also need better names. Foe example, Maybes & lists names need to show their type in the name. -data Options = Options - { verbose :: Verbosity - , tracing :: Bool - , thunks :: Bool - , values :: Bool - , showScopes :: Bool - , reduce :: Maybe Path - , reduceSets :: Bool - , reduceLists :: Bool - , parse :: Bool - , parseOnly :: Bool - , finder :: Bool - , findFile :: Maybe Path - , strict :: Bool - , evaluate :: Bool - , json :: Bool - , xml :: Bool - , attr :: Maybe Text - , include :: [Path] - , check :: Bool - , readFrom :: Maybe Path - , cache :: Bool - , repl :: Bool - , ignoreErrors :: Bool - , expression :: Maybe Text - , arg :: [(Text, Text)] - , argstr :: [(Text, Text)] - , fromFile :: Maybe Path - , currentTime :: UTCTime - , filePaths :: [Path] +data Options = + Options + { getVerbosity :: Verbosity + , isTrace :: Bool + , isThunks :: Bool + , isValues :: Bool + , isShowScopes :: Bool + , getReduce :: Maybe Path + , isReduceSets :: Bool + , isReduceLists :: Bool + , isParse :: Bool + , isParseOnly :: Bool + , isFinder :: Bool + , getFindFile :: Maybe Path + , isStrict :: Bool + , isEvaluate :: Bool + , isJson :: Bool + , isXml :: Bool + , getAttr :: Maybe Text + , getInclude :: [Path] + , isCheck :: Bool + , getReadFrom :: Maybe Path + , isCache :: Bool + , isRepl :: Bool + , isIgnoreErrors :: Bool + , getExpression :: Maybe Text + , getArg :: [(Text, Text)] + , getArgstr :: [(Text, Text)] + , getFromFile :: Maybe Path + , getTime :: UTCTime + -- ^ The time can be set to reproduce time-dependent states. + , getFilePaths :: [Path] } deriving Show defaultOptions :: UTCTime -> Options -defaultOptions current = Options { verbose = ErrorsOnly - , tracing = False - , thunks = False - , values = False - , showScopes = False - , reduce = mempty - , reduceSets = False - , reduceLists = False - , parse = False - , parseOnly = False - , finder = False - , findFile = mempty - , strict = False - , evaluate = False - , json = False - , xml = False - , attr = mempty - , include = mempty - , check = False - , readFrom = mempty - , cache = False - , repl = False - , ignoreErrors = False - , expression = mempty - , arg = mempty - , argstr = mempty - , fromFile = mempty - , currentTime = current - , filePaths = mempty - } +defaultOptions currentTime = + Options + { getVerbosity = ErrorsOnly + , isTrace = False + , isThunks = False + , isValues = False + , isShowScopes = False + , getReduce = mempty + , isReduceSets = False + , isReduceLists = False + , isParse = False + , isParseOnly = False + , isFinder = False + , getFindFile = mempty + , isStrict = False + , isEvaluate = False + , isJson = False + , isXml = False + , getAttr = mempty + , getInclude = mempty + , isCheck = False + , getReadFrom = mempty + , isCache = False + , isRepl = False + , isIgnoreErrors = False + , getExpression = mempty + , getArg = mempty + , getArgstr = mempty + , getFromFile = mempty + , getTime = currentTime + , getFilePaths = mempty + } data Verbosity = ErrorsOnly @@ -80,3 +85,6 @@ | DebugInfo | Vomit deriving (Eq, Ord, Enum, Bounded, Show) + +askOptions :: forall e m . (MonadReader e m, Has e Options) => m Options +askOptions = askLocal 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 @@ -3,6 +3,7 @@ -- | Code that configures presentation parser for the CLI options module Nix.Options.Parser where +import Nix.Prelude import Relude.Unsafe ( read ) import GHC.Err ( errorWithoutStackTrace ) import Data.Char ( isDigit ) diff --git a/src/Nix/Parser.hs b/src/Nix/Parser.hs --- a/src/Nix/Parser.hs +++ b/src/Nix/Parser.hs @@ -9,6 +9,7 @@ , parseNixFileLoc , parseNixText , parseNixTextLoc + , parseExpr , parseFromFileEx , Parser , parseFromText @@ -39,7 +40,7 @@ ) where -import Prelude hiding ( (<|>) +import Nix.Prelude hiding ( (<|>) , some , many ) @@ -270,74 +271,79 @@ antiquotedLexeme <|> Plain <$> p -nixString' :: Parser (NString NExprLoc) -nixString' = label "string" $ lexeme $ doubleQuoted <|> indented - where - doubleQuoted :: Parser (NString NExprLoc) - doubleQuoted = - label "double quoted string" $ - DoubleQuoted . removeEmptyPlains . mergePlain <$> - inQuotationMarks (many $ stringChar quotationMark (void $ char '\\') doubleEscape) - where - inQuotationMarks :: Parser a -> Parser a - inQuotationMarks expr = quotationMark *> expr <* quotationMark +escapeCode :: Parser Char +escapeCode = + msum + [ c <$ char e | (c, e) <- escapeCodes ] + <|> anySingle - quotationMark :: Parser () - quotationMark = void $ char '"' +stringChar + :: Parser () + -> Parser () + -> Parser (Antiquoted Text NExprLoc) + -> Parser (Antiquoted Text NExprLoc) +stringChar end escStart esc = + antiquoted + <|> Plain . one <$> char '$' + <|> esc + <|> Plain . fromString <$> some plainChar + where + plainChar :: Parser Char + plainChar = + notFollowedBy (end <|> void (char '$') <|> escStart) *> anySingle - doubleEscape :: Parser (Antiquoted Text r) - doubleEscape = Plain . one <$> (char '\\' *> escapeCode) +doubleQuoted :: Parser (NString NExprLoc) +doubleQuoted = + label "double quoted string" $ + DoubleQuoted . removeEmptyPlains . mergePlain <$> + inQuotationMarks (many $ stringChar quotationMark (void $ char '\\') doubleEscape) + where + inQuotationMarks :: Parser a -> Parser a + inQuotationMarks expr = quotationMark *> expr <* quotationMark - indented :: Parser (NString NExprLoc) - indented = - label "indented string" $ - stripIndent <$> - inIndentedQuotation (many $ join stringChar indentedQuotationMark indentedEscape) - where - indentedEscape :: Parser (Antiquoted Text r) - indentedEscape = - try $ - do - indentedQuotationMark - (Plain <$> ("''" <$ char '\'' <|> "$" <$ char '$')) - <|> - do - _ <- char '\\' - c <- escapeCode + quotationMark :: Parser () + quotationMark = void $ char '"' - pure $ - bool - EscapedNewline - (Plain $ one c) - (c /= '\n') + doubleEscape :: Parser (Antiquoted Text r) + doubleEscape = Plain . one <$> (char '\\' *> escapeCode) - inIndentedQuotation :: Parser a -> Parser a - inIndentedQuotation expr = indentedQuotationMark *> expr <* indentedQuotationMark - indentedQuotationMark :: Parser () - indentedQuotationMark = label "\"''\"" . void $ chunk "''" +indented :: Parser (NString NExprLoc) +indented = + label "indented string" $ + stripIndent <$> + inIndentedQuotation (many $ join stringChar indentedQuotationMark indentedEscape) + where + -- | Read escaping inside of the "'' ''" + indentedEscape :: Parser (Antiquoted Text r) + indentedEscape = + try $ + do + indentedQuotationMark + (Plain <$> ("''" <$ char '\'' <|> "$" <$ char '$')) + <|> + do + _ <- char '\\' + c <- escapeCode - stringChar - :: Parser () - -> Parser () - -> Parser (Antiquoted Text NExprLoc) - -> Parser (Antiquoted Text NExprLoc) - stringChar end escStart esc = - antiquoted - <|> Plain . one <$> char '$' - <|> esc - <|> Plain . fromString <$> some plainChar - where - plainChar :: Parser Char - plainChar = - notFollowedBy (end <|> void (char '$') <|> escStart) *> anySingle + pure $ + bool + EscapedNewline + (Plain $ one c) + (c /= '\n') - escapeCode :: Parser Char - escapeCode = - msum - [ c <$ char e | (c, e) <- escapeCodes ] - <|> anySingle + -- | Enclosed into indented quatation "'' ''" + inIndentedQuotation :: Parser a -> Parser a + inIndentedQuotation expr = indentedQuotationMark *> expr <* indentedQuotationMark + -- | Symbol "''" + indentedQuotationMark :: Parser () + indentedQuotationMark = label "\"''\"" . void $ chunk "''" + + +nixString' :: Parser (NString NExprLoc) +nixString' = label "string" $ lexeme $ doubleQuoted <|> indented + nixString :: Parser NExprLoc nixString = annNStr <$> annotateLocation1 nixString' @@ -586,6 +592,7 @@ one $ binaryR NImpl "->" ] +-- 2021-11-09: NOTE: rename OperatorInfo accessors to `get*` -- 2021-08-10: NOTE: -- All this is a sidecar: -- * This type @@ -595,11 +602,13 @@ -- * getSpecialOperation -- can reduced in favour of adding precedence field into @NOperatorDef@. -- details: https://github.com/haskell-nix/hnix/issues/982 -data OperatorInfo = OperatorInfo - { precedence :: Int - , associativity :: NAssoc - , operatorName :: Text - } deriving (Eq, Ord, Generic, Typeable, Data, Show) +data OperatorInfo = + OperatorInfo + { precedence :: Int + , associativity :: NAssoc + , operatorName :: Text + } + deriving (Eq, Ord, Generic, Typeable, Data, Show) detectPrecedence :: Ord a @@ -918,3 +927,9 @@ parseNixTextLoc = parseNixText' id +parseExpr :: (MonadFail m) => Text -> m NExpr +parseExpr = + either + (fail . show) + pure + . parseNixText diff --git a/src/Nix/Prelude.hs b/src/Nix/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Nix/Prelude.hs @@ -0,0 +1,20 @@ +-- | This is a @Prelude@, but, please, do not put things in here, +-- put them into "Nix.Utils". This module is a pass-through-multiplexer, +-- between our custom code ("Nix.Utils") that shadows over the outside prelude that is in use ("Relude") +-- "Prelude" module has a problem of being imported & used by other projects. +-- "Nix.Utils" as a module with a regular name does not have that problem. +module Nix.Prelude + ( module Nix.Utils + , module Relude + ) where + +import Nix.Utils +import Relude hiding ( pass + , force + , readFile + , whenJust + , whenNothing + , trace + , traceM + ) + diff --git a/src/Nix/Pretty.hs b/src/Nix/Pretty.hs --- a/src/Nix/Pretty.hs +++ b/src/Nix/Pretty.hs @@ -3,10 +3,9 @@ {-# options_ghc -fno-warn-name-shadowing #-} - module Nix.Pretty where -import Prelude hiding ( toList, group ) +import Nix.Prelude hiding ( toList, group ) import Control.Monad.Free ( Free(Free) ) import Data.Fix ( Fix(..) , foldFix ) @@ -33,8 +32,8 @@ -- | This type represents a pretty printed nix expression -- together with some information about the expression. data NixDoc ann = NixDoc - { -- | The rendered expression, without any parentheses. - withoutParens :: Doc ann + { -- | Rendered expression. Without surrounding parenthesis. + getDoc :: Doc ann -- | The root operator is the operator at the root of -- the expression tree. For example, in '(a * b) + c', '+' would be the root @@ -45,8 +44,16 @@ -- we can add brackets appropriately } +-- | Represent Nix antiquotes. +-- +-- > +-- > ${ expr } +-- > +antiquote :: NixDoc ann -> Doc ann +antiquote x = "${" <> getDoc x <> "}" + mkNixDoc :: OperatorInfo -> Doc ann -> NixDoc ann -mkNixDoc o d = NixDoc { withoutParens = d, rootOp = o, wasPath = False } +mkNixDoc o d = NixDoc { getDoc = d, rootOp = o, wasPath = False } -- | A simple expression is never wrapped in parentheses. The expression -- behaves as if its root operator had a precedence higher than all @@ -64,13 +71,13 @@ -- binding). leastPrecedence :: Doc ann -> NixDoc ann leastPrecedence = - mkNixDoc (OperatorInfo maxBound NAssocNone "least precedence") + mkNixDoc $ OperatorInfo maxBound NAssocNone "least precedence" appOp :: OperatorInfo appOp = getBinaryOperator NApp appOpNonAssoc :: OperatorInfo -appOpNonAssoc = (getBinaryOperator NApp) { associativity = NAssocNone } +appOpNonAssoc = appOp { associativity = NAssocNone } selectOp :: OperatorInfo selectOp = getSpecialOperator NSelectOp @@ -78,57 +85,68 @@ hasAttrOp :: OperatorInfo hasAttrOp = getSpecialOperator NHasAttrOp -wrapParens :: OperatorInfo -> NixDoc ann -> Doc ann -wrapParens op sub = - bool - (\ a -> "(" <> a <> ")") - id - ( precedence (rootOp sub) < precedence op - || (precedence (rootOp sub) == precedence op - && associativity (rootOp sub) == associativity op - && associativity op /= NAssocNone) - ) - (withoutParens sub) +-- | Determine if to return doc wraped into parens, +-- according the given operator. +precedenceWrap :: OperatorInfo -> NixDoc ann -> Doc ann +precedenceWrap op subExpr = + maybeWrap $ getDoc subExpr + where + maybeWrap :: Doc ann -> Doc ann + maybeWrap = + bool + parens + id + needsParens + where + needsParens :: Bool + needsParens = + precedence root < precedence op + || ( precedence root == precedence op + && associativity root == associativity op + && associativity op /= NAssocNone + ) + root = rootOp subExpr + + -- Used in the selector case to print a path in a selector as -- "${./abc}" wrapPath :: OperatorInfo -> NixDoc ann -> Doc ann wrapPath op sub = bool - (wrapParens op sub) - ("\"${" <> withoutParens sub <> "}\"") + (precedenceWrap op sub) + (dquotes $ antiquote sub) (wasPath sub) +-- | Handle Output representation of the string escape codes. prettyString :: NString (NixDoc ann) -> Doc ann -prettyString (DoubleQuoted parts) = "\"" <> foldMap prettyPart parts <> "\"" +prettyString (DoubleQuoted parts) = + dquotes $ foldMap prettyPart parts where - -- It serializes Text -> String, because the helper code is done for String, - -- please, can someone break that code. - prettyPart (Plain t) = pretty . foldMap escape . toString $ t + prettyPart (Plain t) = pretty $ escapeString t prettyPart EscapedNewline = "''\\n" - prettyPart (Antiquoted r) = "${" <> withoutParens r <> "}" - escape '"' = "\\\"" - escape x = - maybe - (one x) - (('\\' :) . one) - (toEscapeCode x) -prettyString (Indented _ parts) = group $ nest 2 $ vcat - ["''", content, "''"] + prettyPart (Antiquoted r) = antiquote r +prettyString (Indented _ parts) = + group $ nest 2 $ vcat ["''", content, "''"] where content = vsep . fmap prettyLine . stripLastIfEmpty . splitLines $ parts stripLastIfEmpty :: [[Antiquoted Text r]] -> [[Antiquoted Text r]] - stripLastIfEmpty = filter flt + stripLastIfEmpty = + filter flt where flt :: [Antiquoted Text r] -> Bool flt [Plain t] | Text.null (strip t) = False flt _ = True - prettyLine = hcat . fmap prettyPart - prettyPart (Plain t) = - pretty . replace "${" "''${" . replace "''" "'''" $ t - prettyPart EscapedNewline = "\\n" - prettyPart (Antiquoted r) = "${" <> withoutParens r <> "}" + prettyLine :: [Antiquoted Text (NixDoc ann)] -> Doc ann + prettyLine = + hcat . fmap prettyPart + where + prettyPart :: Antiquoted Text (NixDoc ann) -> Doc ann + prettyPart (Plain t) = + pretty . replace "${" "''${" . replace "''" "'''" $ t + prettyPart EscapedNewline = "\\n" + prettyPart (Antiquoted r) = antiquote r prettyVarName :: VarName -> Doc ann prettyVarName = pretty @Text . coerce @@ -137,55 +155,49 @@ prettyParams (Param n ) = prettyVarName n prettyParams (ParamSet mname variadic pset) = prettyParamSet variadic pset <> - toDoc `whenJust` mname + toDoc `whenJust` mname where toDoc :: VarName -> Doc ann toDoc (coerce -> name) = ("@" <> pretty name) `whenFalse` Text.null name -prettyParamSet :: Variadic -> ParamSet (NixDoc ann) -> Doc ann +prettyParamSet :: forall ann . Variadic -> ParamSet (NixDoc ann) -> Doc ann prettyParamSet variadic args = encloseSep "{ " (align " }") - sep + (align ", ") (fmap prettySetArg args <> one "..." `whenTrue` (variadic == Variadic)) where + prettySetArg :: (VarName, Maybe (NixDoc ann)) -> Doc ann prettySetArg (n, maybeDef) = - maybe - varName - (\x -> varName <> " ? " <> withoutParens x) - maybeDef - where - varName = prettyVarName n - sep = align ", " + (prettyVarName n <>) $ ((" ? " <>) . getDoc) `whenJust` maybeDef prettyBind :: Binding (NixDoc ann) -> Doc ann prettyBind (NamedVar n v _p) = - prettySelector n <> " = " <> withoutParens v <> ";" + prettySelector n <> " = " <> getDoc v <> ";" prettyBind (Inherit s ns _p) = "inherit " <> scope <> align (fillSep $ prettyVarName <$> ns) <> ";" - where - scope = - ((<> " ") . parens . withoutParens) `whenJust` s + where + scope = + ((<> " ") . parens . getDoc) `whenJust` s prettyKeyName :: NKeyName (NixDoc ann) -> Doc ann prettyKeyName (StaticKey key) = bool "\"\"" (bool - varName - ("\"" <> varName <> "\"") + id + dquotes (HashSet.member key reservedNames) + (prettyVarName key) ) (not $ Text.null $ coerce key) - where - varName = prettyVarName key prettyKeyName (DynamicKey key) = runAntiquoted (DoubleQuoted $ one $ Plain "\n") prettyString - (\ x -> "${" <> withoutParens x <> "}") + antiquote key prettySelector :: NAttrPath (NixDoc ann) -> Doc ann @@ -195,32 +207,43 @@ prettyAtom = simpleExpr . pretty . atomText prettyNix :: NExpr -> Doc ann -prettyNix = withoutParens . foldFix exprFNixDoc +prettyNix = getDoc . foldFix exprFNixDoc prettyOriginExpr :: forall t f m ann . HasCitations1 m (NValue t f m) f => NExprLocF (Maybe (NValue t f m)) -> Doc ann -prettyOriginExpr = withoutParens . go +prettyOriginExpr = getDoc . go where + go :: NExprLocF (Maybe (NValue t f m)) -> NixDoc ann go = exprFNixDoc . stripAnnF . fmap render where render :: Maybe (NValue t f m) -> NixDoc ann render Nothing = simpleExpr "_" - render (Just (Free (reverse . citations @m -> p:_))) = go (_originExpr p) + render (Just (Free (reverse . citations @m -> p:_))) = go (getOriginExpr p) render _ = simpleExpr "?" -- render (Just (NValue (citations -> ps))) = - -- simpleExpr $ foldr ((\x y -> vsep [x, y]) . parens . indent 2 . withoutParens + -- simpleExpr $ foldr ((\x y -> vsep [x, y]) . parens . indent 2 . getDoc -- . go . originExpr) -- mempty (reverse ps) -exprFNixDoc :: NExprF (NixDoc ann) -> NixDoc ann +-- | Takes original expression from inside provenance information. +-- Prettifies that expression. +prettyExtractFromProvenance + :: forall t f m ann + . HasCitations1 m (NValue t f m) f + => [Provenance m (NValue t f m)] -> Doc ann +prettyExtractFromProvenance = + sep . + fmap (prettyOriginExpr . getOriginExpr) + +exprFNixDoc :: forall ann . NExprF (NixDoc ann) -> NixDoc ann exprFNixDoc = \case NConstant atom -> prettyAtom atom NStr str -> simpleExpr $ prettyString str NList xs -> - prettyContainer "[" (wrapParens appOpNonAssoc) "]" xs + prettyContainer "[" (precedenceWrap appOpNonAssoc) "]" xs NSet NonRecursive xs -> prettyContainer "{" prettyBind "}" xs NSet Recursive xs -> @@ -230,10 +253,10 @@ nest 2 $ vsep [ prettyParams args <> ":" - , withoutParens body + , getDoc body ] NBinary NApp fun arg -> - mkNixDoc appOp (wrapParens appOp fun <> " " <> wrapParens appOpNonAssoc arg) + mkNixDoc appOp (precedenceWrap appOp fun <> " " <> precedenceWrap appOpNonAssoc arg) NBinary op r1 r2 -> mkNixDoc opInfo $ @@ -244,9 +267,9 @@ ] where opInfo = getBinaryOperator op - f :: NAssoc -> NixDoc ann1 -> Doc ann1 + f :: NAssoc -> NixDoc ann -> Doc ann f x = - wrapParens + precedenceWrap $ bool opInfo (opInfo { associativity = NAssocNone }) @@ -254,7 +277,7 @@ NUnary op r1 -> mkNixDoc opInfo $ - pretty (operatorName opInfo) <> wrapParens opInfo r1 + pretty (operatorName opInfo) <> precedenceWrap opInfo r1 where opInfo = getUnaryOperator op NSelect o r' attr -> @@ -262,13 +285,10 @@ (mkNixDoc selectOp) (const leastPrecedence) o - $ wrapPath selectOp r <> "." <> prettySelector attr <> ordoc - where - r = mkNixDoc selectOp (wrapParens appOpNonAssoc r') - ordoc = - ((" or " <>) . wrapParens appOpNonAssoc) `whenJust` o + $ wrapPath selectOp (mkNixDoc selectOp (precedenceWrap appOpNonAssoc r')) <> "." <> prettySelector attr <> + ((" or " <>) . precedenceWrap appOpNonAssoc) `whenJust` o NHasAttr r attr -> - mkNixDoc hasAttrOp (wrapParens hasAttrOp r <> " ? " <> prettySelector attr) + mkNixDoc hasAttrOp (precedenceWrap hasAttrOp r <> " ? " <> prettySelector attr) NEnvPath p -> simpleExpr $ pretty @String $ "<" <> coerce p <> ">" NLiteralPath p -> pathExpr $ @@ -277,29 +297,33 @@ "./" -> "./." "../" -> "../." ".." -> "../." - _txt -> + path -> bool - ("./" <> _txt) - _txt - (any (`isPrefixOf` coerce _txt) ["/", "~/", "./", "../"]) + ("./" <> path) + path + (any (`isPrefixOf` coerce path) ["/", "~/", "./", "../"]) NSym name -> simpleExpr $ prettyVarName name NLet binds body -> leastPrecedence $ group $ vsep [ "let" - , indent 2 (vsep (fmap prettyBind binds)) - , "in " <> withoutParens body + , indent 2 (vsep $ fmap prettyBind binds) + , "in " <> getDoc body ] NIf cond trueBody falseBody -> leastPrecedence $ group $ nest 2 $ - sep - [ "if " <> withoutParens cond - , align ("then " <> withoutParens trueBody) - , align ("else " <> withoutParens falseBody) - ] + ifThenElse getDoc + where + ifThenElse :: (NixDoc ann -> Doc ann) -> Doc ann + ifThenElse wp = + sep + [ "if " <> wp cond + , align ("then " <> wp trueBody) + , align ("else " <> wp falseBody) + ] NWith scope body -> prettyAddScope "with " scope body NAssert cond body -> @@ -315,7 +339,7 @@ prettyAddScope h c b = leastPrecedence $ vsep - [h <> withoutParens c <> ";", align $ withoutParens b] + [h <> getDoc c <> ";", align $ getDoc b] valueToExpr :: forall t f m . MonadDataContext f m => NValue t f m -> NExpr @@ -325,7 +349,7 @@ phi :: NValue' t f m NExpr -> NExprF NExpr phi (NVConstant' a ) = NConstant a - phi (NVStr' ns ) = NStr $ DoubleQuoted $ one $ Plain $ stringIgnoreContext ns + phi (NVStr' ns ) = NStr $ DoubleQuoted $ one $ Plain $ ignoreContext ns phi (NVList' l ) = NList l phi (NVSet' p s) = NSet mempty [ NamedVar (one $ StaticKey k) v (fromMaybe nullPos $ (`M.lookup` p) k) @@ -339,29 +363,47 @@ :: forall t f m ann . MonadDataContext f m => NValue t f m -> Doc ann prettyNValue = prettyNix . valueToExpr -prettyNValueProv +-- | During the output, which can print only representation of value, +-- lazy thunks need to looked into & so - be evaluated (*sic) +-- This type is a simple manual witness "is the thunk gets shown". +data ValueOrigin = WasThunk | Value + deriving Eq + +prettyProv :: forall t f m ann . ( HasCitations m (NValue t f m) t , HasCitations1 m (NValue t f m) f , MonadThunk t m (NValue t f m) , MonadDataContext f m ) - => NValue t f m + => ValueOrigin -- ^ Was thunk? + -> NValue t f m -> Doc ann -prettyNValueProv v = +prettyProv wasThunk v = list - prettyNVal - (\ ps -> + id + (\ ps pv -> fillSep - [ prettyNVal + [ pv , indent 2 $ - "(" <> fold (one "from: " <> (prettyOriginExpr . _originExpr <$> ps)) <> ")" + "(" <> ("thunk " `whenTrue` (wasThunk == WasThunk) <> "from: " <> prettyExtractFromProvenance ps) <> ")" ] ) (citations @m @(NValue t f m) v) - where - prettyNVal = prettyNValue v + (prettyNValue v) +prettyNValueProv + :: forall t f m ann + . ( HasCitations m (NValue t f m) t + , HasCitations1 m (NValue t f m) f + , MonadThunk t m (NValue t f m) + , MonadDataContext f m + ) + => NValue t f m + -> Doc ann +prettyNValueProv = + prettyProv Value + prettyNThunk :: forall t f m ann . ( HasCitations m (NValue t f m) t @@ -372,25 +414,16 @@ => t -> m (Doc ann) prettyNThunk t = - do - let ps = citations @m @(NValue t f m) @t t - v' <- prettyNValue <$> dethunk t - pure $ - fillSep - [ v' - , indent 2 $ - "(" <> fold (one "thunk from: " <> (prettyOriginExpr . _originExpr <$> ps)) <> ")" - ] + prettyProv WasThunk <$> dethunk t -- | This function is used only by the testing code. printNix :: forall t f m . MonadDataContext f m => NValue t f m -> Text -printNix = iterNValueByDiscardWith thk phi +printNix = + iterNValueByDiscardWith thunkStubText phi where - thk = thunkStubText - phi :: NValue' t f m Text -> Text phi (NVConstant' a ) = atomText a - phi (NVStr' ns) = show $ stringIgnoreContext ns + phi (NVStr' ns) = "\"" <> escapeString (ignoreContext ns) <> "\"" phi (NVList' l ) = "[ " <> unwords l <> " ]" phi (NVSet' _ s) = "{ " <> @@ -405,10 +438,8 @@ v (tryRead @Int <|> tryRead @Float) where - surround s = "\"" <> s <> "\"" - tryRead :: forall a . (Read a, Show a) => Maybe Text - tryRead = fmap (surround . show) (readMaybe (toString v) :: Maybe a) + tryRead = fmap ((\ s -> "\"" <> s <> "\"") . show) $ readMaybe @a $ toString v phi NVClosure'{} = "<>" phi (NVPath' fp ) = fromString $ coerce fp phi (NVBuiltin' name _) = "< coerce name <> ">>" diff --git a/src/Nix/Reduce.hs b/src/Nix/Reduce.hs --- a/src/Nix/Reduce.hs +++ b/src/Nix/Reduce.hs @@ -20,6 +20,7 @@ , reducingEvalExpr ) where +import Nix.Prelude import Control.Monad.Catch ( MonadCatch(catch) ) #if !MIN_VERSION_base(4,13,0) import Prelude hiding ( fail ) @@ -44,8 +45,9 @@ import Nix.Expr.Types.Annotated import Nix.Frames import Nix.Options ( Options - , reduceSets - , reduceLists + , isReduceSets + , isReduceLists + , askOptions ) import Nix.Parser import Nix.Scope @@ -169,22 +171,24 @@ -- -- * Reduce a lambda function by adding its name to the local -- scope and recursively reducing its body. -reduce (NBinaryAnnF bann NApp fun arg) = fun >>= \case - f@(NSymAnn _ "import") -> - (\case - -- NEnvPathAnn pann origPath -> staticImport pann origPath - NLiteralPathAnn pann origPath -> staticImport pann origPath - v -> pure $ NBinaryAnn bann NApp f v - ) =<< arg +reduce (NBinaryAnnF bann NApp fun arg) = + (\case + f@(NSymAnn _ "import") -> + (\case + -- NEnvPathAnn pann origPath -> staticImport pann origPath + NLiteralPathAnn pann origPath -> staticImport pann origPath + v -> pure $ NBinaryAnn bann NApp f v + ) =<< arg - NAbsAnn _ (Param name) body -> - do - x <- arg - pushScope - (coerce $ HM.singleton name x) - (foldFix reduce body) + NAbsAnn _ (Param name) body -> + do + x <- arg + pushScope + (coerce $ HM.singleton name x) + (foldFix reduce body) - f -> NBinaryAnn bann NApp f <$> arg + f -> NBinaryAnn bann NApp f <$> arg + ) =<< fun -- | Reduce an integer addition to its result. reduce (NBinaryAnnF bann op larg rarg) = @@ -368,13 +372,13 @@ bool (fromMaybe annNNull <$>) catMaybes - (reduceLists opts) -- Reduce list members that aren't used; breaks if elemAt is used + (isReduceLists opts) -- Reduce list members that aren't used; breaks if elemAt is used l NSet recur binds -> pure $ NSet recur $ bool (fromMaybe annNNull <<$>>) (mapMaybe sequenceA) - (reduceSets opts) -- Reduce set members that aren't used; breaks if hasAttr is used + (isReduceSets opts) -- Reduce set members that aren't used; breaks if hasAttr is used binds NLet binds (Just body@(Ann _ x)) -> @@ -450,7 +454,7 @@ bool fmap ((pure .) . maybe annNNull) - (reduceSets opts) -- Reduce set members that aren't used; breaks if hasAttr is used + (isReduceSets opts) -- Reduce set members that aren't used; breaks if hasAttr is used (fromMaybe annNNull) pruneBinding :: Binding (Maybe NExprLoc) -> Maybe (Binding NExprLoc) @@ -471,14 +475,14 @@ expr' <- flagExprLoc =<< liftIO (reduceExpr mpath expr) eres <- (`catch` pure . Left) $ pure <$> foldFix (addEvalFlags eval) expr' - opts :: Options <- asks $ view hasLens + opts <- askOptions expr'' <- pruneTree opts expr' pure (fromMaybe annNNull expr'', eres) where addEvalFlags k (FlaggedF (b, x)) = liftIO (writeIORef b True) *> k x instance Monad m => Scoped NExprLoc (Reducer m) where - currentScopes = currentScopesReader - clearScopes = clearScopesReader @(Reducer m) @NExprLoc - pushScopes = pushScopesReader - lookupVar = lookupVarReader + askScopes = askScopesReader + clearScopes = clearScopesReader @(Reducer m) @NExprLoc + pushScopes = pushScopesReader + lookupVar = lookupVarReader diff --git a/src/Nix/Render.hs b/src/Nix/Render.hs --- a/src/Nix/Render.hs +++ b/src/Nix/Render.hs @@ -9,6 +9,7 @@ module Nix.Render where +import Nix.Prelude import qualified Data.Set as Set import Nix.Utils.Fix1 ( Fix1T , MonadFix1T @@ -24,7 +25,7 @@ class (MonadFail m, MonadIO m) => MonadFile m where readFile :: Path -> m Text default readFile :: (MonadTrans t, MonadIO m', MonadFile m', m ~ t m') => Path -> m Text - readFile = liftIO . Prelude.readFile + readFile = liftIO . Nix.Prelude.readFile listDirectory :: Path -> m [Path] default listDirectory :: (MonadTrans t, MonadFile m', m ~ t m') => Path -> m [Path] listDirectory = lift . listDirectory @@ -51,7 +52,7 @@ getSymbolicLinkStatus = lift . getSymbolicLinkStatus instance MonadFile IO where - readFile = Prelude.readFile + readFile = Nix.Prelude.readFile listDirectory = coerce S.listDirectory getCurrentDirectory = coerce S.getCurrentDirectory canonicalizePath = coerce S.canonicalizePath 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 @@ -9,7 +9,7 @@ -- | Code for rendering/representation of the messages packaged with their context (Frames). module Nix.Render.Frame where -import Prelude hiding ( Comparison ) +import Nix.Prelude hiding ( Comparison ) import GHC.Exception ( ErrorCall ) import Data.Fix ( Fix(..) ) import Nix.Eval hiding ( addMetaInfo ) @@ -41,10 +41,10 @@ renderFrames [] = stub renderFrames xss@(x : xs) = do - opts :: Options <- asks $ view hasLens + opts <- askOptions let verbosity :: Verbosity - verbosity = verbose opts + verbosity = getVerbosity opts renderedFrames <- if | verbosity <= ErrorsOnly -> render1 x -- 2021-10-22: NOTE: List reverse is completely conterproductive. `reverse` of list famously neest to traverse the whole list to take the last element @@ -104,7 +104,7 @@ -> m [Doc ann] renderEvalFrame level f = do - opts :: Options <- asks (view hasLens) + opts <- askOptions let addMetaInfo :: ([Doc ann] -> [Doc ann]) -> SrcSpan -> Doc ann -> m [Doc ann] addMetaInfo trans loc = fmap (trans . one) . renderLocation loc @@ -118,9 +118,9 @@ where scopeInfo :: [Doc ann] scopeInfo = - one (pretty $ Text.show scope) `whenTrue` showScopes opts + one (pretty $ Text.show scope) `whenTrue` isShowScopes opts - ForcingExpr _scope e@(Ann loc _) | thunks opts -> + ForcingExpr _scope e@(Ann loc _) | isThunks opts -> addMetaInfo id loc @@ -130,7 +130,7 @@ addMetaInfo id loc - $ "While calling builtins." <> pretty name + $ "While calling `builtins." <> prettyVarName name <> "`" SynHole synfo -> sequenceA @@ -151,28 +151,29 @@ -> Text -> NExprLoc -> m (Doc ann) -renderExpr _level longLabel shortLabel e@(Ann _ x) = do - opts :: Options <- asks (view hasLens) - let - lvl :: Verbosity - lvl = verbose opts +renderExpr _level longLabel shortLabel e@(Ann _ x) = + do + opts <- askOptions + let + verbosity :: Verbosity + verbosity = getVerbosity opts - expr :: NExpr - expr = stripAnnotation e + expr :: NExpr + expr = stripAnnotation e - concise = prettyNix $ Fix $ Fix (NSym "") <$ x + concise = prettyNix $ Fix $ Fix (NSym "") <$ x - chatty = - bool - (pretty $ PS.ppShow expr) - (prettyNix expr) - (lvl == Chatty) + chatty = + bool + (pretty $ PS.ppShow expr) + (prettyNix expr) + (verbosity == Chatty) - pure $ - bool - (pretty shortLabel <> fillSep [": ", concise]) - (vsep [pretty (longLabel <> ":\n>>>>>>>>"), indent 2 chatty, "<<<<<<<<"]) - (lvl >= Chatty) + pure $ + bool + (pretty shortLabel <> fillSep [": ", concise]) + (vsep [pretty (longLabel <> ":\n>>>>>>>>"), indent 2 chatty, "<<<<<<<<"]) + (verbosity >= Chatty) renderValueFrame :: forall e t f m ann @@ -214,13 +215,14 @@ -> Text -> NValue t f m -> m (Doc ann) -renderValue _level _longLabel _shortLabel v = do - opts :: Options <- asks $ view hasLens - bool - prettyNValue - prettyNValueProv - (values opts) - <$> removeEffects v +renderValue _level _longLabel _shortLabel v = + do + opts <- askOptions + bool + prettyNValue + prettyNValueProv + (isValues opts) + <$> removeEffects v dumbRenderValue :: forall e t f m ann diff --git a/src/Nix/Scope.hs b/src/Nix/Scope.hs --- a/src/Nix/Scope.hs +++ b/src/Nix/Scope.hs @@ -1,3 +1,4 @@ +{-# language UndecidableInstances #-} {-# language AllowAmbiguousTypes #-} {-# language ConstraintKinds #-} {-# language FunctionalDependencies #-} @@ -5,6 +6,7 @@ module Nix.Scope where +import Nix.Prelude import qualified Data.HashMap.Lazy as M import qualified Text.Show import Lens.Family2 @@ -18,19 +20,20 @@ , Read, Hashable , Semigroup, Monoid , Functor, Foldable, Traversable + , One ) instance Show (Scope a) where show (Scope m) = show $ M.keys m scopeLookup :: VarName -> [Scope a] -> Maybe a -scopeLookup key = foldr go Nothing +scopeLookup key = foldr fun Nothing where - go + fun :: Scope a -> Maybe a -> Maybe a - go (Scope m) rest = M.lookup key m <|> rest + fun (Scope m) rest = M.lookup key m <|> rest data Scopes m a = Scopes @@ -52,18 +55,18 @@ emptyScopes = Scopes mempty mempty class Scoped a m | m -> a where - currentScopes :: m (Scopes m a) + askScopes :: m (Scopes m a) clearScopes :: m r -> m r pushScopes :: Scopes m a -> m r -> m r lookupVar :: VarName -> m (Maybe a) -currentScopesReader +askScopesReader :: forall m a e . ( MonadReader e m , Has e (Scopes m a) ) => m (Scopes m a) -currentScopesReader = asks $ view hasLens +askScopesReader = askLocal clearScopesReader :: forall m a e r diff --git a/src/Nix/Standard.hs b/src/Nix/Standard.hs --- a/src/Nix/Standard.hs +++ b/src/Nix/Standard.hs @@ -8,6 +8,7 @@ module Nix.Standard where +import Nix.Prelude import Control.Comonad ( Comonad ) import Control.Comonad.Env ( ComonadEnv ) import Control.Monad.Catch ( MonadThrow @@ -59,9 +60,12 @@ newtype StdThunk m = StdThunk (StdCited m (NThunkF m (StdValue m))) - type StdValue' m = NValue' (StdThunk m) (StdCited m) m (StdValue m) type StdValue m = NValue (StdThunk m) (StdCited m) m +type StandardIO = StandardT (StdIdT IO) +type StdVal = StdValue StandardIO +type StdThun = StdThunk StandardIO +type StdIO = StandardIO () -- | Type alias: -- @@ -80,10 +84,10 @@ addProvenance x (StdThunk c) = StdThunk $ addProvenance1 x c instance MonadReader (Context m (StdValue m)) m => Scoped (StdValue m) m where - currentScopes = currentScopesReader - clearScopes = clearScopesReader @m @(StdValue m) - pushScopes = pushScopesReader - lookupVar = lookupVarReader + askScopes = askScopesReader + clearScopes = clearScopesReader @m @(StdValue m) + pushScopes = pushScopesReader + lookupVar = lookupVarReader instance ( MonadFix m @@ -365,11 +369,10 @@ -> StandardT (StdIdT m) a -> m a runWithBasicEffects opts = - go . (`evalStateT` mempty) . (`runReaderT` newContext opts) . runStandardT + fun . (`evalStateT` mempty) . (`runReaderT` newContext opts) . runStandardT where - go action = do - i <- newRef (1 :: Int) - runFreshIdT i action + fun action = + runFreshIdT action =<< newRef (1 :: Int) -runWithBasicEffectsIO :: Options -> StandardT (StdIdT IO) a -> IO a +runWithBasicEffectsIO :: Options -> StandardIO a -> IO a runWithBasicEffectsIO = runWithBasicEffects diff --git a/src/Nix/String.hs b/src/Nix/String.hs --- a/src/Nix/String.hs +++ b/src/Nix/String.hs @@ -2,7 +2,7 @@ module Nix.String ( NixString - , getContext + , getStringContext , mkNixString , StringContext(..) , ContextFlavor(..) @@ -10,10 +10,10 @@ , NixLikeContextValue(..) , toNixLikeContext , fromNixLikeContext - , stringHasContext + , hasContext , intercalateNixString , getStringNoContext - , stringIgnoreContext + , ignoreContext , mkNixStringWithoutContext , mkNixStringWithSingletonContext , modifyNixContents @@ -32,6 +32,7 @@ +import Nix.Prelude hiding ( Type, TVar ) import Control.Monad.Writer ( WriterT(..), MonadWriter(tell)) import qualified Data.HashMap.Lazy as M import qualified Data.HashSet as S @@ -45,12 +46,11 @@ -- ** Context --- 2021-07-18: NOTE: it should be ContextFlavor -> Varname. -- | A Nix 'StringContext' ... data StringContext = StringContext - { scPath :: !VarName - , scFlavor :: !ContextFlavor + { getStringContextFlavor :: !ContextFlavor + , getStringContextPath :: !VarName } deriving (Eq, Ord, Show, Generic) @@ -104,11 +104,10 @@ -- ** NixString --- 2021-07-18: NOTE: It should be Context -> Contents. data NixString = NixString - { nsContents :: !Text - , nsContext :: !(S.HashSet StringContext) + { getStringContext :: !(S.HashSet StringContext) + , getStringContent :: !Text } deriving (Eq, Ord, Show, Generic) @@ -127,47 +126,45 @@ -- | Constructs NixString without a context mkNixStringWithoutContext :: Text -> NixString -mkNixStringWithoutContext = (`NixString` mempty) +mkNixStringWithoutContext = NixString mempty -- | Create NixString using a singleton context mkNixStringWithSingletonContext - :: VarName -> StringContext -> NixString -mkNixStringWithSingletonContext s c = NixString (coerce @VarName @Text s) $ one c + :: StringContext -> VarName -> NixString +mkNixStringWithSingletonContext c s = NixString (one c) (coerce @VarName @Text s) -- | Create NixString from a Text and context -mkNixString :: Text -> S.HashSet StringContext -> NixString +mkNixString + :: S.HashSet StringContext -> Text -> NixString mkNixString = NixString -- ** Checkers -- | Returns True if the NixString has an associated context -stringHasContext :: NixString -> Bool -stringHasContext (NixString _ c) = not $ null c +hasContext :: NixString -> Bool +hasContext (NixString c _) = not $ null c -- ** Getters -getContext :: NixString -> S.HashSet StringContext -getContext = nsContext - fromNixLikeContext :: NixLikeContext -> S.HashSet StringContext fromNixLikeContext = - S.fromList . (toStringContexts <=< (M.toList . getNixLikeContext)) + S.fromList . (uncurry toStringContexts <=< M.toList . getNixLikeContext) -- | Extract the string contents from a NixString that has no context getStringNoContext :: NixString -> Maybe Text -getStringNoContext (NixString s c) +getStringNoContext (NixString c s) | null c = pure s | otherwise = mempty -- | Extract the string contents from a NixString even if the NixString has an associated context -stringIgnoreContext :: NixString -> Text -stringIgnoreContext (NixString s _) = s +ignoreContext :: NixString -> Text +ignoreContext (NixString _ s) = s -- | Get the contents of a 'NixString' and write its context into the resulting set. extractNixString :: Monad m => NixString -> WithStringContextT m Text -extractNixString (NixString s c) = +extractNixString (NixString c s) = WithStringContextT $ s <$ tell c @@ -176,11 +173,10 @@ -- this really should be 2 args, then with @toStringContexts path@ laziness it would tail recurse. -- for now tuple dissected internaly with laziness preservation. -toStringContexts :: (VarName, NixLikeContextValue) -> [StringContext] -toStringContexts ~(path, nlcv) = - go nlcv +toStringContexts :: VarName -> NixLikeContextValue -> [StringContext] +toStringContexts path = go where - + go :: NixLikeContextValue -> [StringContext] go cv = case cv of NixLikeContextValue True _ _ -> @@ -191,29 +187,32 @@ mkCtxFor . DerivationOutput <$> ls _ -> mempty where - mkCtxFor = StringContext path - mkLstCtxFor t c = mkCtxFor t : go c + mkCtxFor :: ContextFlavor -> StringContext + mkCtxFor context = StringContext context path + mkLstCtxFor :: ContextFlavor -> NixLikeContextValue -> [StringContext] + mkLstCtxFor t c = one (mkCtxFor t) <> go c -toNixLikeContextValue :: StringContext -> (VarName, NixLikeContextValue) + +toNixLikeContextValue :: StringContext -> (NixLikeContextValue, VarName) toNixLikeContextValue sc = - ( scPath sc - , case scFlavor sc of + ( case getStringContextFlavor sc of DirectPath -> NixLikeContextValue True False mempty AllOutputs -> NixLikeContextValue False True mempty DerivationOutput t -> NixLikeContextValue False False $ one t + , getStringContextPath sc ) toNixLikeContext :: S.HashSet StringContext -> NixLikeContext toNixLikeContext stringContext = NixLikeContext $ S.foldr - go + fun mempty stringContext where - go sc hm = - let (t, nlcv) = toNixLikeContextValue sc in - M.insertWith (<>) t nlcv hm + fun :: (StringContext -> AttrSet NixLikeContextValue -> AttrSet NixLikeContextValue) + fun sc hm = + uncurry (M.insertWith (<>)) (swap $ toNixLikeContextValue sc) hm -- | Add 'StringContext's into the resulting set. addStringContext @@ -227,7 +226,7 @@ -- | Run an action producing a string with a context and put those into a 'NixString'. runWithStringContextT :: Monad m => WithStringContextT m Text -> m NixString runWithStringContextT (WithStringContextT m) = - uncurry NixString <$> runWriterT m + uncurry (flip NixString) <$> runWriterT m -- | Run an action producing a string with a context and put those into a 'NixString'. runWithStringContext :: WithStringContextT Identity Text -> NixString @@ -238,7 +237,7 @@ -- | Modify the string part of the NixString, leaving the context unchanged modifyNixContents :: (Text -> Text) -> NixString -> NixString -modifyNixContents f (NixString s c) = NixString (f s) c +modifyNixContents f (NixString c s) = NixString c (f s) -- | Run an action that manipulates nix strings, and collect the contexts encountered. -- Warning: this may be unsafe, depending on how you handle the resulting context list. @@ -255,15 +254,9 @@ intercalateNixString _ [] = mempty intercalateNixString _ [ns] = ns intercalateNixString sep nss = - uncurry NixString $ mapPair intertwine unpackNss - where - - intertwine = - ( Text.intercalate (nsContents sep) - , S.unions . (:) (nsContext sep) - ) - - unpackNss = (fnss nsContents, fnss nsContext) - where - fnss = (`fmap` nss) -- do once - + uncurry NixString $ + mapPair + (S.unions . (one (getStringContext sep) <>) . (getStringContext <$>) + , Text.intercalate (getStringContent sep) . (getStringContent <$>) + ) + $ dup nss diff --git a/src/Nix/String/Coerce.hs b/src/Nix/String/Coerce.hs --- a/src/Nix/String/Coerce.hs +++ b/src/Nix/String/Coerce.hs @@ -2,10 +2,12 @@ module Nix.String.Coerce where +import Nix.Prelude import Control.Monad.Catch ( MonadThrow ) import GHC.Exception ( ErrorCall(ErrorCall) ) import qualified Data.HashMap.Lazy as M import Nix.Atoms +import Nix.Expr.Types ( VarName ) import Nix.Effects import Nix.Frames import Nix.String @@ -18,8 +20,8 @@ -- | Data type to avoid boolean blindness on what used to be called coerceMore data CoercionLevel - = CoerceStringy - -- ^ Coerce only stringlike types: strings, paths, and appropriate sets + = CoerceStringlike + -- ^ Coerce only stringlike types: strings, paths | CoerceAny -- ^ Coerce everything but functions deriving (Eq,Ord,Enum,Bounded) @@ -32,8 +34,12 @@ -- ^ Add paths to the store as they are encountered deriving (Eq,Ord,Enum,Bounded) +-- 2021-10-30: NOTE: This seems like metafunction that really is a bunch of functions thrown together. +-- Both code blocks are `\case` - which means they can be or 2 functions, or just as well can be one `\case` that goes through all of them and does not require a `CoercionLevel`. Use of function shows that - the `CoercionLevel` not once was used polymorphically. +-- Also `CopyToStoreMode` acts only in case of `NVPath` - that is a separate function coerceToString - :: ( Framed e m + :: forall e t f m + . ( Framed e m , MonadStore m , MonadThrow m , MonadDataErrorContext t f m @@ -44,74 +50,89 @@ -> CoercionLevel -> NValue t f m -> m NixString -coerceToString call ctsm clevel = go +coerceToString call ctsm clevel = + bool + (coerceAnyToNixString call ctsm) + (coerceStringlikeToNixString ctsm) + (clevel == CoerceStringlike) + +coerceAnyToNixString + :: forall e t f m + . ( Framed e m + , MonadStore m + , MonadThrow m + , MonadDataErrorContext t f m + , MonadValue (NValue t f m) m + ) + => (NValue t f m -> NValue t f m -> m (NValue t f m)) + -> CopyToStoreMode + -> NValue t f m + -> m NixString +coerceAnyToNixString call ctsm = go where + go :: NValue t f m -> m NixString go x = - do - x' <- demand x - bool - (coerceStringy x') - (coerceAny x') - (clevel == CoerceAny) + coerceAny =<< demand x where - - coerceAny x' = - case x' of + coerceAny :: NValue t f m -> m NixString + coerceAny = + \case -- TODO Return a singleton for "" and "1" NVConstant (NBool b) -> castToNixString $ "1" `whenTrue` b NVConstant (NInt n) -> - castToNixString $ - show n + castToNixString $ show n NVConstant (NFloat n) -> - castToNixString $ - show n + castToNixString $ show n NVConstant NNull -> castToNixString mempty - -- NVConstant: NAtom (NURI Text) is not matched NVList l -> nixStringUnwords <$> traverse go l - v -> coerceStringy v - - coerceStringy x' = - case x' of - NVStr ns -> pure ns - NVPath p -> - bool - (castToNixString . fromString . coerce) - (fmap storePathToNixString . addPath) - (ctsm == CopyToStore) - p v@(NVSet _ s) -> - maybe - (maybe - (err v) - (gosw False) - (M.lookup "outPath" s) - ) - (gosw True) - (M.lookup "__toString" s) + fromMaybe + (err v) + $ continueOnKey (`call` v) "__toString" + <|> continueOnKey pure "outPath" where - gosw b p = - do - p' <- demand p - bool - go - (go <=< (`call` v)) - b - p' + continueOnKey :: (NValue t f m -> m (NValue t f m)) -> VarName -> Maybe (m NixString) + continueOnKey f = fmap (go <=< f) . (`M.lookup` s) + err v' = throwError $ ErrorCall $ "Expected a Set that has `__toString` or `outpath`, but saw: " <> show v' + v -> coerceStringlike v + where + castToNixString = pure . mkNixStringWithoutContext - v -> err v - err v = throwError $ ErrorCall $ "Expected a string, but saw: " <> show v - castToNixString = pure . mkNixStringWithoutContext + nixStringUnwords = intercalateNixString $ mkNixStringWithoutContext " " - nixStringUnwords = intercalateNixString $ mkNixStringWithoutContext " " + coerceStringlike :: NValue t f m -> m NixString + coerceStringlike = coerceStringlikeToNixString ctsm - storePathToNixString :: StorePath -> NixString - storePathToNixString sp = - mkNixStringWithSingletonContext - t - (StringContext t DirectPath) - where - t = fromString $ coerce sp +coerceStringlikeToNixString + :: forall e t f m + . ( Framed e m + , MonadStore m + , MonadThrow m + , MonadDataErrorContext t f m + , MonadValue (NValue t f m) m + ) + => CopyToStoreMode + -> NValue t f m + -> m NixString +coerceStringlikeToNixString ctsm = + (\case + NVStr ns -> pure ns + NVPath p -> coercePathToNixString ctsm p + v -> throwError $ ErrorCall $ "Expected a path or string, but saw: " <> show v + ) <=< demand +-- | Convert @Path@ into @NixString@. +-- With an additional option to store the resolved path into Nix Store. +coercePathToNixString :: (MonadStore m, Framed e m) => CopyToStoreMode -> Path -> m NixString +coercePathToNixString = + bool + (pure . mkNixStringWithoutContext . fromString . coerce) + ((storePathToNixString <$>) . addPath) + . (CopyToStore ==) + where + storePathToNixString :: StorePath -> NixString + storePathToNixString (fromString . coerce -> sp) = + (mkNixStringWithSingletonContext . StringContext DirectPath) sp sp diff --git a/src/Nix/TH.hs b/src/Nix/TH.hs --- a/src/Nix/TH.hs +++ b/src/Nix/TH.hs @@ -2,11 +2,10 @@ {-# language TemplateHaskell #-} {-# options_ghc -Wno-missing-fields #-} -{-# options_ghc -Wno-name-shadowing #-} module Nix.TH where -import Data.Fix ( Fix(unFix) ) +import Nix.Prelude import Data.Generics.Aliases ( extQ ) import qualified Data.Set as Set import Language.Haskell.TH @@ -22,17 +21,18 @@ do expr <- parseExpr $ fromString s dataToExpQ - (extQOnFreeVars metaExp expr `extQ` (pure . (TH.lift :: Text -> Q Exp))) + (extQOnFreeVars metaExp expr `extQ` (pure . (TH.lift :: Text -> ExpQ))) expr quoteExprPat :: String -> PatQ quoteExprPat s = do - expr <- parseExpr $ fromString s + expr <- parseExpr @Q $ fromString s dataToPatQ - (extQOnFreeVars metaPat expr) + (extQOnFreeVars @_ @NExprLoc @PatQ metaPat expr) expr + -- | Helper function. extQOnFreeVars :: ( Typeable b @@ -45,86 +45,7 @@ -> NExpr -> b -> Maybe q -extQOnFreeVars f = extQ (const Nothing) . f . freeVars - -parseExpr :: (MonadFail m) => Text -> m NExpr -parseExpr = - either - (fail . show) - pure - . parseNixText - -freeVars :: NExpr -> Set VarName -freeVars e = case unFix e of - (NConstant _ ) -> mempty - (NStr string ) -> mapFreeVars string - (NSym var ) -> one var - (NList list ) -> mapFreeVars list - (NSet NonRecursive bindings) -> bindFreeVars bindings - (NSet Recursive bindings) -> diffBetween bindFreeVars bindDefs bindings - (NLiteralPath _ ) -> mempty - (NEnvPath _ ) -> mempty - (NUnary _ expr ) -> freeVars expr - (NBinary _ left right ) -> collectFreeVars left right - (NSelect orExpr expr path) -> - Set.unions - [ freeVars expr - , pathFree path - , freeVars `whenJust` orExpr - ] - (NHasAttr expr path) -> freeVars expr <> pathFree path - (NAbs (Param varname) expr) -> Set.delete varname (freeVars expr) - (NAbs (ParamSet varname _ pset) expr) -> - -- Include all free variables from the expression and the default arguments - freeVars expr <> - -- But remove the argument name if existing, and all arguments in the parameter set - Set.difference - (Set.unions $ freeVars <$> mapMaybe snd pset) - (Set.difference - (one `whenJust` varname) - (Set.fromList $ fst <$> pset) - ) - (NLet bindings expr ) -> - freeVars expr <> - diffBetween bindFreeVars bindDefs bindings - (NIf cond th el ) -> Set.unions $ freeVars <$> [cond, th, el] - -- Evaluation is needed to find out whether x is a "real" free variable in `with y; x`, we just include it - -- This also makes sense because its value can be overridden by `x: with y; x` - (NWith set expr ) -> collectFreeVars set expr - (NAssert assertion expr ) -> collectFreeVars assertion expr - (NSynHole _ ) -> mempty - - where - - diffBetween :: (a -> Set VarName) -> (a -> Set VarName) -> a -> Set VarName - diffBetween g f b = Set.difference (g b) (f b) - - collectFreeVars :: NExpr -> NExpr -> Set VarName - collectFreeVars = (<>) `on` freeVars - - bindDefs :: Foldable t => t (Binding NExpr) -> Set VarName - bindDefs = foldMap bind1Def - where - bind1Def :: Binding r -> Set VarName - bind1Def (Inherit Nothing _ _) = mempty - bind1Def (Inherit (Just _ ) keys _) = Set.fromList keys - bind1Def (NamedVar (StaticKey varname :| _) _ _) = one varname - bind1Def (NamedVar (DynamicKey _ :| _) _ _) = mempty - - bindFreeVars :: Foldable t => t (Binding NExpr) -> Set VarName - bindFreeVars = foldMap bind1Free - where - bind1Free :: Binding NExpr -> Set VarName - bind1Free (Inherit Nothing keys _) = Set.fromList keys - bind1Free (Inherit (Just scope) _ _) = freeVars scope - bind1Free (NamedVar path expr _) = pathFree path <> freeVars expr - - pathFree :: NAttrPath NExpr -> Set VarName - pathFree = foldMap mapFreeVars - - mapFreeVars :: Foldable t => t NExpr -> Set VarName - mapFreeVars = foldMap freeVars - +extQOnFreeVars f = extQ (const Nothing) . f . getFreeVars class ToExpr a where toExpr :: a -> NExprLoc diff --git a/src/Nix/Thunk.hs b/src/Nix/Thunk.hs --- a/src/Nix/Thunk.hs +++ b/src/Nix/Thunk.hs @@ -4,6 +4,7 @@ module Nix.Thunk where +import Nix.Prelude import Control.Monad.Trans.Writer ( WriterT ) import qualified Text.Show diff --git a/src/Nix/Thunk/Basic.hs b/src/Nix/Thunk/Basic.hs --- a/src/Nix/Thunk/Basic.hs +++ b/src/Nix/Thunk/Basic.hs @@ -10,6 +10,7 @@ , MonadBasicThunk ) where +import Nix.Prelude import Control.Monad.Ref ( MonadRef(Ref, newRef, readRef, writeRef) , MonadAtomicRef(atomicModifyRef) ) @@ -108,9 +109,7 @@ query :: m v -> NThunkF m v -> m v query vStub (Thunk _ _ lTValRef) = - do - v <- readRef lTValRef - deferred pure (const vStub) v + deferred pure (const vStub) =<< readRef lTValRef force :: NThunkF m v -> m v force = forceMain @@ -120,12 +119,7 @@ further :: NThunkF m v -> m (NThunkF m v) further t@(Thunk _ _ ref) = - do - _ <- - atomicModifyRef - ref - dup - pure t + const (pure t) =<< atomicModifyRef ref dup -- *** United body of `force*` @@ -135,16 +129,16 @@ -- Checks if resource is computed, -- if not - with locking evaluates the resource. forceMain - :: ( MonadBasicThunk m + :: forall v m + . ( MonadBasicThunk m , MonadCatch m ) => NThunkF m v -> m v forceMain (Thunk tIdV tRefV tValRefV) = - do - v <- readRef tValRefV - deferred pure computeW v + deferred pure computeW =<< readRef tValRefV where + computeW :: m v -> m v computeW vDefferred = do locked <- lock tRefV @@ -156,16 +150,19 @@ unlockRef pure v ) - (not locked) - - lockFailedV = throwM $ ThunkLoop $ show tIdV + $ not locked + where + lockFailedV :: m a + lockFailedV = throwM $ ThunkLoop $ show tIdV - bindFailedW (e :: SomeException) = - do - unlockRef - throwM e + bindFailedW :: SomeException -> m b + bindFailedW (e :: SomeException) = + do + unlockRef + throwM e - unlockRef = unlock tRefV + unlockRef :: m Bool + unlockRef = unlock tRefV {-# inline forceMain #-} -- it is big function, but internal, and look at its use. diff --git a/src/Nix/Type/Assumption.hs b/src/Nix/Type/Assumption.hs --- a/src/Nix/Type/Assumption.hs +++ b/src/Nix/Type/Assumption.hs @@ -1,6 +1,7 @@ +{-# language TypeFamilies #-} + -- | Basing on the Nix (Hindley–Milner) type system (that provides decidable type inference): -- gathering assumptions (inference evidence) about polymorphic types. -{-# language TypeFamilies #-} module Nix.Type.Assumption ( Assumption(..) , empty @@ -13,7 +14,7 @@ ) where -import Prelude hiding ( Type +import Nix.Prelude hiding ( Type , empty ) @@ -36,6 +37,7 @@ type OneItem Assumption = (VarName, Type) one vt = Assumption $ one vt +-- 2022-01-12: NOTE: `empty` implies Alternative. Either have Alternative or use `mempty` empty :: Assumption empty = Assumption mempty diff --git a/src/Nix/Type/Env.hs b/src/Nix/Type/Env.hs --- a/src/Nix/Type/Env.hs +++ b/src/Nix/Type/Env.hs @@ -1,4 +1,5 @@ {-# language TypeFamilies #-} + module Nix.Type.Env ( Env(..) , empty @@ -15,7 +16,7 @@ ) where -import Prelude hiding ( empty +import Nix.Prelude hiding ( empty , toList , fromList ) 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 @@ -18,14 +18,14 @@ ) where +import Nix.Prelude hiding ( Constraint + , Type + , TVar + ) import Control.Monad.Catch ( MonadThrow(..) , MonadCatch(..) ) import Control.Monad.Except ( MonadError(throwError,catchError) ) -import Prelude hiding ( Type - , TVar - , Constraint - ) import Control.Monad.Logic hiding ( fail ) import Control.Monad.Reader ( MonadFix ) import Control.Monad.Ref ( MonadAtomicRef(..) @@ -58,10 +58,6 @@ import Nix.Scope import Nix.Type.Assumption hiding ( extend ) import qualified Nix.Type.Assumption as Assumption - ( remove - , lookup - , keys - ) import Nix.Type.Env import qualified Nix.Type.Env as Env import Nix.Type.Type @@ -368,11 +364,8 @@ (foldWith fold typeConstraints) (foldWith c inferredType ) where - foldWith :: ((t a -> a) -> (Judgment s -> a) -> InferT s m a) - foldWith g f = uncurry (foldInitializedWith g f) tpl - - tpl :: (Judgment s -> InferT s m (Judgment s), t (Judgment s)) - tpl = (demand, xs) + foldWith :: (t a -> a) -> (Judgment s -> a) -> InferT s m a + foldWith g f = foldInitializedWith g f demand xs instance MonadInfer m => ToValue (AttrSet (Judgment s), PositionSet) @@ -389,10 +382,10 @@ instance Monad m => Scoped (Judgment s) (InferT s m) where - currentScopes = currentScopesReader - clearScopes = clearScopesReader @(InferT s m) @(Judgment s) - pushScopes = pushScopesReader - lookupVar = lookupVarReader + askScopes = askScopesReader + clearScopes = clearScopesReader @(InferT s m) @(Judgment s) + pushScopes = pushScopesReader + lookupVar = lookupVarReader -- newtype JThunkT s m = JThunk (NThunkF (InferT s m) (Judgment s)) @@ -455,9 +448,9 @@ polymorphicVar :: MonadInfer m => VarName -> InferT s m (Judgment s) polymorphicVar var = - fmap - (join ((`Judgment` mempty) . curry one var)) - fresh + fmap + (join $ (`Judgment` mempty) . curry one var) + fresh constInfer :: Applicative f => Type -> b -> f (Judgment s) constInfer x = const $ pure $ inferred x @@ -496,23 +489,12 @@ evalEnvPath = constInfer typePath evalUnary op (Judgment as1 cs1 t1) = - fmap - (join - $ Judgment - as1 - . (cs1 <>) . (`unops` op) . (t1 :~>) - ) - fresh + (Judgment as1 =<< (cs1 <>) . (`unops` op) . (t1 :~>)) <$> fresh - evalBinary op (Judgment as1 cs1 t1) e2 = do - Judgment as2 cs2 t2 <- e2 - fmap - (join - $ Judgment - (as1 <> as2) - . (\ cs3 -> cs1 <> cs2 <> cs3) . (`binops` op) . (\ t3 -> t1 :~> t2 :~> t3) - ) - fresh + evalBinary op (Judgment as1 cs1 t1) e2 = + do + Judgment as2 cs2 t2 <- e2 + (Judgment (as1 <> as2) =<< ((cs1 <> cs2) <>) . (`binops` op) . ((t1 :~> t2) :~>)) <$> fresh evalWith = Eval.evalWithAttrSet @@ -548,15 +530,9 @@ ((), Judgment as cs t) <- extendMSet a - (k - (pure $ - Judgment - (one (x, tv)) - mempty - tv - ) - (\_ b -> ((), ) <$> b) - ) + $ k + (pure (join ((`Judgment` mempty) . curry one x ) tv)) + $ const $ fmap (mempty,) pure $ Judgment (as `Assumption.remove` x) @@ -573,7 +549,7 @@ call = k arg $ \args b -> (args, ) <$> b names = fst <$> js - (args, Judgment as cs t) <- foldr (\(_, TVar a) -> extendMSet a) call js + (args, Judgment as cs t) <- foldr (extendMSet . (\ (TVar a) -> a) . snd) call js ty <- foldInitializedWith (TSet variadic) inferredType id args @@ -646,10 +622,7 @@ runInfer :: (forall s . InferT s (FreshIdT Int (ST s)) a) -> Either InferError a runInfer m = - runST $ - do - i <- newRef (1 :: Int) - runFreshIdT i $ runInfer' m + runST $ runFreshIdT (runInfer' m) =<< newRef (1 :: Int) inferType :: forall s m . MonadInfer m => Env -> NExpr -> InferT s m [(Subst, Type)] @@ -838,11 +811,12 @@ unifyMany :: Monad m => [Type] -> [Type] -> Solver m Subst unifyMany [] [] = stub -unifyMany (t1 : ts1) (t2 : ts2) = do - su1 <- unifies t1 t2 - su2 <- - (unifyMany `on` apply su1) ts1 ts2 - pure $ compose su1 su2 +unifyMany (t1 : ts1) (t2 : ts2) = + do + su1 <- unifies t1 t2 + su2 <- + (unifyMany `on` apply su1) ts1 ts2 + pure $ compose su1 su2 unifyMany t1 t2 = throwError $ UnificationMismatch t1 t2 nextSolvable :: [Constraint] -> (Constraint, [Constraint]) 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 @@ -3,7 +3,7 @@ -- Therefore -> from this the type inference follows. module Nix.Type.Type where -import Prelude hiding (Type, TVar) +import Nix.Prelude hiding ( Type, TVar ) import Nix.Expr.Types -- | Hindrey-Milner type interface diff --git a/src/Nix/Unused.hs b/src/Nix/Unused.hs --- a/src/Nix/Unused.hs +++ b/src/Nix/Unused.hs @@ -8,6 +8,7 @@ module Nix.Unused where +import Nix.Prelude import Control.Monad.Free ( Free(..) ) import Data.Fix ( Fix(..) ) import Lens.Family2.TH ( makeLensesBy ) diff --git a/src/Nix/Utils.hs b/src/Nix/Utils.hs --- a/src/Nix/Utils.hs +++ b/src/Nix/Utils.hs @@ -1,4 +1,3 @@ -{-# language NoImplicitPrelude #-} {-# language CPP #-} {-# language GeneralizedNewtypeDeriving #-} @@ -6,11 +5,24 @@ -- It is for import for projects other then @HNix@. -- For @HNix@ - this module gets reexported by "Prelude", so for @HNix@ please fix-up pass-through there. module Nix.Utils - ( KeyMap - , TransformF - , Transform - , Alg + ( stub + , pass + , dup + , both + , mapPair + , iterateN + , nestM + , applyAll + , traverse2 + , lifted + , whenTrue + , whenFalse + , whenJust + , whenText + , list + , free + , Path(..) , isAbsolute , () @@ -24,26 +36,21 @@ , addExtension , dropExtensions , replaceExtension + , readFile + , Alg + , Transform + , TransformF + , loebM + , adi + , Has(..) + , askLocal + + , KeyMap + , trace , traceM - , stub - , pass - , whenTrue - , whenFalse - , list - , whenText - , free - , whenJust - , dup - , mapPair - , both - , readFile - , traverseM - , lifted - , loebM - , adi , module X ) where @@ -77,6 +84,7 @@ , _2 ) import qualified System.FilePath as FilePath +import Control.Monad.List (foldM) #if ENABLE_TRACING import qualified Relude.Debug as X @@ -90,7 +98,146 @@ {-# inline traceM #-} #endif --- | To have explicit type boundary between FilePath & String. +-- * Helpers + +-- After migration from the @relude@ - @relude: pass -> stub@ +-- | @pure mempty@: Short-curcuit, stub. +stub :: (Applicative f, Monoid a) => f a +stub = pure mempty +{-# inline stub #-} + +-- | Alias for 'stub', since "Relude" has more specialized @pure ()@. +pass :: (Applicative f) => f () +pass = stub +{-# inline pass #-} + +-- | Duplicates object into a tuple. +dup :: a -> (a, a) +dup x = (x, x) +{-# inline dup #-} + +-- | Apply a single function to both components of a pair. +-- +-- > both succ (1,2) == (2,3) +-- +-- Taken From package @extra@ +both :: (a -> b) -> (a, a) -> (b, b) +both f (x,y) = (f x, f y) +{-# inline both #-} + +-- | Gives tuple laziness. +-- +-- Takem from @utility-ht@. +mapPair :: (a -> c, b -> d) -> (a,b) -> (c,d) +mapPair ~(f,g) ~(a,b) = (f a, g b) +{-# inline mapPair #-} + +iterateN + :: forall a + . Int -- ^ Recursively apply 'Int' times + -> (a -> a) -- ^ the function + -> a -- ^ starting from argument + -> a +iterateN n f x = + -- It is hard to read - yes. It is a non-recursive momoized action - yes. + fix ((<*> (0 /=)) . ((bool x . f) .) . (. pred)) n + +nestM + :: Monad m + => Int -- ^ Recursively apply 'Int' times + -> (a -> m a) -- ^ function (Kleisli arrow). + -> a -- ^ to value + -> m a -- ^ & join layers of 'm' +nestM 0 _ x = pure x +nestM n f x = + foldM (const . f) x $ replicate @() n mempty -- fuses. But also, can it be fix join? +{-# inline nestM #-} + +-- | In `foldr` order apply functions. +applyAll :: Foldable t => t (a -> a) -> a -> a +applyAll = flip (foldr id) + +traverse2 + :: ( Applicative m + , Applicative n + , Traversable t + ) + => ( a + -> m (n b) + ) -- ^ Run function that runs 2 'Applicative' actions + -> t a -- ^ on every element in 'Traversable' + -> m (n (t b)) -- ^ collect the results. +traverse2 f x = sequenceA <$> traverse f x + +-- 2021-08-21: NOTE: Someone needs to put in normal words, what this does. +-- This function is pretty spefic & used only once, in "Nix.Normal". +lifted + :: (MonadTransControl u, Monad (u m), Monad m) + => ((a -> m (StT u b)) -> m (StT u b)) + -> (a -> u m b) + -> u m b +lifted f k = + restoreT . pure =<< liftWith (\run -> f (run . k)) + + +-- * Eliminators + +whenTrue :: (Monoid a) + => a -> Bool -> a +whenTrue = + bool + mempty +{-# inline whenTrue #-} + +whenFalse :: (Monoid a) + => a -> Bool -> a +whenFalse f = + bool + f + mempty +{-# inline whenFalse #-} + +whenJust + :: Monoid b + => (a -> b) + -> Maybe a + -> b +whenJust = + maybe + mempty +{-# inline whenJust #-} + +-- | Analog for @bool@ or @maybe@, for list-like cons structures. +list + :: Foldable t + => b -> (t a -> b) -> t a -> b +list e f l = + bool + (f l) + e + (null l) +{-# inline list #-} + +whenText + :: a -> (Text -> a) -> Text -> a +whenText e f t = + bool + (f t) + e + (Text.null t) + +-- | Lambda analog of @maybe@ or @either@ for Free monad. +free :: (a -> b) -> (f (Free f a) -> b) -> Free f a -> b +free fP fF fr = + case fr of + Pure a -> fP a + Free fa -> fF fa +{-# inline free #-} + + +-- * Path + +-- | Explicit type boundary between FilePath & String. newtype Path = Path FilePath deriving ( Eq, Ord, Generic @@ -105,60 +252,66 @@ instance IsString Path where fromString = coerce --- This set of @Path@ funcs is to control system filepath types & typesafety and to easy migrate from FilePath to anything suitable (like @path@ or so). +-- ** Path functions --- | @isAbsolute@ specialized to @Path@. +-- | This set of @Path@ funcs is to control system filepath types & typesafety and to easily migrate from FilePath to anything suitable (like @path@ or so). + +-- | 'Path's 'FilePath.isAbsolute'. isAbsolute :: Path -> Bool isAbsolute = coerce FilePath.isAbsolute --- | @()@ specialized to @Path@ +-- | 'Path's 'FilePath.()'. () :: Path -> Path -> Path () = coerce (FilePath.) infixr 5 --- | @joinPath@ specialized to @Path@ +-- | 'Path's 'FilePath.joinPath'. joinPath :: [Path] -> Path joinPath = coerce FilePath.joinPath --- | @splitDirectories@ specialized to @Path@ +-- | 'Path's 'FilePath.splitDirectories'. splitDirectories :: Path -> [Path] splitDirectories = coerce FilePath.splitDirectories --- | @takeDirectory@ specialized to @Path@ +-- | 'Path's 'FilePath.takeDirectory'. takeDirectory :: Path -> Path takeDirectory = coerce FilePath.takeDirectory --- | @takeFileName@ specialized to @Path@ +-- | 'Path's 'FilePath.takeFileName'. takeFileName :: Path -> Path takeFileName = coerce FilePath.takeFileName --- | @takeBaseName@ specialized to @Path@ +-- | 'Path's 'FilePath.takeBaseName'. takeBaseName :: Path -> String takeBaseName = coerce FilePath.takeBaseName --- | @takeExtension@ specialized to @Path@ +-- | 'Path's 'FilePath.takeExtension'. takeExtension :: Path -> String takeExtension = coerce FilePath.takeExtensions --- | @takeExtensions@ specialized to @Path@ +-- | 'Path's 'FilePath.takeExtensions'. takeExtensions :: Path -> String takeExtensions = coerce FilePath.takeExtensions +-- | 'Path's 'FilePath.addExtensions'. addExtension :: Path -> String -> Path addExtension = coerce FilePath.addExtension --- | @dropExtensions@ specialized to @Path@ +-- | 'Path's 'FilePath.dropExtensions'. dropExtensions :: Path -> Path dropExtensions = coerce FilePath.dropExtensions --- | @replaceExtension@ specialized to @Path@ +-- | 'Path's 'FilePath.replaceExtension'. replaceExtension :: Path -> String -> Path replaceExtension = coerce FilePath.replaceExtension +-- | 'Path's 'FilePath.readFile'. +readFile :: Path -> IO Text +readFile = Text.readFile . coerce --- | > Hashmap Text -- type synonym -type KeyMap = HashMap Text +-- * Recursion scheme + -- | F-algebra defines how to reduce the fixed-point of a functor to a value. -- > type Alg f a = f a -> a type Alg f a = f a -> a @@ -171,39 +324,12 @@ -- | Do according transformation. -- -- It is a transformation between functors. --- ... --- You got me, it is a natural transformation. type TransformF f a = (f -> a) -> f -> a -class Has a b where - hasLens :: Lens' a b - -instance Has a a where - hasLens f = f - -instance Has (a, b) a where - hasLens = _1 - -instance Has (a, b) b where - hasLens = _2 - loebM :: (MonadFix m, Traversable t) => t (t a -> m a) -> m (t a) --- Sectioning here insures optimization happening. loebM f = mfix $ \a -> (`traverse` f) ($ a) {-# inline loebM #-} --- 2021-08-21: NOTE: Someone needs to put in normal words, what this does. --- This function is pretty spefic & used only once, in "Nix.Normal". -lifted - :: (MonadTransControl u, Monad (u m), Monad m) - => ((a -> m (StT u b)) -> m (StT u b)) - -> (a -> u m b) - -> u m b -lifted f k = - do - lftd <- liftWith (\run -> f (run . k)) - restoreT $ pure lftd - -- | adi is Abstracting Definitional Interpreters: -- -- https://arxiv.org/abs/1707.04755 @@ -222,102 +348,25 @@ adi g f = g $ f . (adi g f <$>) . unFix --- | Analog for @bool@ or @maybe@, for list-like cons structures. -list - :: Foldable t - => b -> (t a -> b) -> t a -> b -list e f l = - bool - (f l) - e - (null l) -{-# inline list #-} - -whenText - :: a -> (Text -> a) -> Text -> a -whenText e f t = - bool - (f t) - e - (Text.null t) - --- | Lambda analog of @maybe@ or @either@ for Free monad. -free :: (a -> b) -> (f (Free f a) -> b) -> Free f a -> b -free fP fF fr = - case fr of - Pure a -> fP a - Free fa -> fF fa -{-# inline free #-} - - -whenTrue :: (Monoid a) - => a -> Bool -> a -whenTrue = - bool - mempty -{-# inline whenTrue #-} - -whenFalse :: (Monoid a) - => a -> Bool -> a -whenFalse f = - bool - f - mempty -{-# inline whenFalse #-} - -whenJust - :: Monoid b - => (a -> b) - -> Maybe a - -> b -whenJust = - maybe - mempty -{-# inline whenJust #-} - - --- | Apply a single function to both components of a pair. --- --- > both succ (1,2) == (2,3) --- --- Taken From package @extra@ -both :: (a -> b) -> (a, a) -> (b, b) -both f (x,y) = (f x, f y) -{-# inline both #-} +-- * Has lens +class Has a b where + hasLens :: Lens' a b --- | Duplicates object into a tuple. -dup :: a -> (a, a) -dup x = (x, x) -{-# inline dup #-} +instance Has a a where + hasLens f = f --- | From @utility-ht@ for tuple laziness. -mapPair :: (a -> c, b -> d) -> (a,b) -> (c,d) -mapPair ~(f,g) ~(a,b) = (f a, g b) -{-# inline mapPair #-} +instance Has (a, b) a where + hasLens = _1 --- After migration from the @relude@ - @relude: pass -> stub@ --- | @pure mempty@: Short-curcuit, stub. -stub :: (Applicative f, Monoid a) => f a -stub = pure mempty -{-# inline stub #-} +instance Has (a, b) b where + hasLens = _2 --- | Alias for @stub@, since @Relude@ has more specialized @pure ()@. -pass :: (Applicative f) => f () -pass = stub -{-# inline pass #-} +-- | Retrive monad state by 'Lens''. +askLocal :: (MonadReader t m, Has t a) => m a +askLocal = asks $ view hasLens -readFile :: Path -> IO Text -readFile = Text.readFile . coerce +-- * Other -traverseM - :: ( Applicative m - , Applicative f - , Traversable t - ) - => ( a - -> m (f b) - ) - -> t a - -> m (f (t b)) -traverseM f x = sequenceA <$> traverse f x +-- | > Hashmap Text -- type synonym +type KeyMap = HashMap Text diff --git a/src/Nix/Utils/Fix1.hs b/src/Nix/Utils/Fix1.hs --- a/src/Nix/Utils/Fix1.hs +++ b/src/Nix/Utils/Fix1.hs @@ -7,13 +7,15 @@ module Nix.Utils.Fix1 where +import Nix.Prelude import Control.Monad.Fix ( MonadFix ) import Control.Monad.Ref ( MonadAtomicRef(..) , MonadRef(..) ) import Control.Monad.Catch ( MonadCatch , MonadMask - , MonadThrow ) + , MonadThrow + ) -- | The fixpoint combinator. -- Courtesy of Gregory Malecha. diff --git a/src/Nix/Value.hs b/src/Nix/Value.hs --- a/src/Nix/Value.hs +++ b/src/Nix/Value.hs @@ -13,6 +13,7 @@ module Nix.Value where +import Nix.Prelude import Control.Comonad ( Comonad , extract ) @@ -144,27 +145,25 @@ instance Eq1 (NValueF p m) where liftEq _ (NVConstantF x) (NVConstantF y) = x == y liftEq _ (NVStrF x) (NVStrF y) = x == y + liftEq _ (NVPathF x) (NVPathF y) = x == y liftEq eq (NVListF x) (NVListF y) = liftEq eq x y liftEq eq (NVSetF _ x) (NVSetF _ y) = liftEq eq x y - liftEq _ (NVPathF x) (NVPathF y) = x == y liftEq _ _ _ = False -- ** Show instance Show r => Show (NValueF p m r) where - showsPrec d = go - where - go :: NValueF p m r -> String -> String - go = \case + showsPrec d = + \case (NVConstantF atom ) -> showsCon1 "NVConstant" atom - (NVStrF ns ) -> showsCon1 "NVStr" (stringIgnoreContext ns) + (NVStrF ns ) -> showsCon1 "NVStr" $ ignoreContext ns (NVListF lst ) -> showsCon1 "NVList" lst (NVSetF _ attrs) -> showsCon1 "NVSet" attrs (NVClosureF params _ ) -> showsCon1 "NVClosure" params (NVPathF path ) -> showsCon1 "NVPath" path (NVBuiltinF name _ ) -> showsCon1 "NVBuiltin" name - + where showsCon1 :: Show a => String -> a -> String -> String showsCon1 con a = showParen (d > 10) $ showString (con <> " ") . showsPrec 11 a @@ -178,10 +177,10 @@ NVConstantF _ -> mempty NVStrF _ -> mempty NVPathF _ -> mempty - NVListF l -> foldMap f l - NVSetF _ s -> foldMap f s NVClosureF _ _ -> mempty NVBuiltinF _ _ -> mempty + NVListF l -> foldMap f l + NVSetF _ s -> foldMap f s -- ** Traversable @@ -207,10 +206,10 @@ -- | @bind@ bindNValueF :: (Monad m, Monad n) - => (forall x . n x -> m x) - -> (a -> n b) - -> NValueF p m a - -> n (NValueF p m b) + => (forall x . n x -> m x) -- ^ Transform @n@ into @m@. + -> (a -> n b) -- ^ A Kleisli arrow (see 'Control.Arrow.Kleisli' & Kleisli catagory). + -> NValueF p m a -- ^ "Unfixed" (openly recursive) value of an embedded Nix language. + -> n (NValueF p m b) -- ^ An implementation of @transform (f =<< x)@ for embedded Nix language values. bindNValueF transform f = \case NVConstantF a -> pure $ NVConstantF a NVStrF s -> pure $ NVStrF s @@ -285,14 +284,13 @@ instance Comonad f => Show1 (NValue' t f m) where liftShowsPrec sp sl p = \case - NVConstant' atom -> showsUnaryWith showsPrec "NVConstantF" p atom - NVStr' ns -> - showsUnaryWith showsPrec "NVStrF" p (stringIgnoreContext ns) - NVList' lst -> showsUnaryWith (liftShowsPrec sp sl) "NVListF" p lst - NVSet' _ attrs -> showsUnaryWith (liftShowsPrec sp sl) "NVSetF" p attrs - NVPath' path -> showsUnaryWith showsPrec "NVPathF" p path - NVClosure' c _ -> showsUnaryWith showsPrec "NVClosureF" p c - NVBuiltin' name _ -> showsUnaryWith showsPrec "NVBuiltinF" p name + NVConstant' atom -> showsUnaryWith showsPrec "NVConstantF" p atom + NVStr' ns -> showsUnaryWith showsPrec "NVStrF" p $ ignoreContext ns + NVList' lst -> showsUnaryWith (liftShowsPrec sp sl) "NVListF" p lst + NVSet' _ attrs -> showsUnaryWith (liftShowsPrec sp sl) "NVSetF" p attrs + NVPath' path -> showsUnaryWith showsPrec "NVPathF" p path + NVClosure' c _ -> showsUnaryWith showsPrec "NVClosureF" p c + NVBuiltin' name _ -> showsUnaryWith showsPrec "NVBuiltinF" p name -- ** Traversable @@ -327,11 +325,11 @@ iterNValue' :: forall t f m a r . MonadDataContext f m - => (a -> (NValue' t f m a -> r) -> r) + => ((NValue' t f m a -> r) -> a -> r) -> (NValue' t f m r -> r) -> NValue' t f m a -> r -iterNValue' k f = f . fmap (\a -> k a (iterNValue' k f)) +iterNValue' k f = fix ((f .) . fmap . k) -- *** Utils @@ -343,7 +341,7 @@ -> NValue' t f m a -> NValue' t f n a hoistNValue' run lft (NValue' v) = - NValue' $ lmapNValueF (hoistNValue lft run) . hoistNValueF lft <$> v + NValue' $ lmapNValueF (hoistNValue lft run) . hoistNValueF lft <$> v {-# inline hoistNValue' #-} -- ** Monad @@ -402,58 +400,62 @@ -- | Haskell constant to the Nix constant, -nvConstant' :: Applicative f +mkNVConstant' :: Applicative f => NAtom -> NValue' t f m r -nvConstant' = NValue' . pure . NVConstantF +mkNVConstant' = NValue' . pure . NVConstantF +-- | Using of Nulls is generally discouraged (in programming language design et al.), but, if you need it. +nvNull' :: Applicative f + => NValue' t f m r +nvNull' = mkNVConstant' NNull + -- | Haskell text & context to the Nix text & context, -nvStr' :: Applicative f +mkNVStr' :: Applicative f => NixString -> NValue' t f m r -nvStr' = NValue' . pure . NVStrF +mkNVStr' = NValue' . pure . NVStrF -- | Haskell @Path@ to the Nix path, -nvPath' :: Applicative f +mkNVPath' :: Applicative f => Path -> NValue' t f m r -nvPath' = NValue' . pure . NVPathF . coerce +mkNVPath' = NValue' . pure . NVPathF . coerce -- | Haskell @[]@ to the Nix @[]@, -nvList' :: Applicative f +mkNVList' :: Applicative f => [r] -> NValue' t f m r -nvList' = NValue' . pure . NVListF +mkNVList' = NValue' . pure . NVListF -- | Haskell key-value to the Nix key-value, -nvSet' :: Applicative f +mkNVSet' :: Applicative f => PositionSet -> AttrSet r -> NValue' t f m r --- 2021-07-16: NOTE: that the arguments are flipped. -nvSet' p s = NValue' $ pure $ NVSetF p s +mkNVSet' p s = NValue' $ pure $ NVSetF p s -- | Haskell closure to the Nix closure, -nvClosure' :: (Applicative f, Functor m) +mkNVClosure' :: (Applicative f, Functor m) => Params () -> (NValue t f m -> m r ) -> NValue' t f m r -nvClosure' x f = NValue' $ pure $ NVClosureF x f +mkNVClosure' x f = NValue' $ pure $ NVClosureF x f -- | Haskell functions to the Nix functions! -nvBuiltin' :: (Applicative f, Functor m) +mkNVBuiltin' :: (Applicative f, Functor m) => VarName -> (NValue t f m -> m r) -> NValue' t f m r -nvBuiltin' name f = NValue' $ pure $ NVBuiltinF name f +mkNVBuiltin' name f = NValue' $ pure $ NVBuiltinF name f -- So above we have maps of Hask subcategory objects to Nix objects, @@ -504,19 +506,19 @@ iterNValue :: forall t f m r . MonadDataContext f m - => ((Free (NValue' t f m) t -> r) -> t -> r) + => ((NValue t f m -> r) -> t -> r) -> (NValue' t f m r -> r) - -> Free (NValue' t f m) t + -> NValue t f m -> r -iterNValue k f = iter f . fmap (k (iterNValue k f)) +iterNValue k f = fix ((iter f .) . fmap . k) -- already almost iterNValue' iterNValueByDiscardWith :: MonadDataContext f m => r -> (NValue' t f m r -> r) - -> Free (NValue' t f m) t + -> NValue t f m -> r -iterNValueByDiscardWith dflt = iterNValue (\ _ _ -> dflt) +iterNValueByDiscardWith = iterNValue . const . const -- | HOF of @iterM@ from @Free@ @@ -527,10 +529,9 @@ -> (NValue' t f m (n r) -> n r) -> NValue t f m -> n r -iterNValueM transform k f = - iterM f <=< go . (k (iterNValueM transform k f) <$>) +iterNValueM transform k f = fix (((iterM f <=< go) .) . fmap . k) where - go (Pure x) = Pure <$> x + go (Pure x) = Pure <$> x -- It should be a 'sequenceA' if to remote 'transform' form function. go (Free fa) = Free <$> bindNValue' transform go fa -- *** Utils @@ -553,7 +554,7 @@ => (forall x . u m x -> m x) -> NValue t f m -> NValue t f (u m) -liftNValue run = hoistNValue run lift +liftNValue = (`hoistNValue` lift) -- *** MonadTransUnlift @@ -575,101 +576,107 @@ -- | Life of a Haskell thunk to the life of a Nix thunk, -nvThunk :: Applicative f +mkNVThunk :: Applicative f => t -> NValue t f m -nvThunk = Pure +mkNVThunk = Pure -- | Life of a Haskell constant to the life of a Nix constant, -nvConstant :: Applicative f +mkNVConstant :: Applicative f => NAtom -> NValue t f m -nvConstant = Free . nvConstant' +mkNVConstant = Free . mkNVConstant' +-- | Using of Nulls is generally discouraged (in programming language design et al.), but, if you need it. +nvNull :: Applicative f + => NValue t f m +nvNull = mkNVConstant NNull -- | Life of a Haskell sting & context to the life of a Nix string & context, -nvStr :: Applicative f +mkNVStr :: Applicative f => NixString -> NValue t f m -nvStr = Free . nvStr' +mkNVStr = Free . mkNVStr' -nvStrWithoutContext :: Applicative f +mkNVStrWithoutContext :: Applicative f => Text -> NValue t f m -nvStrWithoutContext = nvStr . mkNixStringWithoutContext +mkNVStrWithoutContext = mkNVStr . mkNixStringWithoutContext -- | Life of a Haskell FilePath to the life of a Nix path -nvPath :: Applicative f +mkNVPath :: Applicative f => Path -> NValue t f m -nvPath = Free . nvPath' +mkNVPath = Free . mkNVPath' -nvList :: Applicative f +mkNVList :: Applicative f => [NValue t f m] -> NValue t f m -nvList = Free . nvList' +mkNVList = Free . mkNVList' -nvSet :: Applicative f +mkNVSet :: Applicative f => PositionSet -> AttrSet (NValue t f m) -> NValue t f m -nvSet p s = Free $ nvSet' p s +mkNVSet p s = Free $ mkNVSet' p s -nvClosure :: (Applicative f, Functor m) +mkNVClosure :: (Applicative f, Functor m) => Params () -> (NValue t f m -> m (NValue t f m) ) -> NValue t f m -nvClosure x f = Free $ nvClosure' x f +mkNVClosure x f = Free $ mkNVClosure' x f -nvBuiltin :: (Applicative f, Functor m) +mkNVBuiltin :: (Applicative f, Functor m) => VarName -> (NValue t f m -> m (NValue t f m) ) -> NValue t f m -nvBuiltin name f = Free $ nvBuiltin' name f +mkNVBuiltin name f = Free $ mkNVBuiltin' name f builtin :: forall m f t . (MonadThunk t m (NValue t f m), MonadDataContext f m) - => VarName + => VarName -- ^ function name -> ( NValue t f m -> m (NValue t f m) - ) + ) -- ^ unary function -> m (NValue t f m) -builtin name f = pure $ nvBuiltin name $ \a -> f a +builtin = (pure .) . mkNVBuiltin builtin2 :: (MonadThunk t m (NValue t f m), MonadDataContext f m) - => VarName + => VarName -- ^ function name -> ( NValue t f m -> NValue t f m -> m (NValue t f m) - ) + ) -- ^ binary function -> m (NValue t f m) -builtin2 name f = builtin name $ \a -> builtin name $ \b -> f a b +builtin2 = ((.) <*> (.)) . builtin builtin3 :: (MonadThunk t m (NValue t f m), MonadDataContext f m) - => VarName + => VarName -- ^ function name -> ( NValue t f m -> NValue t f m -> NValue t f m -> m (NValue t f m) - ) + ) -- ^ ternary function -> m (NValue t f m) -builtin3 name f = - builtin name $ \a -> builtin name $ \b -> builtin name $ \c -> f a b c +builtin3 = + liftA2 (.) -- compose 2 together + builtin + ((.) . builtin2) -- *** @F: Evaluation -> NValue@ @@ -729,7 +736,7 @@ NNull -> TNull NVStrF ns -> TString $ - HasContext `whenTrue` stringHasContext ns + HasContext `whenTrue` hasContext ns NVListF{} -> TList NVSetF{} -> TSet NVClosureF{} -> TClosure @@ -765,17 +772,17 @@ -- * @ValueFrame@ data ValueFrame t f m - = ForcingThunk t - | ConcerningValue (NValue t f m) - | Comparison (NValue t f m) (NValue t f m) - | Addition (NValue t f m) (NValue t f m) - | Multiplication (NValue t f m) (NValue t f m) - | Division (NValue t f m) (NValue t f m) - | Coercion ValueType ValueType - | CoercionToJson (NValue t f m) - | CoercionFromJson Aeson.Value - | Expectation ValueType (NValue t f m) - deriving Typeable + = ForcingThunk t + | ConcerningValue (NValue t f m) + | Comparison (NValue t f m) (NValue t f m) + | Addition (NValue t f m) (NValue t f m) + | Multiplication (NValue t f m) (NValue t f m) + | Division (NValue t f m) (NValue t f m) + | Coercion ValueType ValueType + | CoercionToJson (NValue t f m) + | CoercionFromJson Aeson.Value + | Expectation ValueType (NValue t f m) + deriving Typeable deriving instance (Comonad f, Show t) => Show (ValueFrame t f m) @@ -798,7 +805,7 @@ $(deriveEq1 ''NValue') --- * @NValue'@ traversals, getter & setters +-- * @NValueF@ traversals, getter & setters -- | Make traversals for Nix traversable structures. $(makeTraversals ''NValueF) diff --git a/src/Nix/Value/Equal.hs b/src/Nix/Value/Equal.hs --- a/src/Nix/Value/Equal.hs +++ b/src/Nix/Value/Equal.hs @@ -6,7 +6,7 @@ module Nix.Value.Equal where -import Prelude hiding ( Comparison ) +import Nix.Prelude hiding ( Comparison ) import Control.Comonad ( Comonad(extract)) import Control.Monad.Free ( Free(Pure,Free) ) import Control.Monad.Trans.Except ( throwE ) @@ -50,20 +50,19 @@ -> m Bool alignEqM eq fa fb = fmap - isRight + (isRight @() @()) $ runExceptT $ - do - pairs <- - traverse + traverse_ + (guard <=< lift . uncurry eq) + =<< traverse (\case These a b -> pure (a, b) - _ -> throwE () + _ -> throwE mempty ) (Data.Semialign.align fa fb) - traverse_ (\ (a, b) -> guard =<< lift (eq a b)) pairs alignEq :: (Align f, Traversable f) => (a -> b -> Bool) -> f a -> f b -> Bool -alignEq eq fa fb = runIdentity $ alignEqM (\x y -> Identity (eq x y)) fa fb +alignEq eq fa fb = runIdentity $ alignEqM ((Identity .) . eq) fa fb isDerivationM :: Monad m @@ -83,7 +82,7 @@ -- We should probably really make sure the context is empty here -- but the C++ implementation ignores it. False - ((==) "derivation" . stringIgnoreContext) + ((==) "derivation" . ignoreContext) <$> f t isDerivation @@ -114,7 +113,7 @@ (NVConstantF (NFloat x), NVConstantF (NInt y)) -> pure $ x == fromInteger y (NVConstantF (NInt x), NVConstantF (NFloat y)) -> pure $ fromInteger x == y (NVConstantF lc , NVConstantF rc ) -> pure $ lc == rc - (NVStrF ls , NVStrF rs ) -> pure $ (\ i -> i ls == i rs) stringIgnoreContext + (NVStrF ls , NVStrF rs ) -> pure $ (\ i -> i ls == i rs) ignoreContext (NVListF ls , NVListF rs ) -> alignEqM eq ls rs (NVSetF _ lm , NVSetF _ rm ) -> attrsEq lm rm (NVPathF lp , NVPathF rp ) -> pure $ lp == rp @@ -129,8 +128,8 @@ valueFEq attrsEq eq x y = runIdentity $ valueFEqM - (\x' y' -> Identity $ attrsEq x' y') - (\x' y' -> Identity $ eq x' y') + ((Identity .) . attrsEq) + ((Identity .) . eq) x y @@ -165,7 +164,7 @@ -> AttrSet t -> Bool compareAttrSets f eq lm rm = runIdentity - $ compareAttrSetsM (Identity . f) (\x y -> Identity $ eq x y) lm rm + $ compareAttrSetsM (Identity . f) ((Identity .) . eq) lm rm valueEqM :: (MonadThunk t m (NValue t f m), Comonad f) diff --git a/src/Nix/Value/Monad.hs b/src/Nix/Value/Monad.hs --- a/src/Nix/Value/Monad.hs +++ b/src/Nix/Value/Monad.hs @@ -1,4 +1,3 @@ - module Nix.Value.Monad where -- * @MonadValue@ - a main implementation class diff --git a/src/Nix/Var.hs b/src/Nix/Var.hs --- a/src/Nix/Var.hs +++ b/src/Nix/Var.hs @@ -7,6 +7,7 @@ module Nix.Var () where +import Nix.Prelude import Control.Monad.Ref import Data.GADT.Compare ( GEq(..) ) import Data.STRef ( STRef ) diff --git a/src/Nix/XML.hs b/src/Nix/XML.hs --- a/src/Nix/XML.hs +++ b/src/Nix/XML.hs @@ -1,8 +1,8 @@ - module Nix.XML ( toXML ) where +import Nix.Prelude import qualified Data.HashMap.Lazy as M import Nix.Atoms import Nix.Expr.Types diff --git a/src/Prelude.hs b/src/Prelude.hs deleted file mode 100644 --- a/src/Prelude.hs +++ /dev/null @@ -1,20 +0,0 @@ --- | This is a @Prelude@, but, please, do not put things in here, --- put them into "Nix.Utils". This module is a pass-through-multiplexer, --- between our custom code ("Nix.Utils") that shadows over the outside prelude that is in use ("Relude") --- "Prelude" module has a problem of being imported & used by other projects. --- "Nix.Utils" as a module with a regular name does not have that problem. -module Prelude - ( module Nix.Utils - , module Relude - ) where - -import Nix.Utils -import Relude hiding ( pass - , force - , readFile - , whenJust - , whenNothing - , trace - , traceM - ) - diff --git a/tests/EvalTests.hs b/tests/EvalTests.hs --- a/tests/EvalTests.hs +++ b/tests/EvalTests.hs @@ -4,8 +4,12 @@ {-# options_ghc -Wno-missing-signatures #-} -module EvalTests (tests, genEvalCompareTests) where +module EvalTests + ( tests + , genEvalCompareTests + ) where +import Nix.Prelude import Control.Monad.Catch import Data.List ((\\)) import qualified Data.Set as S @@ -13,7 +17,6 @@ import NeatInterpolation (text) import Nix import Nix.Standard -import Nix.TH import Nix.Value.Equal import qualified System.Directory as D import Test.Tasty @@ -444,7 +447,7 @@ -- Regression test for #373 case_regression_373 :: Assertion case_regression_373 = - traverse_ (uncurry freeVarsEqual) + traverse_ (uncurry sameFreeVars) [ ( "{ inherit a; }" , one "a" ) @@ -456,6 +459,18 @@ ) ] +case_bound_vars :: Assertion +case_bound_vars = + traverse_ noFreeVars + [ "a: a" + , "{b}: b" + , "let c = 5; d = c; in d" + , "rec { e = 5; f = e; }" + ] + where + noFreeVars = flip sameFreeVars mempty + + case_expression_split = constantEqualText "[ \"\" [ \"a\" ] \"c\" ]" @@ -564,9 +579,10 @@ tests :: TestTree tests = $testGroupGenerator +genEvalCompareTests :: IO TestTree genEvalCompareTests = do - (coerce -> files :: [Path]) <- D.listDirectory $ coerce testDir + files <- coerce D.listDirectory testDir let unmaskedFiles :: [Path] @@ -613,7 +629,7 @@ do constantEqualText' expected actual mres <- liftIO $ on (<|>) lookupEnv "ALL_TESTS" "MATCHING_TESTS" - whenJust (const $ assertEvalMatchesNix actual) mres + whenJust (const $ assertEvalTextMatchesNix actual) mres assertNixEvalThrows :: Text -> Assertion assertNixEvalThrows a = @@ -632,14 +648,13 @@ (\(_ :: NixException) -> pure True) unless errored $ assertFailure "Did not catch nix exception" -freeVarsEqual :: Text -> [VarName] -> Assertion -freeVarsEqual a xs = +sameFreeVars :: Text -> [VarName] -> Assertion +sameFreeVars a xs = do let Right a' = parseNixText a - xs' = S.fromList xs - free' = freeVars a' - assertEqual mempty xs' free' + free' = getFreeVars a' + assertEqual mempty (S.fromList xs) free' maskedFiles :: [Path] maskedFiles = one "builtins.fetchurl-01.nix" diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -2,6 +2,7 @@ module Main where +import Nix.Prelude import Relude (force) import Relude.Unsafe (read) import qualified Control.Exception as Exc @@ -55,7 +56,7 @@ time <- getCurrentTime runWithBasicEffectsIO (defaultOptions time) $ Nix.nixEvalExprLoc mempty expr - let dir = stringIgnoreContext ns + let dir = ignoreContext ns exists <- fileExist $ toString dir unless exists $ errorWithoutStackTrace $ diff --git a/tests/NixLanguageTests.hs b/tests/NixLanguageTests.hs --- a/tests/NixLanguageTests.hs +++ b/tests/NixLanguageTests.hs @@ -1,6 +1,6 @@ - module NixLanguageTests (genTests) where +import Nix.Prelude import Control.Exception import GHC.Err ( errorWithoutStackTrace ) import Control.Monad.ST @@ -56,20 +56,25 @@ -- previously passed. newFailingTests :: Set String newFailingTests = Set.fromList - [ "eval-okay-hash" - , "eval-okay-hashfile" - , "eval-okay-path" -- #128 - , "eval-okay-types" - , "eval-okay-fromTOML" + [ "eval-okay-fromTOML" + , "eval-okay-zipAttrsWith" + , "eval-okay-tojson" + , "eval-okay-search-path" + , "eval-okay-sort" + , "eval-okay-path-antiquotation" + , "eval-okay-getattrpos-functionargs" + , "eval-okay-attrs6" ] -- | Upstream tests that test cases that HNix disaded as a misfeature that is used so rarely -- that it more effective to fix it & lint it out of existance. deprecatedRareNixQuirkTests :: Set String -deprecatedRareNixQuirkTests = Set.fromList $ - one - -- A rare quirk of Nix that is proper to fix&enforce then to support (see git commit history) +deprecatedRareNixQuirkTests = Set.fromList + [ -- A rare quirk of Nix that is proper to fix&enforce then to support (see git commit history) "eval-okay-strings-as-attrs-names" + -- Nix upstream removed this test altogether + , "eval-okay-hash" + ] genTests :: IO TestTree genTests = @@ -163,7 +168,7 @@ assertLangOkXml :: Options -> Path -> Assertion assertLangOkXml opts fileBaseName = do - actual <- stringIgnoreContext . toXML <$> hnixEvalFile opts (addNixExt fileBaseName) + actual <- ignoreContext . toXML <$> hnixEvalFile opts (addNixExt fileBaseName) expected <- read fileBaseName ".exp.xml" assertEqual mempty expected actual @@ -173,7 +178,7 @@ time <- liftIO getCurrentTime let opts = defaultOptions time case delete ".nix" $ sort $ fromString @Text . takeExtensions <$> files of - [] -> void $ hnixEvalFile opts (addNixExt name) + [] -> void $ hnixEvalFile opts $ addNixExt name [".exp" ] -> assertLangOk opts name [".exp.xml" ] -> assertLangOkXml opts name [".exp.disabled" ] -> stub diff --git a/tests/ParserTests.hs b/tests/ParserTests.hs --- a/tests/ParserTests.hs +++ b/tests/ParserTests.hs @@ -10,7 +10,7 @@ module ParserTests (tests) where -import Prelude hiding (($<)) +import Nix.Prelude hiding (($<)) import Data.Fix import NeatInterpolation (text) import Nix.Atoms @@ -540,34 +540,46 @@ ) case_select_or_precedence = - assertParsePrint [text|let - matchDef = def: matcher: - v: let - case = builtins.head (builtins.attrNames v); - in (matcher.case or def case) (v.case); -in null|] [text|let - matchDef = def: - matcher: - v: + assertParsePrint + [text| let - case = builtins.head (builtins.attrNames v); - in (matcher.case or def) case (v.case); -in null|] + matchDef = def: matcher: + v: let + case = builtins.head (builtins.attrNames v); + in (matcher.case or def case) (v.case); + in null + |] + [text| + let + matchDef = def: + matcher: + v: + let + case = builtins.head (builtins.attrNames v); + in (matcher.case or def) case (v.case); + in null + |] case_select_or_precedence2 = - assertParsePrint [text|let - matchDef = def: matcher: - v: let - case = builtins.head (builtins.attrNames v); - in (matcher.case or null.foo) (v.case); -in null|] [text|let - matchDef = def: - matcher: - v: + assertParsePrint + [text| let - case = builtins.head (builtins.attrNames v); - in (matcher.case or null).foo (v.case); -in null|] + matchDef = def: matcher: + v: let + case = builtins.head (builtins.attrNames v); + in (matcher.case or null.foo) (v.case); + in null + |] + [text| + let + matchDef = def: + matcher: + v: + let + case = builtins.head (builtins.attrNames v); + in (matcher.case or null).foo (v.case); + in null + |] -- ** Function application @@ -730,7 +742,7 @@ do res <- parseNixFile $ "data/" <> file either - (throwParseError "data file" $ toText file) + (throwParseError "data file" $ coerce fromString file) (assertEqual ("Parsing data file " <> coerce file) (stripPositionInfo expected) @@ -782,7 +794,7 @@ checkListPairs' f acc x = checkListPairs' f (acc <> one x) checks :: (VariadicAssertions a) => a -checks = checkListPairs' (uncurry assertParseText) [] +checks = checkListPairs' (uncurry assertParseText) mempty class VariadicArgs t where @@ -798,7 +810,7 @@ checkList' f acc x = checkList' f (acc <> one x) knownAs :: (VariadicArgs a) => (NixLang -> Assertion) -> a -knownAs f = checkList' f [] +knownAs f = checkList' f mempty mistakes :: (VariadicArgs a) => a mistakes = knownAs assertParseFail diff --git a/tests/PrettyParseTests.hs b/tests/PrettyParseTests.hs --- a/tests/PrettyParseTests.hs +++ b/tests/PrettyParseTests.hs @@ -6,6 +6,7 @@ module PrettyParseTests where +import Nix.Prelude import Data.Algorithm.Diff import Data.Algorithm.DiffOutput import Data.Char diff --git a/tests/PrettyTests.hs b/tests/PrettyTests.hs --- a/tests/PrettyTests.hs +++ b/tests/PrettyTests.hs @@ -1,6 +1,8 @@ {-# language TemplateHaskell #-} -module PrettyTests (tests) where +module PrettyTests ( tests ) where + +import Nix.Prelude import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.TH @@ -23,7 +25,7 @@ do assertPretty (mkStr "echo $foo") - "\"echo \\$foo\"" + "\"echo $foo\"" assertPretty (mkStr "echo ${foo}") "\"echo \\${foo}\"" diff --git a/tests/ReduceExprTests.hs b/tests/ReduceExprTests.hs --- a/tests/ReduceExprTests.hs +++ b/tests/ReduceExprTests.hs @@ -1,5 +1,8 @@ {-# options_ghc -fno-warn-name-shadowing #-} + module ReduceExprTests (tests) where + +import Nix.Prelude import Test.Tasty import Test.Tasty.HUnit diff --git a/tests/TestCommon.hs b/tests/TestCommon.hs --- a/tests/TestCommon.hs +++ b/tests/TestCommon.hs @@ -1,14 +1,12 @@ -{-# language PartialTypeSignatures #-} - module TestCommon where +import Nix.Prelude import GHC.Err ( errorWithoutStackTrace ) import Control.Monad.Catch import Data.Time import Data.Text.IO as Text import Nix import Nix.Standard -import Nix.Fresh.Basic import System.Environment import System.IO import System.PosixCompat.Files @@ -16,7 +14,7 @@ import System.Process import Test.Tasty.HUnit -hnixEvalFile :: Options -> Path -> IO (StdValue (StandardT (StdIdT IO))) +hnixEvalFile :: Options -> Path -> IO StdVal hnixEvalFile opts file = do parseResult <- parseNixFileLoc file @@ -26,51 +24,59 @@ do setEnv "TEST_VAR" "foo" runWithBasicEffects opts $ - catch (evaluateExpression (pure $ coerce file) nixEvalExprLoc normalForm expr) $ - \case - NixException frames -> - errorWithoutStackTrace . show - =<< renderFrames - @(StdValue (StandardT (StdIdT IO))) - @(StdThunk (StandardT (StdIdT IO))) - frames + evaluateExpression (pure $ coerce file) nixEvalExprLoc normalForm expr + `catch` + \case + NixException frames -> + errorWithoutStackTrace . show + =<< renderFrames + @StdVal + @StdThun + frames ) parseResult -hnixEvalText :: Options -> Text -> IO (StdValue (StandardT (StdIdT IO))) +nixEvalFile :: Path -> IO Text +nixEvalFile (coerce -> fp) = fromString <$> readProcess "nix-instantiate" ["--eval", "--strict", fp] mempty +hnixEvalText :: Options -> Text -> IO StdVal hnixEvalText opts src = either (\ err -> fail $ toString $ "Parsing failed for expression `" <> src <> "`.\n" <> show err) - (\ expr -> - runWithBasicEffects opts $ normalForm =<< nixEvalExpr mempty expr - ) - (parseNixText src) + (runWithBasicEffects opts . (normalForm <=< nixEvalExpr mempty)) + $ parseNixText src -nixEvalString :: Text -> IO Text -nixEvalString expr = +nixEvalText :: Text -> IO Text +nixEvalText expr = do - (coerce -> fp, h) <- mkstemp "nix-test-eval" + (fp, h) <- mkstemp "nix-test-eval" Text.hPutStr h expr hClose h - res <- nixEvalFile fp - removeLink $ coerce fp + res <- nixEvalFile $ coerce fp + removeLink fp pure res -nixEvalFile :: Path -> IO Text -nixEvalFile fp = fromString <$> readProcess "nix-instantiate" ["--eval", "--strict", coerce fp] mempty +assertEvalMatchesNix + :: ( Options + -> Text -> IO (NValue t (StdCited StandardIO) StandardIO) + ) + -> (Text -> IO Text) + -> Text + -> IO () +assertEvalMatchesNix evalHNix evalNix fp = + do + time <- liftIO getCurrentTime + hnixVal <- (<> "\n") . printNix <$> evalHNix (defaultOptions time) fp + nixVal <- evalNix fp + assertEqual (toString fp) nixVal hnixVal +-- | Compares @HNix@ & @Nix@ return results. assertEvalFileMatchesNix :: Path -> Assertion assertEvalFileMatchesNix fp = - do - time <- liftIO getCurrentTime - hnixVal <- (<> "\n") . printNix <$> hnixEvalFile (defaultOptions time) fp - nixVal <- nixEvalFile fp - assertEqual (coerce fp) nixVal hnixVal + assertEvalMatchesNix + (\ o -> hnixEvalFile o . coerce . toString) + (nixEvalFile . coerce . toString) + $ fromString $ coerce fp -assertEvalMatchesNix :: Text -> Assertion -assertEvalMatchesNix expr = - do - time <- liftIO getCurrentTime - hnixVal <- (<> "\n") . printNix <$> hnixEvalText (defaultOptions time) expr - nixVal <- nixEvalString expr - assertEqual (toString expr) nixVal hnixVal +assertEvalTextMatchesNix :: Text -> Assertion +assertEvalTextMatchesNix = + assertEvalMatchesNix hnixEvalText nixEvalText