diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,7 +1,114 @@ # ChangeLog -## [(diff)](https://github.com/haskell-nix/hnix/compare/0.13.1...0.14.0#files_bucket) 0.14.0 +## [(diff)](https://github.com/haskell-nix/hnix/compare/0.16.0...0.17.0#files_bucket) 0.17.0 + +* Additional + * `Nix.Effect` + * [(link)](https://github.com/haskell-nix/hnix/pull/1051) Introduction of new type NarContent, a tagged union type of `byteString` and `FilePath`. + * [(link)](https://github.com/haskell-nix/hnix/pull/1051) getURL of instance MonadHttp IO is finally working through hnix-store. Which also means + builtins.fetchurl is working through it. +* Breaking: + * `Nix.Effect` + * [(link)](https://github.com/haskell-nix/hnix/pull/1051) MonadStore's addToStore signature changed to `StorePathName -> NarContent -> RecursiveFlag -> RepairFlag -> m (Either ErrorCall StorePath)` with new introduction of NarContent. Which enable us to add byteString as file to Store. It is corresponding to the hnix-store api change. + * `Nix.Expr.Types` + * [(link)](https://github.com/haskell-nix/hnix/pull/1042/files) The central HNix type `NExprF` changed, the `NApp` was moved out of `NBinary` & now a `NExprF` constructor of its own, the type signatures were changed accordingly. + * [(link)](https://github.com/haskell-nix/hnix/pull/1038/files) project was using `megaparsec` `{,Source}Pos` and to use it shipped a lot of orphan instances. To improve the situation & performance (reports [#1026](https://github.com/haskell-nix/hnix/issues/1026), [#746](https://github.com/haskell-nix/hnix/issues/746)) project uses `N{,Source}Pos` types, related type signatures were changed accordingly. + * `Nix.Value` + * [(link)](https://github.com/haskell-nix/hnix/pull/1046/files) Unify builder `mkNV*` and `NV*` patterns by bidirectional synonyms, a lot of builders `mkNV*` are removed, and merged to `NV*`. e.g. instead of builder `mkNVList`, `NVList` should be used. + * [(link)](https://github.com/haskell-nix/hnix/pull/1046/files) Constraint `NVConstraint f = (Comonad f, Applicative f)` was introduced, in order to unify builder `mkNV*` and `NV*` patterns. + + * `Nix.Parser`: + * [(link)](https://github.com/haskell-nix/hnix/pull/1047/files) rm `OperatorInfo`, using `NOperatorDef`. Number of functions changed signatures accordingly: + * In `Nix.Pretty`: + * `NixDoc ann` + * `mkNixDoc` + * `selectOp` + * `hasAttrOp` + * `precedenceWrap` + * `wrapPath` + * In `Nix.Parser`: + * rm `get{App,Unary,Binary,Special}Operator`, currely `NOp` class instances are used instead. + + * `Nix.Pretty`: + * [(link)](https://github.com/haskell-nix/hnix/pull/1047/files) rm `appOp`, instead use `appOpDef`. + * [(link)](https://github.com/haskell-nix/hnix/pull/1047/files) `precedenceWrap` behaviour is changed (to be literal to the name), the old behaviour is now a `wrap` function. + +## [(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 + +Partial log (for now): + +* Breaking: + + * `Nix.Expr.Shorthands`: + * `inherit{,From}`: + * dropped second(/third) argument as irrelevant ([report](https://github.com/haskell-nix/hnix/issues/326)) + * bindings to inherit changed type from complex `[NKeyName]` (which is for static & dynamic keys) to `[VarName]` (`VarName` is newtype of `Text`). + * So examples of use now are: `inherit ["a", "b"]`, `inheritFrom (var "a") ["b", "c"]` + * `mkAssert`: fixed ([report](https://github.com/haskell-nix/hnix/issues/969)). + * fx presedence between the operators: + + ```haskell + (@@), (@.), (@./), ($==), ($!=), ($<), ($<=), ($>), ($>=), ($&&), ($||), ($->), ($//), ($+), ($-), ($*), ($/), ($++), (==>) + ``` + + Now these shorthands can be used without sectioning & so represent the Nix expressions one to one. + + ```haskell + nix = " a/b // c/def // < def/d" + hask = mkRelPath "a/b" $// mkRelPath "c/def" $// mkEnvPath "g" $< mkRelPath "def/d" + ``` + +* Additional + * `Nix.Expr.Shorthands`: + * added: + * `emptySet` + * `emptyList` + * `mkOp{,2}` + * `mk{,Named,Variadic,General}ParamSet` + * `mkNeg` - number negation. + * `@.<|>` for Nix language `s.x or y` expession. + * entered deprecation: + * `mkOper{,2}` bacame `mkOp{,2}`. + * `mkBinop` became `mkOp2`. + * `mkParaset` supeceeded by `mk{,Named{,Variadic},Variadic,General}ParamSet`. + * fixed: + * `mkAssert` was creating `with`, now properly creates `assert`. + +## [(diff)](https://github.com/haskell-nix/hnix/compare/0.13.1...0.14.0#files_bucket) 0.14.0 (2021-07-08) * GHC 9.0 support. diff --git a/benchmarks/Main.hs b/benchmarks/Main.hs --- a/benchmarks/Main.hs +++ b/benchmarks/Main.hs @@ -1,8 +1,9 @@ module Main where +import Nix.Prelude import Criterion.Main import qualified ParserBench main :: IO () -main = defaultMain [ParserBench.benchmarks] +main = defaultMain $ one ParserBench.benchmarks diff --git a/benchmarks/ParserBench.hs b/benchmarks/ParserBench.hs --- a/benchmarks/ParserBench.hs +++ b/benchmarks/ParserBench.hs @@ -1,11 +1,12 @@ module ParserBench (benchmarks) where +import Nix.Prelude import Nix.Parser import Criterion -benchFile :: FilePath -> Benchmark -benchFile = bench <*> whnfIO . parseNixFile . ("data/" <>) +benchFile :: Path -> Benchmark +benchFile = bench . coerce <*> whnfIO . parseNixFile . ("data/" <>) benchmarks :: Benchmark benchmarks = bgroup 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.14.0.8 +version: 0.17.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 @@ -339,9 +327,60 @@ manual: True default: False +common shared + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + , OverloadedStrings + , DeriveGeneric + , DeriveDataTypeable + , DeriveFunctor + , DeriveFoldable + , DeriveTraversable + , DeriveLift + , FlexibleContexts + , FlexibleInstances + , ScopedTypeVariables + , StandaloneDeriving + , TypeApplications + , TypeSynonymInstances + , InstanceSigs + , MultiParamTypeClasses + , TupleSections + , LambdaCase + , BangPatterns + , ViewPatterns + build-depends: + base >= 4.12 && < 5 + , data-fix >= 0.3.0 && < 0.4 + , exceptions >= 0.10.0 && < 0.11 + , filepath >= 1.4.2 && < 1.5 + , optparse-applicative >= 0.14.3 && < 0.19 + , relude >= 1.0.0 && < 1.3 + , serialise >= 0.2.1 && < 0.3 + , template-haskell >= 2.13 && < 2.22 + , time >= 1.8.0 && < 1.9 || >= 1.9.3 && < 1.13 + ghc-options: + -Wall + -Wno-incomplete-uni-patterns + -fprint-potential-instances + if flag(optimize) + default-extensions: + ApplicativeDo + ghc-options: + -O2 + -fexpose-all-unfoldings + -fspecialise-aggressively + -- if !flag(profiling) + -- build-depends: + -- ghc-datasize + library + import: shared exposed-modules: Nix + Nix.Prelude + Nix.Utils Nix.Atoms Nix.Builtins Nix.Cache @@ -383,7 +422,6 @@ Nix.Type.Env Nix.Type.Infer Nix.Type.Type - Nix.Utils Nix.Utils.Fix1 Nix.Value Nix.Value.Equal @@ -392,112 +430,70 @@ Nix.XML other-modules: Paths_hnix + Nix.Unused autogen-modules: Paths_hnix hs-source-dirs: src - mixins: - base hiding (Prelude) - , relude (Relude as Prelude) - , relude - ghc-options: - -Wall - -fprint-potential-instances build-depends: - aeson >= 1.4.2 && < 1.6 || >= 2.0 && < 2.1 + aeson >= 1.4.2 && < 1.6 || >= 2.0 && < 2.2 , array >= 0.4 && < 0.6 - , base >= 4.12 && < 4.16 , base16-bytestring >= 0.1.1 && < 1.1 , binary >= 0.8.5 && < 0.9 , bytestring >= 0.10.8 && < 0.12 , cryptonite , comonad >= 5.0.4 && < 5.1 , containers >= 0.5.11.0 && < 0.7 - , data-fix >= 0.3.0 && < 0.4 - , deepseq >= 1.4.3 && <1.5 + , deepseq >= 1.4.3 && <1.6 , deriving-compat >= 0.3 && < 0.7 , directory >= 1.3.1 && < 1.4 - , exceptions >= 0.10.0 && < 0.11 - , filepath >= 1.4.2 && < 1.5 + , extra >= 1.7 && < 1.8 , free >= 5.1 && < 5.2 , gitrev >= 1.1.0 && < 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 + , hnix-store-core >= 0.6.0 && < 0.8 + , hnix-store-remote >= 0.6.0 && < 0.7 , http-client >= 0.5.14 && < 0.6 || >= 0.6.4 && < 0.8 , http-client-tls >= 0.3.5 && < 0.4 , http-types >= 0.12.2 && < 0.13 , lens-family >= 1.2.2 && < 2.2 , lens-family-core >= 1.2.2 && < 2.2 , lens-family-th >= 0.5.0 && < 0.6 - , logict >= 0.6.0 && < 0.7 || >= 0.7.0.2 && < 0.8 - , megaparsec >= 7.0 && < 9.3 + , logict >= 0.6.0 && < 0.7 || >= 0.7.0.2 && < 0.9 + , megaparsec >= 7.0 && < 9.6 , monad-control >= 1.0.2 && < 1.1 , monadlist >= 0.0.2 && < 0.1 - , mtl >= 2.2.2 && < 2.3 + , mtl >= 2.2.2 && < 2.4 , neat-interpolation >= 0.4 && < 0.6 - , optparse-applicative >= 0.14.3 && < 0.17 , parser-combinators >= 1.0.1 && < 1.4 , pretty-show >= 1.9.5 && < 1.11 , prettyprinter >= 1.7.0 && < 1.8 , process >= 1.6.3 && < 1.7 , ref-tf >= 0.5 && < 0.6 , regex-tdfa >= 1.2.3 && < 1.4 - , relude >= 1.0.0 && < 1.1.0 , scientific >= 0.3.6 && < 0.4 - , semialign >= 1.2 && < 1.3 - , serialise >= 0.2.1 && < 0.3 + , semialign >= 1.2 && < 1.4 , some >= 1.0.1 && < 1.1 , split >= 0.2.3 && < 0.3 , syb >= 0.7 && < 0.8 - , template-haskell >= 2.13 && < 2.18 -- provides: -- * compat instances for old versions of TH for old GHCs -- * orphan instances for TH missing instances -- aka Lift Text, Bytestring, Vector, Containers, -- we use Lift Text particulrarly for GHC 8.6 , th-lift-instances >= 0.1 && < 0.2 - , text >= 1.2.3 && < 1.3 - , these >= 1.0.1 && < 1.2 - , time >= 1.8.0 && < 1.9 || >= 1.9.3 && < 1.10 - , transformers >= 0.5.5 && < 0.6 + , text >= 1.2.3 && < 2.2 + , these >= 1.0.1 && < 1.3 + , transformers >= 0.5.5 && < 0.7 , transformers-base >= 0.4.5 && < 0.5 - , unix >= 2.7.2 && < 2.8 - , unordered-containers >= 0.2.9 && < 0.3 - , vector >= 0.12.0 && < 0.13 + , unix-compat >= 0.4.3 && < 0.8 + , unordered-containers >= 0.2.14 && < 0.3 + , vector >= 0.12.0 && < 0.14 , xml >= 1.3.14 && < 1.4 - default-extensions: - OverloadedStrings - , DeriveGeneric - , DeriveDataTypeable - , DeriveFunctor - , DeriveFoldable - , DeriveTraversable - , DeriveLift - , FlexibleContexts - , FlexibleInstances - , StandaloneDeriving - , TypeApplications - , TypeSynonymInstances - , InstanceSigs - , MultiParamTypeClasses - , TupleSections - , LambdaCase - , BangPatterns - if flag(optimize) - default-extensions: - ApplicativeDo - ghc-options: - -O2 - -fexpose-all-unfoldings - -fspecialise-aggressively - -- if !flag(profiling) - -- build-depends: - -- ghc-datasize - default-language: Haskell2010 executable hnix + import: shared hs-source-dirs: main main-is: Main.hs @@ -506,65 +502,25 @@ Paths_hnix autogen-modules: Paths_hnix - ghc-options: - -Wall build-depends: - aeson - , base + hnix + , aeson , comonad , containers - , data-fix , deepseq - , exceptions - , filepath , free , haskeline >= 0.8.0.0 && < 0.9 - , hnix - , optparse-applicative , pretty-show , prettyprinter , ref-tf - , relude , repline >= 0.4.0.0 && < 0.5 - , serialise - , template-haskell - , time - mixins: - base hiding (Prelude) - , relude (Relude as Prelude) - , relude - default-extensions: - OverloadedStrings - , DeriveGeneric - , DeriveDataTypeable - , DeriveFunctor - , DeriveFoldable - , DeriveTraversable - , DeriveLift - , FlexibleContexts - , FlexibleInstances - , StandaloneDeriving - , TypeApplications - , TypeSynonymInstances - , InstanceSigs - , MultiParamTypeClasses - , TupleSections - , LambdaCase - , BangPatterns - if flag(optimize) - default-extensions: - ApplicativeDo - ghc-options: - -O2 - -fexpose-all-unfoldings - -fspecialise-aggressively if impl(ghc < 8.10) -- GHC < 8.10 comes with haskeline < 0.8, which we don't support. -- To simplify CI, we just disable the component. buildable: False - default-language: Haskell2010 test-suite hnix-tests + import: shared type: exitcode-stdio-1.0 main-is: Main.hs other-modules: @@ -575,117 +531,35 @@ PrettyTests ReduceExprTests TestCommon - mixins: - base hiding (Prelude) - , relude (Relude as Prelude) - , relude hs-source-dirs: tests - ghc-options: - -Wall - -threaded build-depends: - Diff + hnix + , Diff , Glob - , base , containers - , data-fix , directory - , exceptions - , filepath , hedgehog - , hnix , megaparsec , neat-interpolation - , optparse-applicative , pretty-show , prettyprinter , process - , relude , split , tasty , tasty-hedgehog , tasty-hunit , tasty-th - , serialise - , template-haskell - , time - , unix - default-extensions: - OverloadedStrings - , DeriveGeneric - , DeriveDataTypeable - , DeriveFunctor - , DeriveFoldable - , DeriveTraversable - , DeriveLift - , FlexibleContexts - , FlexibleInstances - , StandaloneDeriving - , TypeApplications - , TypeSynonymInstances - , InstanceSigs - , MultiParamTypeClasses - , TupleSections - , LambdaCase - , BangPatterns - if flag(optimize) - default-extensions: - ApplicativeDo - ghc-options: - -O2 - -fexpose-all-unfoldings - -fspecialise-aggressively - default-language: Haskell2010 + , unix-compat benchmark hnix-benchmarks + import: shared type: exitcode-stdio-1.0 main-is: Main.hs other-modules: ParserBench hs-source-dirs: benchmarks - mixins: - base hiding (Prelude) - , relude (Relude as Prelude) - , relude - ghc-options: - -Wall build-depends: - base + hnix , criterion - , data-fix - , exceptions - , filepath - , hnix - , optparse-applicative - , relude - , serialise - , template-haskell - , time - default-extensions: - OverloadedStrings - , DeriveGeneric - , DeriveDataTypeable - , DeriveFunctor - , DeriveFoldable - , DeriveTraversable - , DeriveLift - , FlexibleContexts - , FlexibleInstances - , StandaloneDeriving - , TypeApplications - , TypeSynonymInstances - , InstanceSigs - , MultiParamTypeClasses - , TupleSections - , LambdaCase - , BangPatterns - if flag(optimize) - default-extensions: - ApplicativeDo - ghc-options: - -O2 - -fexpose-all-unfoldings - -fspecialise-aggressively - default-language: Haskell2010 diff --git a/main/Main.hs b/main/Main.hs --- a/main/Main.hs +++ b/main/Main.hs @@ -1,30 +1,25 @@ -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE RecordWildCards #-} +{-# language MultiWayIf #-} +{-# language TypeFamilies #-} +{-# language RecordWildCards #-} module Main ( main ) where -import Nix.Utils +import Nix.Prelude +import Relude as Prelude ( force ) import Control.Comonad ( extract ) -import qualified Control.DeepSeq as Deep -import qualified Control.Exception as Exc +import qualified Control.Exception as Exception import GHC.Err ( errorWithoutStackTrace ) import Control.Monad.Free import Control.Monad.Ref ( MonadRef(readRef) ) import Control.Monad.Catch -import System.IO ( hPutStrLn, getContents ) +import System.IO ( hPutStrLn ) import qualified Data.HashMap.Lazy as M import qualified Data.Map as Map -import Data.Maybe ( fromJust ) -import qualified Data.String as String import Data.Time import qualified Data.Text.IO as Text -import Nix +import Text.Show.Pretty ( ppShow ) +import Nix hiding ( force ) import Nix.Convert -import qualified Nix.Eval as Eval -import Nix.Fresh.Basic import Nix.Json import Nix.Options.Parser import Nix.Standard @@ -35,119 +30,139 @@ import Nix.Value.Monad import Options.Applicative hiding ( ParserResult(..) ) import Prettyprinter hiding ( list ) -import Prettyprinter.Render.Text +import Prettyprinter.Render.Text ( renderIO ) import qualified Repl -import System.FilePath -import qualified Text.Show.Pretty as PS -import Nix.Utils.Fix1 ( Fix1T ) +import Nix.Eval main :: IO () main = do - time <- getCurrentTime - opts <- execParser $ nixOptionsInfo time + currentTime <- getCurrentTime + opts <- execParser $ nixOptionsInfo currentTime main' opts main' :: Options -> IO () -main' (opts@Options{..}) = runWithBasicEffectsIO opts execContentsFilesOrRepl +main' opts@Options{..} = runWithBasicEffectsIO opts execContentsFilesOrRepl 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 :: StdIO execContentsFilesOrRepl = - firstJust - -- The `--read` option: load expression from a serialized file. - [ readFrom <&> \path -> do - let file = addExtension (dropExtension path) "nixc" - process (Just file) =<< liftIO (readCache path) + fromMaybe + loadFromCliFilePathList + $ loadBinaryCacheFile <|> + loadLiteralExpression <|> + loadExpressionFromFile + where + -- | The base case: read expressions from the last CLI directive (@[FILE]@) listed on the command line. + loadFromCliFilePathList :: StdIO + loadFromCliFilePathList = + case getFilePaths of + [] -> runRepl + ["-"] -> readExpressionFromStdin + _paths -> processSeveralFiles (coerce _paths) + where + -- | Fall back to running the REPL + runRepl = withEmptyNixContext Repl.main - -- The `--expr` option: read expression from the argument string - , expression <&> processText + readExpressionFromStdin = + processExpr =<< liftIO Text.getContents - -- The `--file` argument: read expressions from the files listed in the argument file - , fromFile <&> \x -> - -- We can start use Text as in the base case, requires changing FilePath -> Text - traverse_ processFile . String.lines =<< liftIO - (case x of - "-" -> getContents - fp -> readFile fp - ) - ] - `orElse` - -- The base case: read expressions from the files listed on the command line - case filePaths of - -- With no files, fall back to running the REPL - [] -> withNixContext mempty Repl.main - ["-"] -> processText =<< liftIO Text.getContents - _paths -> traverse_ processFile _paths + processSeveralFiles :: [Path] -> StdIO + processSeveralFiles = traverse_ processFile + where + processFile path = handleResult (pure path) =<< parseNixFileLoc path - firstJust :: [Maybe a] -> Maybe a - firstJust = asum + -- | The `--read` option: load expression from a serialized file. + loadBinaryCacheFile :: Maybe StdIO + loadBinaryCacheFile = + (\ (binaryCacheFile :: Path) -> + do + let file = replaceExtension binaryCacheFile "nixc" + processCLIOptions (pure file) =<< liftIO (readCache binaryCacheFile) + ) <$> getReadFrom - orElse :: Maybe a -> a -> a - orElse = flip fromMaybe + -- | The `--expr` option: read expression from the argument string + loadLiteralExpression :: Maybe StdIO + loadLiteralExpression = processExpr <$> getExpression - processText text = handleResult Nothing $ parseNixTextLoc text + -- | 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: + -- https://github.com/haskell-nix/hnix/issues/912 + (processSeveralFiles . (coerce . toString <$>) . lines <=< liftIO) . + (\case + "-" -> Text.getContents + _fp -> readFile _fp + ) <$> getFromFile - processFile path = handleResult (Just path) =<< parseNixFileLoc path + processExpr :: Text -> StdIO + processExpr = handleResult mempty . parseNixTextLoc + withEmptyNixContext = withNixContext mempty + + -- 2021-07-15: NOTE: @handleResult@ & @process@ - have atrocious size & compexity, they need to be decomposed & refactored. handleResult mpath = either (\ err -> bool errorWithoutStackTrace (liftIO . hPutStrLn stderr) - ignoreErrors + isIgnoreErrors $ "Parse failed: " <> show err ) (\ expr -> do - when check $ + when isCheck $ do - expr' <- liftIO (reduceExpr mpath expr) + expr' <- liftIO $ reduceExpr mpath expr either - (\ err -> errorWithoutStackTrace $ "Type error: " <> PS.ppShow err) - (\ ty -> liftIO $ putStrLn $ "Type of expression: " <> PS.ppShow - (fromJust $ Map.lookup "it" (coerce ty :: Map Text [Scheme])) + (\ err -> errorWithoutStackTrace $ "Type error: " <> ppShow err) + (liftIO . putStrLn . (<>) "Type of expression: " . + ppShow . maybeToMonoid . Map.lookup @VarName @[Scheme] "it" . coerce ) - (HM.inferTop mempty [("it", stripAnnotation expr')]) + $ HM.inferTop mempty $ curry one "it" $ stripAnnotation expr' -- liftIO $ putStrLn $ runST $ -- runLintM opts . renderSymbolic =<< lint opts expr - catch (process mpath expr) $ + catch (processCLIOptions mpath expr) $ \case NixException frames -> errorWithoutStackTrace . show =<< renderFrames - @(StdValue (StandardT (StdIdT IO))) - @(StdThunk (StandardT (StdIdT IO))) + @StdVal + @StdThun frames - when repl $ - withNixContext mempty $ + when isRepl $ + withEmptyNixContext $ bool Repl.main - (do - val <- Nix.nixEvalExprLoc mpath expr - Repl.main' $ pure val - ) - evaluate + ((Repl.main' . pure) =<< nixEvalExprLoc (coerce mpath) expr) + isEvaluate ) - process mpath expr - | evaluate = + -- 2021-07-15: NOTE: Logic of CLI Option processing is scattered over several functions, needs to be consolicated. + processCLIOptions :: Maybe Path -> NExprLoc -> StdIO + processCLIOptions mpath expr + | isEvaluate = if - | tracing -> evaluateExpression mpath Nix.nixTracingEvalExprLoc printer expr - | Just path <- reduce -> evaluateExpression mpath (reduction path) printer expr - | not (null arg && null argstr) -> evaluateExpression mpath Nix.nixEvalExprLoc printer expr - | otherwise -> processResult printer =<< Nix.nixEvalExprLoc 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 $ PS.ppShow $ stripAnnotation expr - | cache , Just path <- mpath = liftIO $ writeCache (addExtension (dropExtension path) "nixc") expr - | parseOnly = void $ liftIO $ Exc.evaluate $ Deep.force expr - | otherwise = - liftIO $ + | 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 + | 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 . layoutPretty (LayoutOptions $ AvailablePerLine 80 0.4) @@ -155,28 +170,60 @@ . stripAnnotation $ expr where + evaluateExprWith evaluator = evaluateExpression (coerce mpath) evaluator printer + printer - | finder = findAttrs <=< fromValue @(AttrSet (StdValue (StandardT (StdIdT IO)))) - | xml = liftIO . Text.putStrLn . stringIgnoreContext . toXML <=< normalForm + :: 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. - | json = liftIO . Text.putStrLn . stringIgnoreContext <=< nvalueToJSONNixString <=< normalForm - | strict = liftIO . print . prettyNValue <=< normalForm - | values = liftIO . print . prettyNValueProv <=< removeEffects - | otherwise = liftIO . print . prettyNValue <=< removeEffects - where + printer' + | 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 + out + :: (b -> Text) + -> (a -> StandardIO b) + -> a + -> 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 @@ -186,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 s) - traverse_ - (\ (k, mv) -> - do - let - path = prefix <> k - (report, descend) = filterEntry path k - when report $ - do - liftIO $ Text.putStrLn path - when descend $ - maybe - pass - (\case - NVSet s' _ -> go (path <> ".") s' - _ -> pass - ) - mv - ) - xs + (sortWith fst $ M.toList $ M.mapKeys coerce s) where filterEntry path k = case (path, k) of ("stdenv", "stdenv" ) -> (True , True ) @@ -239,44 +267,45 @@ _ -> (True , True ) forceEntry - :: MonadValue a (Fix1T StandardTF (StdIdT IO)) + :: MonadValue a StandardIO => Text -> a - -> Fix1T StandardTF (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 mp x = + reduction path mpathToContext annExpr = do eres <- - Nix.withNixContext - mp - (Nix.reducingEvalExpr - Eval.evalContent - mp - x - ) + withNixContext + mpathToContext + $ reducingEvalExpr + evalContent + mpathToContext + annExpr handleReduced path eres handleReduced :: (MonadThrow m, MonadIO m) - => FilePath + => Path -> (NExprLoc, Either SomeException (NValue t f m)) -> m (NValue t f m) - handleReduced path (expr', eres) = + handleReduced (coerce -> path) (expr', eres) = do liftIO $ do diff --git a/main/Repl.hs b/main/Repl.hs --- a/main/Repl.hs +++ b/main/Repl.hs @@ -7,26 +7,23 @@ directory for more details. -} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# language MultiWayIf #-} module Repl ( main , main' ) where -import Nix hiding ( exec - , try - ) +import Nix.Prelude hiding ( state ) +import Nix hiding ( exec ) import Nix.Scope -import Nix.Utils import Nix.Value.Monad ( demand ) -import qualified Data.HashMap.Lazy +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 ) @@ -36,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) @@ -52,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 () @@ -71,7 +68,7 @@ evalStateT (evalRepl banner - (cmd . toText) + (cmd . fromString) options (pure commandPrefix) (pure "paste") @@ -99,28 +96,28 @@ rcFile = do - f <- liftIO $ Text.readFile ".hnixrc" `catch` handleMissing + f <- liftIO $ readFile ".hnixrc" `catch` handleMissing traverse_ (\case (prefixedCommand : xs) | Text.head prefixedCommand == commandPrefix -> do let - arguments = Text.unwords xs + arguments = unwords xs command = Text.tail prefixedCommand optMatcher command options arguments - x -> cmd $ Text.unwords x + x -> cmd $ unwords x ) - (Text.words <$> lines f) + (words <$> lines f) handleMissing e - | Error.isDoesNotExistError e = pure "" - | otherwise = throwIO e + | Error.isDoesNotExistError e = stub + | otherwise = throwM e -- Replicated and slightly adjusted `optMatcher` from `System.Console.Repline` -- which doesn't export it. - -- * @MonadIO m@ instead of @MonadHaskeline m@ - -- * @putStrLn@ instead of @outputStrLn@ + -- * @MonadIO m@ instead of @MonadHaskeline m@ + -- * @putStrLn@ instead of @outputStrLn@ optMatcher :: MonadIO m => Text -> Console.Options m @@ -128,16 +125,16 @@ -> m () optMatcher s [] _ = liftIO $ Text.putStrLn $ "No such command :" <> s optMatcher s ((x, m) : xs) args - | s `Text.isPrefixOf` toText x = m $ toString args + | s `Text.isPrefixOf` fromString x = m $ toString args | otherwise = optMatcher s xs args -- * Types data IState t f m = IState - { replIt :: Maybe NExprLoc -- ^ Last expression entered - , replCtx :: AttrSet (NValue t f m) -- ^ Value environment - , replCfg :: ReplConfig -- ^ REPL configuration + { replIt :: Maybe NExprLoc -- ^ Last expression entered + , replCtx :: Scope (NValue t f m) -- ^ Scope. Value environment. + , replCfg :: ReplConfig -- ^ REPL configuration } deriving (Eq, Show) data ReplConfig = ReplConfig @@ -159,17 +156,20 @@ builtins <- evalText "builtins" - opts :: Nix.Options <- asks (view hasLens) + let + scope = coerce $ + M.fromList $ + ("builtins", builtins) : fmap ("input",) (maybeToList mIni) + opts <- askOptions + pure $ IState Nothing - (Data.HashMap.Lazy.fromList $ - ("builtins", builtins) : fmap ("input",) (maybeToList mIni) - ) + 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 - st <- get +exec update source = + do + -- Get the current interpreter state + state <- get - when (cfgDebug $ replCfg st) $ liftIO $ print st + 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 st) (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 st { 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 xs _ -> put st { replCtx = xs <> replCtx st } - _ -> pass + -- 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 <> bool ";" mempty (Text.isSuffixOf ";" i) <> "}" + toAttrSet i = + "{" <> i <> whenFalse ";" (Text.isSuffixOf ";" i) <> "}" cmd :: (MonadNix e t f m, MonadIO m) @@ -258,7 +264,7 @@ do mVal <- exec True source maybe - pass + stub printValue mVal @@ -267,11 +273,15 @@ -> Repl e t f m () printValue val = do cfg <- replCfg <$> get + let + g :: MonadIO m => Doc ann0 -> m () + g = liftIO . print + lift $ lift $ (if - | cfgStrict cfg -> liftIO . print . prettyNValue <=< normalForm - | cfgValues cfg -> liftIO . print . prettyNValueProv <=< removeEffects - | otherwise -> liftIO . print . prettyNValue <=< removeEffects + | cfgStrict cfg -> g . prettyNValue <=< normalForm + | cfgValues cfg -> g . prettyNValueProv <=< removeEffects + | otherwise -> g . prettyNValue <=< removeEffects ) val @@ -281,48 +291,48 @@ browse :: (MonadNix e t f m, MonadIO m) => Text -> Repl e t f m () -browse _ = do - st <- get - for_ (Data.HashMap.Lazy.toList $ replCtx st) $ \(k, v) -> do - liftIO $ Text.putStr $ k <> " = " - printValue v +browse _ = + do + state <- get + traverse_ + (\(k, v) -> + do + liftIO $ Text.putStr $ coerce k <> " = " + printValue v + ) + (M.toList $ coerce $ replCtx state) -- | @: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. - => String + => Path -> Repl e t f m () -load args = +load path = do - contents <- liftIO $ - Text.readFile $ - trim args + contents <- liftIO $ readFile $ + trim path void $ exec True contents where - trim = dropWhileEnd isSpace . dropWhile isSpace + trim :: Path -> Path + trim = coerce . dropWhileEnd isSpace . dropWhile isSpace . coerce -- | @:type@ command typeof :: (MonadNix e t f m, MonadIO m) => Text -> Repl e t f m () -typeof args = do - st <- get +typeof src = do + state <- get mVal <- maybe - (exec False line) + (exec False src) (pure . pure) - (Data.HashMap.Lazy.lookup line (replCtx st)) + (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 @@ -332,12 +342,14 @@ -- | @:set@ command setConfig :: (MonadNix e t f m, MonadIO m) => Text -> Repl e t f m () setConfig args = - case Text.words args of - [] -> liftIO $ Text.putStrLn "No option to set specified" - (x:_xs) -> + handlePresence + (liftIO $ Text.putStrLn "No option to set specified") + (\ (x:_xs) -> case filter ((==x) . helpSetOptionName) helpSetOptions of [opt] -> modify (\s -> s { replCfg = helpSetOptionFunction opt (replCfg s) }) _ -> liftIO $ Text.putStrLn "No such option" + ) + $ words args -- * Interactive Shell @@ -345,18 +357,18 @@ -- | Prefix tab completer defaultMatcher :: MonadIO m => [(String, CompletionFunc m)] defaultMatcher = - [ (":load", Console.fileCompleter) - ] + one (":load", Console.fileCompleter) 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 -- @@ -381,9 +393,9 @@ listFiles word -- Attributes of sets in REPL context - | var : subFields <- Text.split (== '.') (toText word) , not $ null subFields = + | var : subFields <- Text.split (== '.') (fromString word) , isPresent subFields = do - s <- get + state <- get maybe stub (\ binding -> @@ -396,18 +408,24 @@ candidates ) ) - (Data.HashMap.Lazy.lookup var (replCtx s)) + (M.lookup (coerce var) $ coerce $ replCtx state) -- Builtins, context variables | otherwise = do - s <- get - let contextKeys = Data.HashMap.Lazy.keys (replCtx s) - (Just (NVSet builtins _)) = Data.HashMap.Lazy.lookup "builtins" (replCtx s) - shortBuiltins = Data.HashMap.Lazy.keys builtins + state <- get + let + scopeHashMap :: HashMap VarName (NValue t f m) + scopeHashMap = coerce $ replCtx state + contextKeys :: [VarName] + contextKeys = M.keys scopeHashMap + builtins :: AttrSet (NValue t f m) + (Just (NVSet _ builtins)) = M.lookup "builtins" scopeHashMap + shortBuiltins :: [VarName] + shortBuiltins = M.keys builtins pure $ listCompletion $ toString <$> - ["__includes"] + one "__includes" <> contextKeys <> shortBuiltins @@ -423,7 +441,7 @@ -> m [Text] algebraicComplete subFields val = let - keys = fmap ("." <>) . Data.HashMap.Lazy.keys + keys = fmap ("." <>) . M.keys withMap m = case subFields of @@ -437,10 +455,10 @@ (("." <> f) <>) . algebraicComplete fs <=< demand ) - (Data.HashMap.Lazy.lookup f m) + (M.lookup (coerce f) m) in case val of - NVSet xs _ -> withMap xs + NVSet _ xs -> withMap (M.mapKeys coerce xs) _ -> stub -- | HelpOption inspired by Dhall Repl @@ -458,44 +476,44 @@ helpOptions = [ HelpOption "help" - "" + mempty "Print help text" - (help helpOptions . toText) + (help helpOptions . fromString) , HelpOption "paste" - "" + mempty "Enter multi-line mode" (error "Unreachable") , HelpOption "load" "FILENAME" "Load .nix file into scope" - load + (load . fromString) , HelpOption "browse" - "" + mempty "Browse bindings in interpreter context" - (browse . toText) + (browse . fromString) , HelpOption "type" "EXPRESSION" "Evaluate expression or binding from context and print the type of the result value" - (typeof . toText) + (typeof . fromString) , HelpOption "quit" - "" + mempty "Quit interpreter" quit , HelpOption "set" - "" + mempty ("Set REPL option" <> Prettyprinter.line <> "Available options:" <> Prettyprinter.line <> renderSetOptions helpSetOptions ) - (setConfig . toText) + (setConfig . fromString) ] -- | Options for :set @@ -510,32 +528,32 @@ helpSetOptions = [ HelpSetOption "strict" - "" + mempty "Enable strict evaluation of REPL expressions" (\x -> x { cfgStrict = True}) , HelpSetOption "lazy" - "" + mempty "Disable strict evaluation of REPL expressions" (\x -> x { cfgStrict = False}) , HelpSetOption "values" - "" + mempty "Enable printing of value provenance information" (\x -> x { cfgValues = True}) , HelpSetOption "novalues" - "" + mempty "Disable printing of value provenance information" (\x -> x { cfgValues = False}) , HelpSetOption "debug" - "" + mempty "Enable printing of REPL debug information" (\x -> x { cfgDebug = True}) , HelpSetOption "nodebug" - "" + mempty "Disable REPL debugging" (\x -> x { cfgDebug = False}) ] @@ -557,18 +575,21 @@ -> Repl e t f m () help hs _ = do liftIO $ putStrLn "Available commands:\n" - for_ hs $ \h -> - liftIO . - Text.putStrLn . - Prettyprinter.renderStrict . - Prettyprinter.layoutPretty Prettyprinter.defaultLayoutOptions $ - ":" - <> Prettyprinter.pretty (helpOptionName h) <> space - <> helpOptionSyntax h - <> Prettyprinter.line - <> Prettyprinter.indent 4 (helpOptionDoc h) + traverse_ + (\h -> + liftIO . + Text.putStrLn . + Prettyprinter.renderStrict . + Prettyprinter.layoutPretty Prettyprinter.defaultLayoutOptions $ + ":" + <> Prettyprinter.pretty (helpOptionName h) <> space + <> helpOptionSyntax h + <> Prettyprinter.line + <> Prettyprinter.indent 4 (helpOptionDoc h) + ) + hs 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,10 +1,9 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} - module Nix ( module Nix.Cache , module Nix.Exec - , module Nix.Expr + , module Nix.Expr.Types + , module Nix.Expr.Shorthands + , module Nix.Expr.Types.Annotated , module Nix.Frames , module Nix.Render.Frame , module Nix.Normal @@ -25,6 +24,7 @@ ) where +import Nix.Prelude import Relude.Unsafe ( (!!) ) import GHC.Err ( errorWithoutStackTrace ) import Data.Fix ( Fix ) @@ -35,7 +35,9 @@ import Nix.Cache import qualified Nix.Eval as Eval import Nix.Exec -import Nix.Expr +import Nix.Expr.Types +import Nix.Expr.Shorthands +import Nix.Expr.Types.Annotated import Nix.Frames import Nix.String import Nix.Normal @@ -45,7 +47,6 @@ import Nix.Reduce import Nix.Render.Frame import Nix.Thunk -import Nix.Utils import Nix.Value import Nix.Value.Monad import Nix.XML @@ -57,7 +58,7 @@ :: (MonadNix e t f m, Has e Options, Functor g) => Transform g (m a) -> Alg g (m a) - -> Maybe FilePath + -> Maybe Path -> Fix g -> m a nixEval transform alg mpath = withNixContext mpath . adi transform alg @@ -65,7 +66,7 @@ -- | Evaluate a nix expression in the default context nixEvalExpr :: (MonadNix e t f m, Has e Options) - => Maybe FilePath + => Maybe Path -> NExpr -> m (NValue t f m) nixEvalExpr = nixEval id Eval.eval @@ -74,7 +75,7 @@ nixEvalExprLoc :: forall e t f m . (MonadNix e t f m, Has e Options) - => Maybe FilePath + => Maybe Path -> NExprLoc -> m (NValue t f m) nixEvalExprLoc = @@ -89,31 +90,31 @@ -- context. nixTracingEvalExprLoc :: (MonadNix e t f m, Has e Options, MonadIO m, Alternative m) - => Maybe FilePath + => Maybe Path -> NExprLoc -> m (NValue t f m) nixTracingEvalExprLoc mpath = withNixContext mpath . evalExprLoc evaluateExpression :: (MonadNix e t f m, Has e Options) - => Maybe FilePath - -> (Maybe FilePath -> NExprLoc -> m (NValue t f m)) + => Maybe Path + -> (Maybe Path -> NExprLoc -> m (NValue t f m)) -> (NValue t f m -> m a) -> NExprLoc -> m a evaluateExpression mpath evaluator handler expr = do - opts :: Options <- asks $ view hasLens - args <- + 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 $ NVSet mempty $ M.fromList args _ -> pure f processResult handler val where @@ -125,35 +126,34 @@ 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) - (\ (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 :: [Text] -> NValue t f m -> m a + processKeys :: [VarName] -> NValue t f m -> m a processKeys kys v = - list + handlePresence (h v) - (\ (k : ks) -> + (\ ((k : ks) :: [VarName]) -> do v' <- demand v case (k, v') of - (Text.decimal -> Right (n,""), NVList xs) -> processKeys ks $ xs !! n - (_, NVSet xs _) -> + (Text.decimal . coerce -> Right (n,""), NVList xs) -> processKeys ks $ xs !! n + (_, NVSet _ xs) -> maybe - (errorWithoutStackTrace $ toString $ "Set does not contain key '" <> k <> "'") + (errorWithoutStackTrace $ "Set does not contain key ''" <> show k <> "''.") (processKeys ks) (M.lookup k xs) - (_, _) -> errorWithoutStackTrace $ toString $ "Expected a set or list for selector '" <> k <> "', but got: " <> show v + (_, _) -> errorWithoutStackTrace $ "Expected a set or list for selector '" <> show k <> "', but got: " <> show v ) kys 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,6 +12,7 @@ import Data.Aeson.Types ( FromJSON , ToJSON ) +-- 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 @@ -1,2014 +1,2122 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MonoLocalBinds #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE PackageImports #-} -- 2021-07-05: Due to hashing Haskell IT system situation, in HNix we currently ended-up with 2 hash package dependencies @{hashing, cryptonite}@ - -{-# 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 - , builtins - ) -where - - -import Prelude hiding ( traceM ) -import Nix.Utils -import Control.Comonad ( Comonad ) -import Control.Monad ( foldM ) -import Control.Monad.Catch ( MonadCatch(catch) ) -import Control.Monad.ListM ( sortByM ) -import "hashing" Crypto.Hash -import qualified "hashing" Crypto.Hash.MD5 as MD5 -import qualified "hashing" Crypto.Hash.SHA1 as SHA1 -import qualified "hashing" Crypto.Hash.SHA256 as SHA256 -import qualified "hashing" Crypto.Hash.SHA512 as SHA512 -import qualified Data.Aeson as A -#if MIN_VERSION_aeson(2,0,0) -import qualified Data.Aeson.Key as AKM -import qualified Data.Aeson.KeyMap as AKM -#endif -import Data.Align ( alignWith ) -import Data.Array -import Data.Bits -import qualified Data.ByteString as B -import Data.ByteString.Base16 as Base16 -import Data.Char ( isDigit ) -import Data.Foldable ( foldrM ) -import Data.Fix ( foldFix ) -import Data.List ( partition ) -import qualified Data.HashMap.Lazy as M -import Data.Scientific -import qualified Data.Set as S -import qualified Data.Text as Text -import qualified Data.Text.Lazy as LazyText -import qualified Data.Text.Lazy.Builder as Builder -import Data.These ( fromThese ) -import qualified Data.Time.Clock.POSIX as Time -import qualified Data.Vector as V -import NeatInterpolation ( text ) -import Nix.Atoms -import Nix.Convert -import Nix.Effects -import Nix.Effects.Basic ( fetchTarball ) -import Nix.Exec -import Nix.Expr.Types -import Nix.Expr.Types.Annotated -import qualified Nix.Eval as Eval -import Nix.Frames -import Nix.Json -import Nix.Normal -import Nix.Options -import Nix.Parser -import Nix.Render -import Nix.Scope -import Nix.String -import Nix.String.Coerce -import Nix.Value -import Nix.Value.Equal -import Nix.Value.Monad -import Nix.XML -import System.Nix.Base32 as Base32 -import System.FilePath -import System.Posix.Files ( isRegularFile - , isDirectory - , isSymbolicLink - ) -import Text.Regex.TDFA ( Regex - , makeRegex - , matchOnceText - , 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...@. - --- * Internal - --- ** Nix Builtins Haskell type level - -newtype Prim m a = Prim { runPrim :: m a } - -data BuiltinType = Normal | TopLevel -data Builtin v = - Builtin - { _kind :: BuiltinType - , mapping :: (Text, v) - } - --- *** @class ToBuiltin@ and its instances - --- | Types that support conversion to nix in a particular monad -class ToBuiltin t f m a | a -> m where - toBuiltin :: Text -> a -> m (NValue t f m) - -instance - ( MonadNix e t f m - , ToValue a m (NValue t f m) - ) - => ToBuiltin t f m (Prim m a) where - toBuiltin _ p = toValue =<< runPrim p - -instance - ( MonadNix e t f m - , FromValue a m (Deeper (NValue t f m)) - , ToBuiltin t f m b - ) - => ToBuiltin t f m (a -> b) where - toBuiltin name f = - pure $ nvBuiltin name $ toBuiltin name . f <=< fromValue . Deeper - --- *** @WValue@ closure wrapper to have @Ord@ - --- We wrap values solely to provide an Ord instance for genericClosure -newtype WValue t f m = WValue (NValue t f m) - -instance Comonad f => Eq (WValue t f m) where - WValue (NVConstant (NFloat x)) == WValue (NVConstant (NInt y)) = - x == fromInteger y - WValue (NVConstant (NInt x)) == WValue (NVConstant (NFloat y)) = - fromInteger x == y - WValue (NVConstant (NInt x)) == WValue (NVConstant (NInt y)) = x == y - 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 - _ == _ = False - -instance Comonad f => Ord (WValue t f m) where - WValue (NVConstant (NFloat x)) <= WValue (NVConstant (NInt y)) = - x <= fromInteger y - WValue (NVConstant (NInt x)) <= WValue (NVConstant (NFloat y)) = - fromInteger x <= y - WValue (NVConstant (NInt x)) <= WValue (NVConstant (NInt y)) = x <= y - 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 - _ <= _ = 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 - -foldNixPath - :: forall e t f m r - . MonadNix e t f m - => r - -> (FilePath -> Maybe Text -> NixPathEntryType -> r -> m r) - -> m r -foldNixPath z f = - do - mres <- lookupVar "__includes" - dirs <- - maybe - stub - ((fromValue . Deeper) <=< demand) - mres - mPath <- getEnvVar "NIX_PATH" - mDataDir <- getEnvVar "NIX_DATA_DIR" - dataDir <- - maybe - getDataDir - (pure . toString) - mDataDir - - foldrM - go - z - $ (fromInclude . stringIgnoreContext <$> dirs) - <> maybe - mempty - uriAwareSplit - mPath - <> [ fromInclude $ "nix=" <> toText dataDir <> "/nix/corepkgs" ] - where - - fromInclude x = (x, ) $ - bool - PathEntryPath - PathEntryURI - ("://" `Text.isInfixOf` x) - - go (x, ty) rest = - case Text.splitOn "=" x of - [p] -> f (toString p) mempty ty rest - [n, p] -> f (toString p) (pure n) ty rest - _ -> throwError $ ErrorCall $ "Unexpected entry in NIX_PATH: " <> show x - -attrsetGet :: MonadNix e t f m => Text -> AttrSet (NValue t f m) -> m (NValue t f m) -attrsetGet k s = - maybe - (throwError $ ErrorCall $ "Attribute '" <> toString k <> "' required") - pure - (M.lookup k s) - -data VersionComponent - = VersionComponentPre -- ^ The string "pre" - | VersionComponentString !Text -- ^ A string other than "pre" - | VersionComponentNumber !Integer -- ^ A number - deriving (Show, Read, Eq, Ord) - -versionComponentToString :: VersionComponent -> Text -versionComponentToString = - \case - VersionComponentPre -> "pre" - VersionComponentString s -> s - VersionComponentNumber n -> show n - --- | Based on https://github.com/NixOS/nix/blob/4ee4fda521137fed6af0446948b3877e0c5db803/src/libexpr/names.cc#L44 -versionComponentSeparators :: String -versionComponentSeparators = ".-" - -splitVersion :: Text -> [VersionComponent] -splitVersion s = - case Text.uncons s of - Nothing -> mempty - Just (h, t) - - | h `elem` versionComponentSeparators -> splitVersion t - - | isDigit h -> - let (digits, rest) = Text.span isDigit s - in - VersionComponentNumber - (fromMaybe (error $ "splitVersion: couldn't parse " <> show digits) $ readMaybe $ toString digits) : splitVersion rest - - | otherwise -> - let - (chars, rest) = - Text.span - (\c -> not $ isDigit c || c `elem` versionComponentSeparators) - s - thisComponent = - case chars of - "pre" -> VersionComponentPre - x -> VersionComponentString x - in - thisComponent : splitVersion rest - -compareVersions :: Text -> Text -> Ordering -compareVersions s1 s2 = - mconcat $ - alignWith - f - (splitVersion s1) - (splitVersion s2) - where - z = VersionComponentString "" - f = uncurry compare . fromThese z z - -splitDrvName :: Text -> (Text, Text) -splitDrvName s = - let - sep = "-" - pieces = Text.splitOn sep s - isFirstVersionPiece p = - case Text.uncons p of - Just (h, _) -> isDigit h - _ -> False - -- Like 'break', but always puts the first item into the first result - -- list - breakAfterFirstItem :: (a -> Bool) -> [a] -> ([a], [a]) - breakAfterFirstItem f = - list - (mempty, mempty) - (\ (h : t) -> let (a, b) = break f t in (h : a, b)) - (namePieces, versionPieces) = - breakAfterFirstItem isFirstVersionPiece pieces - in - (Text.intercalate sep namePieces, Text.intercalate sep versionPieces) - -splitMatches - :: forall e t f m - . MonadNix e t f m - => Int - -> [[(ByteString, (Int, Int))]] - -> ByteString - -> [NValue t f m] -splitMatches _ [] haystack = [thunkStr haystack] -splitMatches _ ([] : _) _ = - fail "Fail in splitMatches: this should never happen!" -splitMatches numDropped (((_, (start, len)) : captures) : mts) haystack = - thunkStr before : caps : splitMatches (numDropped + relStart + len) - mts - (B.drop len rest) - where - relStart = max 0 start - numDropped - (before, rest) = B.splitAt relStart haystack - caps = nvList (f <$> captures) - f (a, (s, _)) = - bool - nvNull - (thunkStr a) - (s >= 0) - -thunkStr :: Applicative f => ByteString -> NValue t f m -thunkStr s = nvStrWithoutContext $ decodeUtf8 s - -hasKind - :: forall a e t f m - . (MonadNix e t f m, FromValue a m (NValue t f m)) - => NValue t f m - -> m (NValue t f m) -hasKind nv = - do - v <- fromValueMay nv - - toValue $ - case v of - Just (_ :: a) -> True - _ -> False - - -absolutePathFromValue :: MonadNix e t f m => NValue t f m -> m FilePath -absolutePathFromValue = - \case - NVStr ns -> - do - let - path = toString $ stringIgnoreContext ns - - unless (isAbsolute path) $ throwError $ ErrorCall $ "string " <> show path <> " doesn't represent an absolute path" - pure path - - NVPath path -> pure path - v -> throwError $ ErrorCall $ "expected a path, got " <> show v - - -data FileType - = FileTypeRegular - | FileTypeDirectory - | FileTypeSymlink - | FileTypeUnknown - deriving (Show, Read, Eq, Ord) - -instance Convertible e t f m => ToValue FileType m (NValue t f m) where - toValue = - toValue . makeNixStringWithoutContext . - \case - FileTypeRegular -> "regular" :: Text - FileTypeDirectory -> "directory" - FileTypeSymlink -> "symlink" - FileTypeUnknown -> "unknown" - --- ** Builtin functions - -derivationNix - :: forall e t f m. (MonadNix e t f m, Scoped (NValue t f m) m) - => m (NValue t f m) -derivationNix = foldFix Eval.eval $$(do - -- This is compiled in so that we only parse it once at compile-time. - let Right expr = parseNixText [text| - 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|] - [|| expr ||] - ) - -nixPathNix :: MonadNix e t f m => m (NValue t f m) -nixPathNix = - fmap - nvList - (foldNixPath mempty $ - \p mn ty rest -> - pure $ - pure - (nvSet - mempty - (M.fromList - [case ty of - PathEntryPath -> ("path", nvPath p) - PathEntryURI -> ( "uri", mkNvStr p) - - , ( "prefix", mkNvStr $ toString $ fromMaybe "" mn) - ] - ) - ) - <> rest - ) - where - mkNvStr = nvStrWithoutContext . toText - -toStringNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -toStringNix = toValue <=< coerceToString callFunc DontCopyToStore CoerceAny - -hasAttrNix - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -hasAttrNix x y = - do - key <- fromStringNoContext =<< fromValue x - (aset, _) <- fromValue @(AttrSet (NValue t f m), AttrSet SourcePos) y - - toValue $ M.member key aset - -hasContextNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -hasContextNix = toValue . stringHasContext <=< fromValue - -getAttrNix - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -getAttrNix x y = - do - key <- fromStringNoContext =<< fromValue x - (aset, _) <- fromValue @(AttrSet (NValue t f m), AttrSet SourcePos) y - - attrsetGet key aset - -unsafeGetAttrPosNix - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -unsafeGetAttrPosNix nvX nvY = - do - x <- demand nvX - y <- demand nvY - - case (x, y) of - (NVStr ns, NVSet _ apos) -> - maybe - (pure nvNull) - toValue - (M.lookup (stringIgnoreContext 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 --- of the list. -lengthNix - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -lengthNix = toValue . (length :: [NValue t f m] -> Int) <=< fromValue - -addNix - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -addNix nvX nvY = - do - x' <- demand nvX - y' <- demand nvY - - case (x', y') of - (NVConstant (NInt x), NVConstant (NInt y)) -> toValue ( x + y :: Integer ) - (NVConstant (NFloat x), NVConstant (NInt y)) -> toValue $ x + fromInteger y - (NVConstant (NInt x), NVConstant (NFloat y)) -> toValue $ fromInteger x + y - (NVConstant (NFloat x), NVConstant (NFloat y)) -> toValue $ x + y - (_x , _y ) -> throwError $ Addition _x _y - -mulNix - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -mulNix nvX nvY = - do - x' <- demand nvX - y' <- demand nvY - - case (x', y') of - (NVConstant (NInt x), NVConstant (NInt y)) -> toValue (x * y :: Integer ) - (NVConstant (NFloat x), NVConstant (NInt y)) -> toValue (x * fromInteger y) - (NVConstant (NInt x), NVConstant (NFloat y)) -> toValue (fromInteger x * y) - (NVConstant (NFloat x), NVConstant (NFloat y)) -> toValue (x * y ) - (_x , _y ) -> throwError $ Multiplication _x _y - -divNix - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -divNix nvX nvY = - do - x' <- demand nvX - y' <- demand nvY - case (x', y') of - (NVConstant (NInt x), NVConstant (NInt y)) | y /= 0 -> toValue ( floor (fromInteger x / fromInteger y :: Double) :: Integer) - (NVConstant (NFloat x), NVConstant (NInt y)) | y /= 0 -> toValue $ x / fromInteger y - (NVConstant (NInt x), NVConstant (NFloat y)) | y /= 0 -> toValue $ fromInteger x / y - (NVConstant (NFloat x), NVConstant (NFloat y)) | y /= 0 -> toValue $ x / y - (_x , _y ) -> throwError $ Division _x _y - -anyNix - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -anyNix f = toValue <=< anyMNix fromValue <=< traverse (callFunc f) <=< fromValue - where - anyMNix :: Monad m => (a -> m Bool) -> [a] -> m Bool - anyMNix _ [] = pure False - anyMNix p (x : xs) = - bool - (anyMNix p xs) - (pure True) - =<< p x - -allNix - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -allNix f = toValue <=< allMNix fromValue <=< traverse (callFunc f) <=< fromValue - where - allMNix :: Monad m => (a -> m Bool) -> [a] -> m Bool - allMNix _ [] = pure True - allMNix p (x : xs) = - bool - (pure False) - (allMNix p xs) - =<< p x - -foldl'Nix - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> NValue t f m - -> m (NValue t f m) -foldl'Nix f z xs = foldM go z =<< fromValue @[NValue t f m] xs - where - go b a = (`callFunc` a) =<< callFunc f b - -headNix :: forall e t f m. MonadNix e t f m => NValue t f m -> m (NValue t f m) -headNix = - maybe - (throwError $ ErrorCall "builtins.head: empty list") - (pure) - . viaNonEmpty head <=< fromValue @[NValue t f m] - -tailNix :: forall e t f m. MonadNix e t f m => NValue t f m -> m (NValue t f m) -tailNix = - maybe - (throwError $ ErrorCall "builtins.tail: empty list") - (pure . nvList) - . viaNonEmpty tail <=< fromValue @[NValue t f m] - -splitVersionNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -splitVersionNix v = - do - version <- fromStringNoContext =<< fromValue v - pure $ - nvList $ - nvStrWithoutContext . versionComponentToString <$> - splitVersion version - -compareVersionsNix - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -compareVersionsNix t1 t2 = - do - s1 <- mkText t1 - s2 <- mkText t2 - - let - cmpVers = - case compareVersions s1 s2 of - LT -> -1 - EQ -> 0 - GT -> 1 - - pure $ nvConstant $ NInt cmpVers - - where - mkText = fromStringNoContext <=< fromValue - -parseDrvNameNix - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -parseDrvNameNix drvname = - do - s <- fromStringNoContext =<< fromValue drvname - - let - (name :: Text, version :: Text) = splitDrvName s - - toValue @(AttrSet (NValue t f m)) $ - M.fromList - [ ( "name" :: Text - , mkNVStr name - ) - , ( "version" - , mkNVStr version - ) - ] - - where - mkNVStr = nvStrWithoutContext - -matchNix - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -matchNix pat str = - do - p <- fromStringNoContext =<< fromValue pat - ns <- fromValue str - - -- NOTE: 2018-11-19: Currently prim_match in nix/src/libexpr/primops.cc - -- ignores the context of its second argument. This is probably a bug but we're - -- going to preserve the behavior here until it is fixed upstream. - -- Relevant issue: https://github.com/NixOS/nix/issues/2547 - let - s = stringIgnoreContext ns - re = makeRegex p :: Regex - mkMatch t = - bool - (toValue ()) -- Shorthand for Null - (toValue $ makeNixStringWithoutContext t) - (not $ Text.null t) - - case matchOnceText re s of - Just ("", sarr, "") -> - do - let submatches = fst <$> elems sarr - nvList <$> - traverse - mkMatch - (case submatches of - [] -> [] - [a] -> [a] - _:xs -> xs -- return only the matched groups, drop the full string - ) - _ -> pure nvNull - -splitNix - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -splitNix pat str = - do - p <- fromStringNoContext =<< fromValue pat - ns <- fromValue str - -- NOTE: Currently prim_split in nix/src/libexpr/primops.cc ignores the - -- context of its second argument. This is probably a bug but we're - -- going to preserve the behavior here until it is fixed upstream. - -- Relevant issue: https://github.com/NixOS/nix/issues/2547 - let - s = stringIgnoreContext ns - regex = makeRegex p :: Regex - haystack = encodeUtf8 s - - pure $ nvList $ 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 = - Prim $ - bool - (throwError $ ErrorCall $ "builtins.substring: negative start position: " <> show start) - (pure $ modifyNixContents (take . Text.drop start) str) - (start >= 0) - where - take = - bool - id --NOTE: negative values of 'len' are OK, and mean "take everything" - (Text.take len) - (len >= 0) - -attrNamesNix - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -attrNamesNix = - (fmap (coerce :: CoerceDeeperToNValue t f m) . toValue . fmap makeNixStringWithoutContext . sort . M.keys) - <=< fromValue @(AttrSet (NValue t f m)) - -attrValuesNix - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -attrValuesNix nvattrs = - do - attrs <- fromValue @(AttrSet (NValue t f m)) nvattrs - toValue $ - snd <$> - sortOn - (fst @Text @(NValue t f m)) - (M.toList attrs) - -mapNix - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -mapNix f = - toValue <=< - traverse - (defer @(NValue t f m) - . withFrame Debug (ErrorCall "While applying f in map:\n") - . callFunc f - ) - <=< fromValue @[NValue t f m] - -mapAttrsNix - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -mapAttrsNix f xs = - do - nixAttrset <- fromValue @(AttrSet (NValue t f m)) xs - let - keyVals = M.toList nixAttrset - keys = fst <$> keyVals - - applyFunToKeyVal (key, val) = - do - runFunForKey <- callFunc f $ nvStrWithoutContext key - callFunc runFunForKey val - - newVals <- - traverse - (defer @(NValue t f m) . withFrame Debug (ErrorCall "While applying f in mapAttrs:\n") . applyFunToKeyVal) - keyVals - - toValue $ M.fromList $ zip keys newVals - -filterNix - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -filterNix f = - toValue <=< - filterM - (fromValue <=< callFunc f) - <=< fromValue - -catAttrsNix - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -catAttrsNix attrName xs = - do - n <- fromStringNoContext =<< fromValue attrName - l <- fromValue @[NValue t f m] xs - - nvList . catMaybes <$> - traverse - (fmap (M.lookup n) . fromValue <=< demand) - l - -baseNameOfNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -baseNameOfNix x = - do - ns <- coerceToString callFunc DontCopyToStore CoerceStringy x - pure $ - nvStr $ - modifyNixContents - (toText . takeFileName . toString) - ns - -bitAndNix - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -bitAndNix x y = - do - a <- fromValue @Integer x - b <- fromValue @Integer y - - toValue (a .&. b) - -bitOrNix - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -bitOrNix x y = - do - a <- fromValue @Integer x - b <- fromValue @Integer y - - toValue (a .|. b) - -bitXorNix - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -bitXorNix x y = - do - a <- fromValue @Integer x - b <- fromValue @Integer y - - toValue (a `xor` b) - -builtinsBuiltinNix - :: forall e t f m - . MonadNix e t f m - => m (NValue t f m) -builtinsBuiltinNix = throwError $ ErrorCall "HNix does not provide builtins.builtins at the moment. Using builtins directly should be preferred" - -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 (toText . takeDirectory . toString) ns - NVPath path -> pure $ nvPath $ 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 mnv = do - ns <- fromValue mnv - toValue $ makeNixStringWithoutContext $ stringIgnoreContext ns - --- | Evaluate `a` to WHNF to collect its topmost effect. -seqNix - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -seqNix a b = b <$ demand a - --- | Evaluate 'a' to NF to collect all of its effects, therefore data cycles are ignored. -deepSeqNix - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -deepSeqNix a b = b <$ normalForm_ a - -elemNix - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -elemNix x = toValue <=< anyMNix (valueEqM x) <=< fromValue - where - anyMNix :: Monad m => (a -> m Bool) -> [a] -> m Bool - anyMNix _ [] = pure False - anyMNix p (x : xs) = - bool - (anyMNix p xs) - (pure True) - =<< p x - -elemAtNix - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -elemAtNix xs n = - do - n' <- fromValue n - xs' <- fromValue xs - maybe - (throwError $ ErrorCall $ "builtins.elem: Index " <> show n' <> " too large for list of length " <> show (length xs')) - pure - (xs' !!? n') - -genListNix - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -genListNix f nixN = - do - n <- fromValue @Integer nixN - bool - (throwError $ ErrorCall $ "builtins.genList: Expected a non-negative number, got " <> show n) - (toValue =<< traverse (defer . callFunc f <=< toValue) [0 .. n - 1]) - (n >= 0) - -genericClosureNix - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -genericClosureNix c = - do - s <- fromValue @(AttrSet (NValue t f m)) c - - case (M.lookup "startSet" s, M.lookup "operator" s) of - (Nothing , Nothing ) -> throwError $ ErrorCall "builtins.genericClosure: Attributes 'startSet' and 'operator' required" - (Nothing , Just _ ) -> throwError $ ErrorCall "builtins.genericClosure: Attribute 'startSet' required" - (Just _ , Nothing ) -> throwError $ ErrorCall "builtins.genericClosure: Attribute 'operator' required" - (Just startSet, Just operator) -> - do - ss <- fromValue @[NValue t f m] =<< demand startSet - op <- demand operator - - toValue @[NValue t f m] =<< snd <$> go op mempty ss - where - go - :: NValue t f m - -> Set (WValue t f m) - -> [NValue t f m] - -> m (Set (WValue t f m), [NValue t f m]) - go _ ks [] = pure (ks, mempty) - go op ks (t : ts) = - do - v <- demand t - k <- demand =<< attrsetGet "key" =<< fromValue @(AttrSet (NValue t f m)) v - - bool - (do - ys <- fromValue @[NValue t f m] =<< callFunc op v - checkComparable k - (case S.toList ks of - [] -> k - WValue j : _ -> j - ) - (t :) <<$>> go op (S.insert (WValue k) ks) (ts <> ys) - ) - (go op ks ts) - (S.member (WValue k) ks) - --- | Takes: --- 1. List of strings to match. --- 2. List of strings to replace corresponding match occurance. (arg 1 & 2 lists matched by index) --- 3. String to process --- -> returns the string with requested replacements. --- --- Example: --- builtins.replaceStrings ["ll" "e"] [" " "i"] "Hello world" == "Hi o world". -replaceStringsNix - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> NValue t f m - -> m (NValue t f m) -replaceStringsNix tfrom tto ts = - do - -- NixStrings have context - remember - (fromKeys :: [NixString]) <- fromValue (Deeper tfrom) - (toVals :: [NixString]) <- fromValue (Deeper tto) - (string :: NixString ) <- fromValue ts - - when (length fromKeys /= length toVals) $ throwError $ ErrorCall "builtins.replaceStrings: Arguments `from`&`to` construct a key-value map, so the number of their elements must always match." - - let - -- 2021-02-18: NOTE: if there is no match - the process does not changes the context, simply slides along the string. - -- So it isbe more effective to pass the context as the first argument. - -- And moreover, the `passOneCharNgo` passively passes the context, to context can be removed from it and inherited directly. - -- Then the solution would've been elegant, but the Nix bug prevents elegant implementation. - go ctx input output = - maybe - -- Passively pass the chars - passOneChar - replace - maybePrefixMatch - - where - -- When prefix matched something - returns (match, replacement, remainder) - maybePrefixMatch :: Maybe (Text, NixString, Text) - maybePrefixMatch = formMatchReplaceTailInfo <$> find ((`Text.isPrefixOf` input) . fst) fromKeysToValsMap - where - formMatchReplaceTailInfo = (\(m, r) -> (m, r, Text.drop (Text.length m) input)) - - fromKeysToValsMap = zip (stringIgnoreContext <$> fromKeys) toVals - - -- Not passing args => It is constant that gets embedded into `go` => It is simple `go` tail recursion - passOneChar = - maybe - (finish ctx output) -- The base case - there is no chars left to process -> finish - (\(c, i) -> go ctx i (output <> Builder.singleton c)) -- If there are chars - pass one char & continue - (Text.uncons input) -- chip first char - - -- 2021-02-18: NOTE: rly?: toStrict . toLazyText - -- Maybe `text-builder`, `text-show`? - finish ctx output = makeNixString (LazyText.toStrict $ Builder.toLazyText output) ctx - - replace (key, replacementNS, unprocessedInput) = replaceWithNixBug unprocessedInput updatedOutput - - where - replaceWithNixBug = - bool - (go updatedCtx) -- tail recursion - -- Allowing match on "" is a inherited bug of Nix, - -- when "" is checked - it always matches. And so - when it checks - it always insers a replacement, and then process simply passesthrough the char that was under match. - -- - -- repl> builtins.replaceStrings ["" "e"] [" " "i"] "Hello world" - -- " H e l l o w o r l d " - -- repl> builtins.replaceStrings ["ll" ""] [" " "i"] "Hello world" - -- "iHie ioi iwioirilidi" - -- 2021-02-18: NOTE: There is no tests for this - bugPassOneChar -- augmented recursion - isNixBugCase - - isNixBugCase = key == mempty - - updatedOutput = output <> replacement - updatedCtx = ctx <> replacementCtx - - replacement = Builder.fromText $ stringIgnoreContext replacementNS - replacementCtx = getContext replacementNS - - -- The bug modifies the content => bug demands `pass` to be a real function => - -- `go` calls `pass` function && `pass` calls `go` function - -- => mutual recusion case, so placed separately. - bugPassOneChar input output = - maybe - (finish updatedCtx output) -- The base case - there is no chars left to process -> finish - (\(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 - -removeAttrsNix - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -removeAttrsNix set v = - do - (m, p) <- fromValue @(AttrSet (NValue t f m), AttrSet SourcePos) set - (nsToRemove :: [NixString]) <- fromValue $ Deeper v - toRemove <- traverse fromStringNoContext nsToRemove - toValue (go m toRemove, go p toRemove) - where - go = foldl' (flip M.delete) - -intersectAttrsNix - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -intersectAttrsNix set1 set2 = - do - (s1, p1) <- fromValue @(AttrSet (NValue t f m), AttrSet SourcePos) set1 - (s2, p2) <- fromValue @(AttrSet (NValue t f m), AttrSet SourcePos) set2 - - pure $ nvSet (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) -functionArgsNix nvfun = - do - fun <- demand nvfun - case fun of - NVClosure p _ -> - toValue @(AttrSet (NValue t f m)) $ mkNVBool <$> - case p of - Param name -> one (name, False) - ParamSet s _ _ -> isJust <$> M.fromList s - _v -> throwError $ ErrorCall $ "builtins.functionArgs: expected function, got " <> show _v - -toFileNix - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -toFileNix name s = - do - name' <- fromStringNoContext =<< fromValue name - s' <- fromValue s - mres <- - (toFile_ `on` toString) - name' - (stringIgnoreContext s') - - let - t = toText $ unStorePath mres - sc = StringContext t DirectPath - - toValue $ makeNixStringWithSingletonContext t sc - -toPathNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -toPathNix = toValue @Path <=< fromValue @Path - -pathExistsNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -pathExistsNix nvpath = - do - path <- demand nvpath - toValue =<< - case path of - NVPath p -> doesPathExist p - NVStr ns -> doesPathExist $ toString $ stringIgnoreContext ns - _v -> throwError $ ErrorCall $ "builtins.pathExists: expected path, got " <> show _v - -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)) - -isListNix - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -isListNix = hasKind @[NValue t f m] - -isIntNix - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -isIntNix = hasKind @Int - -isFloatNix - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -isFloatNix = hasKind @Float - -isBoolNix - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -isBoolNix = hasKind @Bool - -isNullNix - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -isNullNix = hasKind @() - --- isString cannot use `hasKind` because it coerces derivationNixs to strings. -isStringNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -isStringNix nv = - do - v <- demand nv - - toValue $ - case v of - NVStr{} -> True - _ -> False - -isFunctionNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -isFunctionNix nv = - do - v <- demand nv - - toValue $ - case v of - NVClosure{} -> True - _ -> 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 - --- | Implementation of Nix @import@ clause. --- --- Because Nix @import@s work strictly --- (import gets fully evaluated befor bringing it into the scope it was called from) --- - that property raises a requirement for execution phase of the interpreter go into evaluation phase --- & then also go into parsing phase on the imports. --- So it is not possible (more precise - not practical) to do a full parse Nix code phase fully & then go into evaluation phase. --- As it is not possible to "import them lazily", as import is strict & it is not possible to establish --- what imports whould be needed up until where it would be determined & they import strictly --- -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 - --- | @scopedImport scope path@ --- An undocumented secret powerful function. --- --- At the same time it is strongly forbidden to be used, as prolonged use of it would bring devastating consequences. --- As it is essentially allows rewriting(redefinition) paradigm. --- --- Allows to import the environment into the scope of a file expression that gets imported. --- It is as if the contents at @path@ were given to @import@ wrapped as: @with scope; path@ --- meaning: --- --- > -- Nix pseudocode: --- > import (with scope; path) --- --- For example, it allows to use itself as: --- > bar = scopedImport pkgs ./bar.nix; --- > -- & declare @./bar.nix@ without a header, so as: --- > stdenv.mkDerivation { ... buildInputs = [ libfoo ]; } --- --- But that breaks the evaluation/execution sharing of the @import@s. --- --- Function also allows to redefine or extend the builtins. --- --- For instance, to trace all calls to function ‘map’: --- --- > let --- > overrides = { --- > map = f: xs: builtins.trace "call of map!" (map f xs); --- --- > # Propagate override by calls to import&scopedImport. --- > import = fn: scopedImport overrides fn; --- > scopedImport = attrs: fn: scopedImport (overrides // attrs) fn; --- --- > # Update ‘builtins’. --- > builtins = builtins // overrides; --- > }; --- > in scopedImport overrides ./bla.nix --- --- In the related matter the function can be added and passed around as builtin. -scopedImportNix - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -scopedImportNix asetArg pathArg = - do - s <- fromValue @(AttrSet (NValue t f m)) asetArg - (Path p) <- fromValue pathArg - - path <- pathToDefaultNix @t @f @m p - path' <- - maybe - (do - traceM "No known current directory" - pure path - ) - (\ res -> - do - (Path p') <- fromValue =<< demand res - - traceM $ "Current file being evaluated is: " <> show p' - pure $ takeDirectory p' path - ) - =<< lookupVar "__cur_file" - - clearScopes @(NValue t f m) - $ withNixContext (pure path') - $ pushScope s - $ importPath @t @f @m path' - -getEnvNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -getEnvNix v = - do - s <- fromStringNoContext =<< fromValue v - mres <- getEnvVar s - - toValue $ makeNixStringWithoutContext $ - fromMaybe mempty mres - -sortNix - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -sortNix comp = toValue <=< sortByM (cmp comp) <=< fromValue - where - cmp f a b = - do - isLessThan <- (`callFunc` b) =<< callFunc f a - bool - (do - isGreaterThan <- (`callFunc` a) =<< callFunc f b - fromValue isGreaterThan <&> - bool EQ GT - ) - (pure LT) - =<< fromValue isLessThan - -lessThanNix - :: MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -lessThanNix ta tb = - do - va <- demand ta - vb <- demand tb - - let - badType = throwError $ ErrorCall $ "builtins.lessThan: expected two numbers or two strings, got '" <> show va <> "' and '" <> show vb <> "'." - - mkNVBool <$> - case (va, vb) of - (NVConstant ca, NVConstant cb) -> - case (ca, cb) of - (NInt a, NInt b) -> pure $ a < b - (NInt a, NFloat b) -> pure $ fromInteger a < b - (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 - _ -> badType - --- | Helper function, generalization of @concat@ operations. -concatWith - :: forall e t f m - . MonadNix e t f m - => (NValue t f m -> m (NValue t f m)) - -> NValue t f m - -> m (NValue t f m) -concatWith f = - toValue . concat <=< - traverse - (fromValue @[NValue t f m] <=< f) - <=< fromValue @[NValue t f m] - --- | Nix function of Haskell: --- > concat :: [[a]] -> [a] --- --- Concatenate a list of lists into a single list. -concatListsNix - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -concatListsNix = concatWith demand - --- | Nix function of Haskell: --- > concatMap :: Foldable t => (a -> [b]) -> t a -> [b] -concatMapNix - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -concatMapNix f = concatWith (callFunc f) - -listToAttrsNix - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -listToAttrsNix lst = - do - l <- fromValue @[NValue t f m] lst - fmap - (nvSet mempty . M.fromList . reverse) - (traverse - (\ nvattrset -> - do - a <- fromValue @(AttrSet (NValue t f m)) =<< demand nvattrset - name <- fromStringNoContext =<< fromValue =<< demand =<< attrsetGet "name" a - val <- attrsetGet "value" a - - pure (name, val) - ) - l - ) - --- prim_hashString from nix/src/libexpr/primops.cc --- fail if context in the algo arg --- propagate context from the s arg --- | The result coming out of hashString is base16 encoded -hashStringNix - :: forall e t f m. MonadNix e t f m => NixString -> NixString -> Prim m NixString -hashStringNix nsAlgo ns = - Prim $ - do - algo <- fromStringNoContext nsAlgo - let - f g = pure $ modifyNixContents g ns - - case algo of - -- 2021-03-04: Pattern can not be taken-out because hashes represented as different types - "md5" -> f (show . mkHash @MD5.MD5) - "sha1" -> f (show . mkHash @SHA1.SHA1) - "sha256" -> f (show . mkHash @SHA256.SHA256) - "sha512" -> f (show . mkHash @SHA512.SHA512) - - _ -> throwError $ ErrorCall $ "builtins.hashString: expected \"md5\", \"sha1\", \"sha256\", or \"sha512\", got " <> show algo - - where - -- This intermidiary `a` is only needed because of the type application - mkHash :: (Show a, HashAlgorithm a) => Text -> a - mkHash s = hash $ encodeUtf8 s - - -placeHolderNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -placeHolderNix p = - do - t <- fromStringNoContext =<< fromValue p - h <- - runPrim $ - (hashStringNix `on` makeNixStringWithoutContext) - "sha256" - ("nix-output:" <> t) - toValue - $ makeNixStringWithoutContext - $ Text.cons '/' - $ Base32.encode - -- Please, stop Text -> Bytestring here after migration to Text - $ case Base16.decode (bytes h) of -- The result coming out of hashString is base16 encoded -#if MIN_VERSION_base16_bytestring(1,0,0) - -- Please, stop Text -> String here after migration to Text - Left e -> error $ "Couldn't Base16 decode the text: '" <> body h <> "'.\nThe Left fail content: '" <> show e <> "'." - Right d -> d -#else - (d, "") -> d - (_, e) -> error $ "Couldn't Base16 decode the text: '" <> body h <> "'.\nUndecodable remainder: '" <> show e <> "'." -#endif - where - bytes :: NixString -> ByteString - bytes = encodeUtf8 . body - - body h = stringIgnoreContext h - -readFileNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -readFileNix = toValue <=< Nix.Render.readFile <=< absolutePathFromValue <=< demand - -findFileNix - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -findFileNix nvaset nvfilepath = - do - aset <- demand nvaset - filePath <- demand nvfilepath - - case (aset, filePath) of - (NVList x, NVStr ns) -> - do - mres <- findPath @t @f @m x $ toString $ stringIgnoreContext ns - - pure $ nvPath mres - - (NVList _, _y ) -> throwError $ ErrorCall $ "expected a string, got " <> show _y - (_x , NVStr _) -> throwError $ ErrorCall $ "expected a list, got " <> show _x - (_x , _y ) -> throwError $ ErrorCall $ "Invalid types for builtins.findFile: " <> show (_x, _y) - -readDirNix - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -readDirNix nvpath = - do - path <- absolutePathFromValue =<< demand nvpath - items <- listDirectory path - - let - detectFileTypes item = - do - s <- getSymbolicLinkStatus $ path item - let - t = - if - | isRegularFile s -> FileTypeRegular - | isDirectory s -> FileTypeDirectory - | isSymbolicLink s -> FileTypeSymlink - | otherwise -> FileTypeUnknown - - pure (toText item, t) - - itemsWithTypes <- - traverse - detectFileTypes - items - - (coerce :: CoerceDeeperToNValue t f m) <$> toValue (M.fromList itemsWithTypes) - -fromJSONNix - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -fromJSONNix nvjson = - do - j <- demand nvjson - jText <- fromStringNoContext =<< fromValue j - - either - (\ jsonError -> throwError $ ErrorCall $ "builtins.fromJSON: " <> jsonError) - jsonToNValue - -- do we really need to marshall Text -> ByteString -> Aeson.Value (that is a Text) - (A.eitherDecodeStrict' @A.Value $ encodeUtf8 jText) - - where - jsonToNValue :: (A.Value -> m (NValue t f m)) - jsonToNValue = - \case - A.Object m -> - traverseToNValue - (nvSet 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.Number n -> - pure $ - nvConstant $ - either - NFloat - NInt - (floatingOrInteger n) - A.Bool b -> pure $ mkNVBool b - A.Null -> pure nvNull - where - traverseToNValue :: Traversable t0 => (t0 (NValue t f m) -> b) -> t0 A.Value -> m b - 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 - -toXMLNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -toXMLNix = (fmap (nvStr . toXML) . normalForm) <=< demand - -typeOfNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -typeOfNix nvv = - do - v <- demand nvv - let - detectType = - case v of - NVConstant a -> - case a of - NURI _ -> "string" - NInt _ -> "int" - NFloat _ -> "float" - NBool _ -> "bool" - NNull -> "null" - NVStr _ -> "string" - NVList _ -> "list" - NVSet _ _ -> "set" - NVClosure{} -> "lambda" - NVPath _ -> "path" - NVBuiltin _ _ -> "lambda" - _ -> error "Pattern synonyms obscure complete patterns" - - toValue $ makeNixStringWithoutContext detectType - -tryEvalNix - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -tryEvalNix e = (`catch` (pure . onError)) - (onSuccess <$> demand e) - where - onSuccess v = - nvSet - mempty - $ M.fromList - [ ("success", mkNVBool True) - , ("value" , v ) - ] - - onError :: SomeException -> NValue t f m - onError _ = - nvSet - mempty - $ M.fromList - $ (, mkNVBool False) <$> - [ "success" - , "value" - ] - -traceNix - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -traceNix msg action = - do - traceEffect @t @f @m . toString . stringIgnoreContext =<< fromValue msg - pure action - --- Please, can function remember fail context -addErrorContextNix - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m -- action - -> m (NValue t f m) -addErrorContextNix _ = pure - -execNix - :: 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 - -- 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 - -fetchurlNix - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -fetchurlNix = - (\case - NVSet s _ -> go (M.lookup "sha256" s) =<< demand =<< attrsetGet "url" s - v@NVStr{} -> go Nothing v - v -> throwError $ ErrorCall $ "builtins.fetchurl: Expected URI or set, got " <> show v - ) <=< demand - - where - go :: Maybe (NValue t f m) -> NValue t f m -> m (NValue t f m) - go _msha = - \case - NVStr ns -> - either -- msha - throwError - toValue - =<< getURL =<< noContextAttrs ns - - v -> throwError $ ErrorCall $ "builtins.fetchurl: Expected URI or string, got " <> show v - - noContextAttrs ns = - maybe - (throwError $ ErrorCall "builtins.fetchurl: unsupported arguments to url") - pure - (getStringNoContext ns) - -partitionNix - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -partitionNix f nvlst = - do - l <- fromValue @[NValue t f m] nvlst - let - match t = (, t) <$> (fromValue =<< callFunc f t) - selection <- traverse match l - - let - (right, wrong) = partition fst selection - makeSide = nvList . fmap snd - - toValue @(AttrSet (NValue t f m)) - $ M.fromList - [ ("right", makeSide right) - , ("wrong", makeSide wrong) - ] - -currentSystemNix :: MonadNix e t f m => m (NValue t f m) -currentSystemNix = - do - os <- getCurrentSystemOS - arch <- getCurrentSystemArch - - pure $ nvStrWithoutContext $ 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 - -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 - -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) <- sequenceA $ toValue <$> context - pure $ nvSet mempty valued - x -> throwError $ ErrorCall $ "Invalid type for builtins.getContext: " <> show x - -appendContextNix - :: forall e t f m - . MonadNix e t f m - => NValue t f m - -> NValue t f m - -> m (NValue t f m) -appendContextNix tx ty = - do - x <- demand tx - y <- demand ty - - case (x, y) of - (NVStr ns, NVSet attrs _) -> - do - newContextValues <- traverse getPathNOuts attrs - - toValue $ addContext ns newContextValues - - _xy -> throwError $ ErrorCall $ "Invalid types for builtins.appendContext: " <> show _xy - - where - getPathNOuts tx = - do - x <- demand tx - - case x of - NVSet attrs _ -> - do - -- TODO: Fail for unexpected keys. - - let - getK k = - maybe - (pure False) - (fromValue <=< demand) - (M.lookup k attrs) - - getOutputs = - maybe - stub - (\ touts -> - do - outs <- demand touts - - 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) - - path <- getK "path" - allOutputs <- getK "allOutputs" - - NixLikeContextValue path allOutputs <$> getOutputs - - _x -> throwError $ ErrorCall $ "Invalid types for context value in builtins.appendContext: " <> show _x - - addContext ns newContextValues = - makeNixString - (stringIgnoreContext ns) - (fromNixLikeContext $ - NixLikeContext $ - M.unionWith - (<>) - newContextValues - (getNixLikeContext $ - toNixLikeContext $ - getContext ns - ) - ) - - --- ** @builtinsList@ - -builtinsList :: forall e t f m . MonadNix e t f m => m [Builtin (NValue t f m)] -builtinsList = sequence - [ do - version <- toValue (makeNixStringWithoutContext "2.3") - pure $ Builtin Normal ("nixVersion", version) - , do - version <- toValue (5 :: Int) - pure $ Builtin Normal ("langVersion", version) - - , 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 - ] - where - arity1 :: (a -> b) -> (a -> Prim m b) - arity1 f = Prim . pure . f - - arity2 :: (a -> b -> c) -> (a -> b -> Prim m c) - arity2 f = ((Prim . pure) .) . f - - mkBuiltin :: BuiltinType -> Text -> m (NValue t f m) -> m (Builtin (NValue t f m)) - mkBuiltin t n v = wrap t n <$> mkThunk n v - where - wrap :: BuiltinType -> Text -> v -> Builtin v - wrap t n f = Builtin t (n, f) - - mkThunk :: Text -> m (NValue t f m) -> m (NValue t f m) - mkThunk n = defer . withFrame Info (ErrorCall $ "While calling builtin " <> toString n <> "\n") - - hAdd - :: ( Text - -> fun - -> m (NValue t f m) - ) - -> BuiltinType - -> Text - -> fun - -> m (Builtin (NValue t f m)) - hAdd f t n v = mkBuiltin t n $ f n v - - add0 - :: BuiltinType - -> Text - -> m (NValue t f m) - -> m (Builtin (NValue t f m)) - add0 = hAdd (\ _ x -> x) - - add - :: BuiltinType - -> Text - -> ( NValue t f m - -> m (NValue t f m) - ) - -> m (Builtin (NValue t f m)) - add = hAdd builtin - - add2 - :: BuiltinType - -> Text - -> ( NValue t f m - -> NValue t f m - -> m (NValue t f m) - ) - -> m (Builtin (NValue t f m)) - add2 = hAdd builtin2 - - add3 - :: BuiltinType - -> Text - -> ( NValue t f m - -> NValue t f m - -> NValue t f m - -> m (NValue t f m) - ) - -> m (Builtin (NValue t f m)) - add3 = hAdd builtin3 - - add' - :: ToBuiltin t f m a - => BuiltinType - -> Text - -> a - -> m (Builtin (NValue t f m)) - add' = hAdd toBuiltin - - --- * Exported - --- | Evaluate expression in the default context. -withNixContext - :: forall e t f m r - . (MonadNix e t f m, Has e Options) - => Maybe FilePath - -> m r - -> m r -withNixContext mpath action = - do - base <- builtins - opts :: Options <- asks $ view hasLens - let - i = nvList $ nvStrWithoutContext . toText <$> include opts - - pushScope - (one ("__includes", i)) - (pushScopes - base $ - maybe - id - (\ path act -> - do - traceM $ "Setting __cur_file = " <> show path - let ref = nvPath path - pushScope (one ("__cur_file", ref)) act - ) - mpath - action - ) - -builtins - :: ( MonadNix e t f m - , Scoped (NValue t f m) m - ) - => m (Scopes m (NValue t f m)) -builtins = - do - ref <- defer $ nvSet mempty <$> buildMap - lst <- ([("builtins", ref)] <>) <$> topLevelBuiltins - pushScope (M.fromList lst) currentScopes - where - buildMap = fmap (M.fromList . fmap mapping) builtinsList - topLevelBuiltins = mapping <<$>> fullBuiltinsList - - fullBuiltinsList = nameBuiltins <<$>> builtinsList - where - nameBuiltins b@(Builtin TopLevel _) = b - nameBuiltins (Builtin Normal nB) = - Builtin TopLevel $ first ("__" <>) nB +{-# language CPP #-} +{-# language AllowAmbiguousTypes #-} +{-# language ConstraintKinds #-} +{-# language FunctionalDependencies #-} +{-# language KindSignatures #-} +{-# language MonoLocalBinds #-} +{-# language MultiWayIf #-} +{-# language PartialTypeSignatures #-} +{-# language QuasiQuotes #-} +{-# language PatternSynonyms #-} +{-# language TemplateHaskell #-} +{-# language UndecidableInstances #-} +{-# language PackageImports #-} -- 2021-07-05: Due to hashing Haskell IT system situation, in HNix we currently ended-up with 2 hash package dependencies @{hashing, cryptonite}@ + +{-# 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 + , builtins + ) +where + +import Nix.Prelude +import GHC.Exception ( ErrorCall(ErrorCall) ) +import Control.Monad ( foldM ) +import Control.Monad.Catch ( MonadCatch(catch) ) +import Control.Monad.ListM ( sortByM ) +import "hashing" Crypto.Hash +import qualified "hashing" Crypto.Hash.MD5 as MD5 +import qualified "hashing" Crypto.Hash.SHA1 as SHA1 +import qualified "hashing" Crypto.Hash.SHA256 as SHA256 +import qualified "hashing" Crypto.Hash.SHA512 as SHA512 +import qualified Data.Aeson as A +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.Key as AKM +import qualified Data.Aeson.KeyMap as AKM +#endif +import Data.Align ( alignWith ) +import Data.Array +import Data.Bits +import qualified Data.ByteString as B +import Data.ByteString.Base16 as Base16 +import Data.Char ( isDigit ) +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 +import qualified Data.Text as Text +import Data.Text.Read ( decimal ) +import qualified Data.Text.Lazy.Builder as Builder +import Data.These ( fromThese, These ) +import qualified Data.Time.Clock.POSIX as Time +import qualified Data.Vector as V +import NeatInterpolation ( text ) +import Nix.Atoms +import Nix.Convert +import Nix.Effects +import Nix.Effects.Basic ( fetchTarball ) +import Nix.Exec +import Nix.Expr.Types +import qualified Nix.Eval as Eval +import Nix.Frames +import Nix.Json +import Nix.Normal +import Nix.Options +import Nix.Parser +import Nix.Render +import Nix.Scope +import Nix.String +import Nix.String.Coerce +import Nix.Value +import Nix.Value.Equal +import Nix.Value.Monad +import Nix.XML +import System.Nix.Base32 as Base32 +import System.PosixCompat.Files ( isRegularFile + , isDirectory + , isSymbolicLink + ) +import qualified Text.Show +import Text.Regex.TDFA ( Regex + , makeRegex + , matchOnceText + , 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...@. + +-- * Internal + +-- ** Nix Builtins Haskell type level + +newtype Prim m a = Prim (m a) + +data BuiltinType = Normal | TopLevel +data Builtin v = + Builtin + { _kind :: BuiltinType + , mapping :: (VarName, v) + } + +-- *** @class ToBuiltin@ and its instances + +-- | Types that support conversion to nix in a particular monad +class ToBuiltin t f m a | a -> m where + toBuiltin :: Text -> a -> m (NValue t f m) + +instance + ( MonadNix e t f m + , ToValue a m (NValue t f m) + ) + => ToBuiltin t f m (Prim m a) where + toBuiltin _ p = toValue @a @m =<< coerce p + +instance + ( MonadNix e t f m + , FromValue a m (Deeper (NValue t f m)) + , ToBuiltin t f m b + ) + => ToBuiltin t f m (a -> b) where + toBuiltin name f = + pure $ NVBuiltin (coerce name) $ toBuiltin name . f <=< fromValue . Deeper + +-- *** @WValue@ closure wrapper to have @Ord@ + +-- We wrap values solely to provide an Ord instance for genericClosure +newtype WValue t f m = WValue (NValue t f m) + +instance NVConstraint f => Eq (WValue t f m) where + WValue (NVConstant (NFloat x)) == WValue (NVConstant (NInt y)) = + x == fromInteger y + WValue (NVConstant (NInt x)) == WValue (NVConstant (NFloat y)) = + fromInteger x == y + WValue (NVConstant (NInt x)) == WValue (NVConstant (NInt y)) = x == y + WValue (NVConstant (NFloat x)) == WValue (NVConstant (NFloat y)) = x == y + WValue (NVPath x ) == WValue (NVPath y ) = x == y + WValue (NVStr x) == WValue (NVStr y) = + ignoreContext x == ignoreContext y + _ == _ = False + +instance NVConstraint f => Ord (WValue t f m) where + WValue (NVConstant (NFloat x)) <= WValue (NVConstant (NInt y)) = + x <= fromInteger y + WValue (NVConstant (NInt x)) <= WValue (NVConstant (NFloat y)) = + fromInteger x <= y + WValue (NVConstant (NInt x)) <= WValue (NVConstant (NInt y)) = x <= y + WValue (NVConstant (NFloat x)) <= WValue (NVConstant (NFloat y)) = x <= y + WValue (NVPath x ) <= WValue (NVPath y ) = x <= y + WValue (NVStr x) <= WValue (NVStr y) = + ignoreContext x <= ignoreContext y + _ <= _ = False + +-- ** Helpers + +pattern NVBool :: MonadNix e t f m => Bool -> NValue t f m +pattern NVBool a = NVConstant (NBool a) + +data NixPathEntryType + = PathEntryPath + | PathEntryURI + deriving (Show, Eq) + +-- | @NIX_PATH@ is colon-separated, but can also contain URLs, which have a colon +-- (i.e. @https://...@) +uriAwareSplit :: Text -> [(Text, NixPathEntryType)] +uriAwareSplit txt = + case Text.break (== ':') txt of + (e1, e2) + | Text.null e2 -> one (e1, PathEntryPath) + | "://" `Text.isPrefixOf` e2 -> + let ((suffix, _) : path) = uriAwareSplit (Text.drop 3 e2) in + (e1 <> "://" <> suffix, PathEntryURI) : path + | otherwise -> (e1, PathEntryPath) : uriAwareSplit (Text.drop 1 e2) + +foldNixPath + :: forall e t f m r + . MonadNix e t f m + => r + -> (Path -> Maybe Text -> NixPathEntryType -> r -> m r) + -> m r +foldNixPath z f = + do + mres <- lookupVar "__includes" + dirs <- + maybe + stub + ((fromValue . Deeper) <=< demand) + mres + mPath <- getEnvVar "NIX_PATH" + mDataDir <- getEnvVar "NIX_DATA_DIR" + dataDir <- + maybe + getDataDir + (pure . coerce . toString) + mDataDir + + foldrM + fun + z + $ (fromInclude . ignoreContext <$> dirs) + <> uriAwareSplit `whenJust` mPath + <> one (fromInclude $ "nix=" <> fromString (coerce dataDir) <> "/nix/corepkgs") + where + + fromInclude :: Text -> (Text, NixPathEntryType) + fromInclude x = + (x, ) $ + bool + PathEntryPath + PathEntryURI + ("://" `Text.isInfixOf` x) + + 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 + _ -> throwError $ ErrorCall $ "Unexpected entry in NIX_PATH: " <> show x + +attrsetGet :: MonadNix e t f m => VarName -> AttrSet (NValue t f m) -> m (NValue t f m) +attrsetGet k s = + maybe + (throwError $ ErrorCall $ toString @Text $ "Attribute '" <> coerce k <> "' required") + pure + (M.lookup k s) + +data VersionComponent + = VersionComponentPre -- ^ The string "pre" + | VersionComponentString !Text -- ^ A string other than "pre" + | VersionComponentNumber !Integer -- ^ A number + deriving (Read, Eq, Ord) + +instance Show VersionComponent where + show = + \case + VersionComponentPre -> "pre" + VersionComponentString s -> show s + VersionComponentNumber n -> show n + +splitVersion :: Text -> [VersionComponent] +splitVersion s = + (\ (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 + + | 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 + separators = ".-" + + eDigitsPart :: Either String (Integer, Text) + eDigitsPart = decimal @Integer $ s + + (charsSpan, rest2) = + Text.span + (\c -> not $ isDigit c || c `elem` separators) + s + + charsPart :: VersionComponent + charsPart = + case charsSpan of + "pre" -> VersionComponentPre + xs' -> VersionComponentString xs' + + +compareVersions :: Text -> Text -> Ordering +compareVersions s1 s2 = + fold $ (alignWith cmp `on` splitVersion) s1 s2 + where + cmp :: These VersionComponent VersionComponent -> Ordering + cmp = uncurry compare . join fromThese (VersionComponentString mempty) + +splitDrvName :: Text -> (Text, Text) +splitDrvName s = + both (Text.intercalate sep) (namePieces, versionPieces) + where + sep = "-" + pieces :: [Text] + pieces = Text.splitOn sep s + isFirstVersionPiece :: Text -> Bool + isFirstVersionPiece p = + maybe + False + (isDigit . fst) + (Text.uncons p) + -- Like 'break', but always puts the first item into the first result + -- list + breakAfterFirstItem :: (a -> Bool) -> [a] -> ([a], [a]) + breakAfterFirstItem f = + handlePresence + mempty + (\ (h : t) -> let (a, b) = break f t in (h : a, b)) + (namePieces, versionPieces) = + breakAfterFirstItem isFirstVersionPiece pieces + +splitMatches + :: forall e t f m + . MonadNix e t f m + => Int + -> [[(ByteString, (Int, Int))]] + -> ByteString + -> [NValue t f m] +splitMatches _ [] haystack = one $ thunkStr haystack +splitMatches _ ([] : _) _ = + fail "Fail in splitMatches: this should never happen!" +splitMatches numDropped (((_, (start, len)) : captures) : mts) haystack = + thunkStr before : caps : splitMatches (numDropped + relStart + len) + mts + (B.drop len rest) + where + relStart = max 0 start - numDropped + (before, rest) = B.splitAt relStart haystack + caps :: NValue t f m + caps = NVList (f <$> captures) + f :: (ByteString, (Int, b)) -> NValue t f m + f (a, (s, _)) = + bool + NVNull + (thunkStr a) + (s >= 0) + +thunkStr :: NVConstraint f => ByteString -> NValue t f m +thunkStr s = mkNVStrWithoutContext $ decodeUtf8 s + +hasKind + :: forall a e t f m + . (MonadNix e t f m, FromValue a m (NValue t f m)) + => NValue t f m + -> m (NValue t f m) +hasKind = + inHaskMay + (isJust @a) + + +absolutePathFromValue :: MonadNix e t f m => NValue t f m -> m Path +absolutePathFromValue = + \case + NVStr ns -> + do + let + path = coerce . toString $ ignoreContext ns + + when (not (isAbsolute path)) $ throwError $ ErrorCall $ "string " <> show path <> " doesn't represent an absolute path" + pure path + + NVPath path -> pure path + v -> throwError $ ErrorCall $ "expected a path, got " <> show v + + +data FileType + = FileTypeRegular + | FileTypeDirectory + | FileTypeSymlink + | FileTypeUnknown + deriving (Show, Read, Eq, Ord) + +instance Convertible e t f m => ToValue FileType m (NValue t f m) where + toValue = + toValue . mkNixStringWithoutContext . + \case + FileTypeRegular -> "regular" :: Text + FileTypeDirectory -> "directory" + FileTypeSymlink -> "symlink" + FileTypeUnknown -> "unknown" + +-- ** Builtin functions + +derivationNix + :: forall e t f m. (MonadNix e t f m, Scoped (NValue t f m) m) + => m (NValue t f m) +derivationNix = foldFix Eval.eval $$(do + -- This is compiled in so that we only parse it once at compile-time. + let Right expr = parseNixText [text| + 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|] + [|| expr ||] + ) + +nixPathNix :: forall e t f m . MonadNix e t f m => m (NValue t f m) +nixPathNix = + fmap + NVList + $ foldNixPath mempty $ + \p mn ty rest -> + pure $ + pure + (NVSet + mempty + (M.fromList + [case ty of + PathEntryPath -> ("path", NVPath p) + PathEntryURI -> ( "uri", mkNVStrWithoutContext $ fromString $ coerce p) + + , ( "prefix", mkNVStrWithoutContext $ maybeToMonoid mn) + ] + ) + ) + <> rest + +toStringNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +toStringNix = toValue <=< coerceAnyToNixString callFunc DontCopyToStore + +hasAttrNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +hasAttrNix x y = + do + (coerce -> key) <- fromStringNoContext =<< fromValue x + (aset, _) <- fromValue @(AttrSet (NValue t f m), PositionSet) y + + toValue $ M.member key aset + +hasContextNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +hasContextNix = inHask hasContext + +getAttrNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +getAttrNix x y = + do + (coerce -> key) <- fromStringNoContext =<< fromValue x + (aset, _) <- fromValue @(AttrSet (NValue t f m), PositionSet) y + + 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 + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +unsafeGetAttrPosNix nvX nvY = + do + x <- demand nvX + y <- demand nvY + + case (x, y) of + (NVStr ns, NVSet apos _) -> + maybe + (pure NVNull) + toValue + (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 +-- of the list. +lengthNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +lengthNix = inHask (length :: [NValue t f m] -> Int) + +addNix + :: MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +addNix nvX nvY = + do + x' <- demand nvX + y' <- demand nvY + + case (x', y') of + (NVConstant (NInt x), NVConstant (NInt y)) -> toValue ( x + y :: Integer ) + (NVConstant (NFloat x), NVConstant (NInt y)) -> toValue $ x + fromInteger y + (NVConstant (NInt x), NVConstant (NFloat y)) -> toValue $ fromInteger x + y + (NVConstant (NFloat x), NVConstant (NFloat y)) -> toValue $ x + y + (_x , _y ) -> throwError $ Addition _x _y + +mulNix + :: MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +mulNix nvX nvY = + do + x' <- demand nvX + y' <- demand nvY + + case (x', y') of + (NVConstant (NInt x), NVConstant (NInt y)) -> toValue (x * y :: Integer ) + (NVConstant (NFloat x), NVConstant (NInt y)) -> toValue (x * fromInteger y) + (NVConstant (NInt x), NVConstant (NFloat y)) -> toValue (fromInteger x * y) + (NVConstant (NFloat x), NVConstant (NFloat y)) -> toValue (x * y ) + (_x , _y ) -> throwError $ Multiplication _x _y + +divNix + :: MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +divNix nvX nvY = + do + x' <- demand nvX + y' <- demand nvY + case (x', y') of + (NVConstant (NInt x), NVConstant (NInt y)) | y /= 0 -> toValue ( floor (fromInteger x / fromInteger y :: Double) :: Integer) + (NVConstant (NFloat x), NVConstant (NInt y)) | y /= 0 -> toValue $ x / fromInteger y + (NVConstant (NInt x), NVConstant (NFloat y)) | y /= 0 -> toValue $ fromInteger x / y + (NVConstant (NFloat x), NVConstant (NFloat y)) | y /= 0 -> toValue $ x / y + (_x , _y ) -> throwError $ Division _x _y + +anyNix + :: MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +anyNix f = toValue <=< anyMNix fromValue <=< traverse (callFunc f) <=< fromValue + where + anyMNix :: Monad m => (a -> m Bool) -> [a] -> m Bool + anyMNix _ [] = pure False + anyMNix p (x : xs) = + bool + (anyMNix p xs) + (pure True) + =<< p x + +allNix + :: MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +allNix f = toValue <=< allMNix fromValue <=< traverse (callFunc f) <=< fromValue + where + allMNix :: Monad m => (a -> m Bool) -> [a] -> m Bool + allMNix _ [] = pure True + allMNix p (x : xs) = + bool + (pure False) + (allMNix p xs) + =<< p x + +foldl'Nix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> NValue t f m + -> m (NValue t f m) +foldl'Nix f z xs = foldM go z =<< fromValue @[NValue t f m] xs + where + go b a = (`callFunc` a) =<< callFunc f b + +headNix :: forall e t f m. MonadNix e t f m => NValue t f m -> m (NValue t f m) +headNix = + maybe + (throwError $ ErrorCall "builtins.head: empty list") + pure + . viaNonEmpty head <=< fromValue @[NValue t f m] + +tailNix :: forall e t f m. MonadNix e t f m => NValue t f m -> m (NValue t f m) +tailNix = + maybe + (throwError $ ErrorCall "builtins.tail: empty list") + (pure . NVList) + . viaNonEmpty tail <=< fromValue @[NValue t f m] + +splitVersionNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +splitVersionNix v = + do + version <- fromStringNoContext =<< fromValue v + pure $ + NVList $ + mkNVStrWithoutContext . show <$> + splitVersion version + +compareVersionsNix + :: MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +compareVersionsNix t1 t2 = + do + s1 <- mkText t1 + s2 <- mkText t2 + + let + cmpVers = + case compareVersions s1 s2 of + LT -> -1 + EQ -> 0 + GT -> 1 + + pure $ NVConstant $ NInt cmpVers + + where + mkText = fromStringNoContext <=< fromValue + +parseDrvNameNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +parseDrvNameNix drvname = + do + s <- fromStringNoContext =<< fromValue drvname + + let + (name :: Text, version :: Text) = splitDrvName s + + toValue @(AttrSet (NValue t f m)) $ + M.fromList + [ ( "name" :: VarName + , mkNVStr name + ) + , ( "version" + , mkNVStr version + ) + ] + + where + mkNVStr = mkNVStrWithoutContext + +matchNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +matchNix pat str = + do + p <- fromStringNoContext =<< fromValue pat + ns <- fromValue str + + -- NOTE: 2018-11-19: Currently prim_match in nix/src/libexpr/primops.cc + -- ignores the context of its second argument. This is probably a bug but we're + -- going to preserve the behavior here until it is fixed upstream. + -- Relevant issue: https://github.com/NixOS/nix/issues/2547 + let + s = ignoreContext ns + re = makeRegex p :: Regex + mkMatch t = + bool + (pure NVNull) + (toValue $ mkNixStringWithoutContext t) + (not $ Text.null t) + + case matchOnceText re s of + Just ("", sarr, "") -> + do + let submatches = fst <$> elems sarr + NVList <$> + traverse + mkMatch + (case submatches of + [] -> mempty + [a] -> one a + _:xs -> xs -- return only the matched groups, drop the full string + ) + _ -> pure NVNull + +splitNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +splitNix pat str = + do + p <- fromStringNoContext =<< fromValue pat + ns <- fromValue str + -- NOTE: Currently prim_split in nix/src/libexpr/primops.cc ignores the + -- context of its second argument. This is probably a bug but we're + -- going to preserve the behavior here until it is fixed upstream. + -- Relevant issue: https://github.com/NixOS/nix/issues/2547 + let + s = ignoreContext ns + regex = makeRegex p :: Regex + haystack = encodeUtf8 s + + pure $ NVList $ 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 = + Prim $ + bool + (throwError $ ErrorCall $ "builtins.substring: negative start position: " <> show start) + (pure $ modifyNixContents (take . Text.drop start) str) + (start >= 0) + where + take = + bool + id --NOTE: negative values of 'len' are OK, and mean "take everything" + (Text.take len) + (len >= 0) + +attrNamesNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +attrNamesNix = + coersion . inHask @(AttrSet (NValue t f m)) + (fmap (mkNixStringWithoutContext . coerce) . sort . M.keys) + where + coersion = fmap (coerce :: CoerceDeeperToNValue t f m) + +attrValuesNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +attrValuesNix nvattrs = + do + attrs <- fromValue @(AttrSet (NValue t f m)) nvattrs + toValue $ + snd <$> + sortOn + (fst @VarName @(NValue t f m)) + (M.toList attrs) + +mapNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +mapNix f = + inHaskM @[NValue t f m] + (traverse + (defer + . withFrame Debug (ErrorCall "While applying f in map:\n") + . callFunc f + ) + ) + +mapAttrsNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +mapAttrsNix f xs = + do + nixAttrset <- fromValue @(AttrSet (NValue t f m)) xs + let + keyVals = M.toList nixAttrset + keys = fst <$> keyVals + + applyFunToKeyVal (key, val) = + do + runFunForKey <- callFunc f $ mkNVStrWithoutContext (coerce key) + callFunc runFunForKey val + + newVals <- + traverse + (defer @(NValue t f m) . withFrame Debug (ErrorCall "While applying f in mapAttrs:\n") . applyFunToKeyVal) + keyVals + + toValue $ M.fromList $ zip keys newVals + +filterNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +filterNix f = + inHaskM + (filterM fh) + where + fh :: NValue t f m -> m Bool + fh = fromValue <=< callFunc f + +catAttrsNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +catAttrsNix attrName xs = + do + n <- fromStringNoContext =<< fromValue attrName + l <- fromValue @[NValue t f m] xs + + NVList . catMaybes <$> + traverse + (fmap (M.lookup @VarName $ coerce n) . fromValue <=< demand) + l + +baseNameOfNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +baseNameOfNix x = + do + ns <- coerceStringlikeToNixString DontCopyToStore x + pure $ + NVStr $ + modifyNixContents + (fromString . coerce takeFileName . toString) + ns + +bitAndNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +bitAndNix x y = + do + a <- fromValue @Integer x + b <- fromValue @Integer y + + toValue $ a .&. b + +bitOrNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +bitOrNix x y = + do + a <- fromValue @Integer x + b <- fromValue @Integer y + + toValue $ a .|. b + +bitXorNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +bitXorNix x y = + do + a <- fromValue @Integer x + b <- fromValue @Integer y + + toValue $ a `xor` b + +builtinsBuiltinNix + :: forall e t f m + . MonadNix e t f m + => 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 (NarFile path) recursive False + -- TODO: Ensure that s matches sha256 when not empty + pure $ NVStr $ 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 + 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 . ignoreContext) + +-- | Evaluate `a` to WHNF to collect its topmost effect. +seqNix + :: MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +seqNix a b = b <$ demand a + +-- | Evaluate 'a' to NF to collect all of its effects, therefore data cycles are ignored. +deepSeqNix + :: MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +deepSeqNix a b = b <$ normalForm_ a + +elemNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +elemNix x = inHaskM (anyMNix $ valueEqM x) + where + anyMNix :: Monad m => (a -> m Bool) -> [a] -> m Bool + anyMNix p = + handlePresence + (pure False) + (\ (x : xss) -> + bool + (anyMNix p xss) + (pure True) + =<< p x + ) + +elemAtNix + :: MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +elemAtNix xs n = + do + n' <- fromValue n + xs' <- fromValue xs + maybe + (throwError $ ErrorCall $ "builtins.elem: Index " <> show n' <> " too large for list of length " <> show (length xs')) + pure + (xs' !!? n') + +genListNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +genListNix f nixN = + do + n <- fromValue @Integer nixN + bool + (throwError $ ErrorCall $ "builtins.genList: Expected a non-negative number, got " <> show n) + (toValue =<< traverse (defer . callFunc f <=< toValue) [0 .. n - 1]) + (n >= 0) + +genericClosureNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +genericClosureNix c = + do + s <- fromValue @(AttrSet (NValue t f m)) c + + case (M.lookup "startSet" s, M.lookup "operator" s) of + (Nothing , Nothing ) -> throwError $ ErrorCall "builtins.genericClosure: Attributes 'startSet' and 'operator' required" + (Nothing , Just _ ) -> throwError $ ErrorCall "builtins.genericClosure: Attribute 'startSet' required" + (Just _ , Nothing ) -> throwError $ ErrorCall "builtins.genericClosure: Attribute 'operator' required" + (Just startSet, Just operator) -> + do + ss <- fromValue @[NValue t f m] =<< demand startSet + op <- demand operator + let + go + :: Set (WValue t f m) + -> [NValue t f m] + -> m (Set (WValue t f m), [NValue t f m]) + go ks [] = pure (ks, mempty) + go ks (t : ts) = + do + v <- demand t + k <- demand =<< attrsetGet "key" =<< fromValue @(AttrSet (NValue t f m)) v + + bool + (do + checkComparable k $ + handlePresence + k + (\ (WValue j:_) -> j) + (S.toList ks) + + (<<$>>) (v :) . go (S.insert (WValue k) ks) . (<>) ts =<< fromValue @[NValue t f m] =<< callFunc op v + ) + (go ks ts) + (S.member (WValue k) ks) + + toValue @[NValue t f m] =<< snd <$> go mempty ss + +-- | Takes: +-- 1. List of strings to match. +-- 2. List of strings to replace corresponding match occurance. (arg 1 & 2 lists matched by index) +-- 3. String to process +-- -> returns the string with requested replacements. +-- +-- Example: +-- builtins.replaceStrings ["ll" "e"] [" " "i"] "Hello world" == "Hi o world". +replaceStringsNix + :: MonadNix e t f m + => NValue t f m + -> NValue t f m + -> NValue t f m + -> m (NValue t f m) +replaceStringsNix tfrom tto ts = + do + -- NixStrings have context - remember + (fromKeys :: [NixString]) <- fromValue (Deeper tfrom) + (toVals :: [NixString]) <- fromValue (Deeper tto) + (string :: NixString ) <- fromValue ts + + when (length fromKeys /= length toVals) $ throwError $ ErrorCall "builtins.replaceStrings: Arguments `from`&`to` construct a key-value map, so the number of their elements must always match." + + let + -- 2021-02-18: NOTE: if there is no match - the process does not changes the context, simply slides along the string. + -- So it isbe more effective to pass the context as the first argument. + -- And moreover, the `passOneCharNgo` passively passes the context, to context can be removed from it and inherited directly. + -- Then the solution would've been elegant, but the Nix bug prevents elegant implementation. + go ctx input output = + maybe + -- Passively pass the chars + passOneChar + replace + maybePrefixMatch + + where + -- When prefix matched something - returns (match, replacement, remainder) + maybePrefixMatch :: Maybe (Text, NixString, Text) + maybePrefixMatch = formMatchReplaceTailInfo <$> find ((`Text.isPrefixOf` input) . fst) fromKeysToValsMap + where + formMatchReplaceTailInfo (m, r) = (m, r, Text.drop (Text.length m) input) + + fromKeysToValsMap = zip (ignoreContext <$> fromKeys) toVals + + -- Not passing args => It is constant that gets embedded into `go` => It is simple `go` tail recursion + passOneChar = + maybe + (finish ctx output) -- The base case - there is no chars left to process -> finish + (\(c, i) -> go ctx i (output <> Builder.singleton c)) -- If there are chars - pass one char & continue + (Text.uncons input) -- chip first char + + -- 2021-02-18: NOTE: rly?: toStrict . toLazyText + -- Maybe `text-builder`, `text-show`? + finish ctx output = mkNixString ctx (toStrict $ Builder.toLazyText output) + + replace (key, replacementNS, unprocessedInput) = replaceWithNixBug unprocessedInput updatedOutput + + where + replaceWithNixBug = + bool + (go updatedCtx) -- tail recursion + -- Allowing match on "" is a inherited bug of Nix, + -- when "" is checked - it always matches. And so - when it checks - it always insers a replacement, and then process simply passesthrough the char that was under match. + -- + -- repl> builtins.replaceStrings ["" "e"] [" " "i"] "Hello world" + -- " H e l l o w o r l d " + -- repl> builtins.replaceStrings ["ll" ""] [" " "i"] "Hello world" + -- "iHie ioi iwioirilidi" + -- 2021-02-18: NOTE: There is no tests for this + bugPassOneChar -- augmented recursion + isNixBugCase + + isNixBugCase = key == mempty + + updatedOutput = output <> replacement + updatedCtx = ctx <> replacementCtx + + 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 + -- => mutual recusion case, so placed separately. + bugPassOneChar input output = + maybe + (finish updatedCtx output) -- The base case - there is no chars left to process -> finish + (\(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 (getStringContext string) (ignoreContext string) mempty + +removeAttrsNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +removeAttrsNix set v = + do + (m, p) <- fromValue @(AttrSet (NValue t f m), PositionSet) set + (nsToRemove :: [NixString]) <- fromValue $ Deeper v + (coerce -> toRemove) <- traverse fromStringNoContext nsToRemove + toValue (fun m toRemove, fun p toRemove) + where + 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 + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +intersectAttrsNix set1 set2 = + do + (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) + +functionArgsNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +functionArgsNix nvfun = + do + fun <- demand nvfun + case fun of + NVClosure p _ -> + toValue @(AttrSet (NValue t f m)) $ NVBool <$> + case p of + Param name -> one (name, False) + ParamSet _ _ pset -> isJust <$> M.fromList pset + _v -> throwError $ ErrorCall $ "builtins.functionArgs: expected function, got " <> show _v + +toFileNix + :: MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +toFileNix name s = + do + name' <- fromStringNoContext =<< fromValue name + s' <- fromValue s + mres <- + toFile_ + (coerce $ toString name') + (ignoreContext s') + + let + storepath = coerce (fromString @Text) mres + sc = StringContext DirectPath storepath + + toValue $ mkNixStringWithSingletonContext sc storepath + +toPathNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +toPathNix = inHask @Path id + +pathExistsNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +pathExistsNix nvpath = + do + path <- demand nvpath + toValue =<< + case path of + NVPath p -> doesPathExist p + 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)) + +isListNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +isListNix = hasKind @[NValue t f m] + +isIntNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +isIntNix = hasKind @Int + +isFloatNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +isFloatNix = hasKind @Float + +isBoolNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +isBoolNix = hasKind @Bool + +isNullNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +isNullNix = hasKind @() + +-- isString cannot use `hasKind` because it coerces derivationNixs to strings. +isStringNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +isStringNix nv = + do + v <- demand nv + + toValue $ + case v of + NVStr{} -> True + _ -> False + +isFunctionNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +isFunctionNix nv = + do + v <- demand nv + + toValue $ + case v of + NVClosure{} -> True + _ -> False + +throwNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +throwNix = + throwError . ErrorCall . toString . ignoreContext + <=< coerceStringlikeToNixString CopyToStore + +-- | Implementation of Nix @import@ clause. +-- +-- Because Nix @import@s work strictly +-- (import gets fully evaluated befor bringing it into the scope it was called from) +-- - that property raises a requirement for execution phase of the interpreter go into evaluation phase +-- & then also go into parsing phase on the imports. +-- So it is not possible (more precise - not practical) to do a full parse Nix code phase fully & then go into evaluation phase. +-- As it is not possible to "import them lazily", as import is strict & it is not possible to establish +-- what imports whould be needed up until where it would be determined & they import strictly +-- +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 + +-- | @scopedImport scope path@ +-- An undocumented secret powerful function. +-- +-- At the same time it is strongly forbidden to be used, as prolonged use of it would bring devastating consequences. +-- As it is essentially allows rewriting(redefinition) paradigm. +-- +-- Allows to import the environment into the scope of a file expression that gets imported. +-- It is as if the contents at @path@ were given to @import@ wrapped as: @with scope; path@ +-- meaning: +-- +-- > -- Nix pseudocode: +-- > import (with scope; path) +-- +-- For example, it allows to use itself as: +-- > bar = scopedImport pkgs ./bar.nix; +-- > -- & declare @./bar.nix@ without a header, so as: +-- > stdenv.mkDerivation { ... buildInputs = [ libfoo ]; } +-- +-- But that breaks the evaluation/execution sharing of the @import@s. +-- +-- Function also allows to redefine or extend the builtins. +-- +-- For instance, to trace all calls to function ‘map’: +-- +-- > let +-- > overrides = { +-- > map = f: xs: builtins.trace "call of map!" (map f xs); +-- +-- > # Propagate override by calls to import&scopedImport. +-- > import = fn: scopedImport overrides fn; +-- > scopedImport = attrs: fn: scopedImport (overrides // attrs) fn; +-- +-- > # Update ‘builtins’. +-- > builtins = builtins // overrides; +-- > }; +-- > in scopedImport overrides ./bla.nix +-- +-- In the related matter the function can be added and passed around as builtin. +scopedImportNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +scopedImportNix asetArg pathArg = + do + (coerce -> scope) <- fromValue @(AttrSet (NValue t f m)) asetArg + p <- fromValue pathArg + + path <- pathToDefaultNix @t @f @m p + path' <- + maybe + (do + traceM "No known current directory" + pure path + ) + (\ res -> + do + p' <- fromValue @Path =<< demand res + + traceM $ "Current file being evaluated is: " <> show p' + pure $ takeDirectory p' path + ) + =<< lookupVar "__cur_file" + + clearScopes @(NValue t f m) + $ withNixContext (pure path') + $ pushScope scope + $ importPath @t @f @m path' + +getEnvNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +getEnvNix v = + (toValue . mkNixStringWithoutContext . maybeToMonoid) =<< getEnvVar =<< fromStringNoContext =<< fromValue v + +sortNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +sortNix comp = + inHaskM (sortByM cmp) + where + cmp :: NValue t f m -> NValue t f m -> m Ordering + cmp a b = + bool + (fmap + (bool EQ GT) + (compare b a) + ) + (pure LT) + =<< compare a b + where + compare :: NValue t f m -> NValue t f m -> m Bool + compare a2 a1 = fromValue =<< (`callFunc` a1) =<< callFunc comp a2 + +lessThanNix + :: MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +lessThanNix ta tb = + do + va <- demand ta + vb <- demand tb + + let + badType = throwError $ ErrorCall $ "builtins.lessThan: expected two numbers or two strings, got '" <> show va <> "' and '" <> show vb <> "'." + + NVBool <$> + case (va, vb) of + (NVConstant ca, NVConstant cb) -> + case (ca, cb) of + (NInt a, NInt b) -> pure $ a < b + (NInt a, NFloat b) -> pure $ fromInteger a < b + (NFloat a, NInt b) -> pure $ a < fromInteger b + (NFloat a, NFloat b) -> pure $ a < b + _ -> badType + (NVStr a, NVStr b) -> pure $ ignoreContext a < ignoreContext b + _ -> badType + +-- | Helper function, generalization of @concat@ operations. +concatWith + :: forall e t f m + . MonadNix e t f m + => (NValue t f m -> m (NValue t f m)) + -> NValue t f m + -> m (NValue t f m) +concatWith f = + toValue . + concat <=< + traverse + (fromValue @[NValue t f m] <=< f) + <=< fromValue @[NValue t f m] + +-- | Nix function of Haskell: +-- > concat :: [[a]] -> [a] +-- +-- Concatenate a list of lists into a single list. +concatListsNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +concatListsNix = concatWith demand + +-- | Nix function of Haskell: +-- > concatMap :: Foldable t => (a -> [b]) -> t a -> [b] +concatMapNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +concatMapNix f = concatWith (callFunc f) + +listToAttrsNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +listToAttrsNix lst = + do + l <- fromValue @[NValue t f m] lst + fmap + (NVSet mempty . M.fromList . reverse) + (traverse + (\ nvattrset -> + do + a <- fromValue @(AttrSet (NValue t f m)) =<< demand nvattrset + (coerce -> name) <- fromStringNoContext =<< fromValue =<< demand =<< attrsetGet "name" a + val <- attrsetGet "value" a + + pure (name, val) + ) + l + ) + +-- prim_hashString from nix/src/libexpr/primops.cc +-- fail if context in the algo arg +-- propagate context from the s arg +-- | The result coming out of hashString is base16 encoded +hashStringNix + :: forall e t f m. MonadNix e t f m => NixString -> NixString -> Prim m NixString +hashStringNix nsAlgo ns = + Prim $ + do + algo <- fromStringNoContext nsAlgo + let + f g = pure $ modifyNixContents g ns + + case algo of + -- 2021-03-04: Pattern can not be taken-out because hashes represented as different types + "md5" -> f (show . mkHash @MD5.MD5) + "sha1" -> f (show . mkHash @SHA1.SHA1) + "sha256" -> f (show . mkHash @SHA256.SHA256) + "sha512" -> f (show . mkHash @SHA512.SHA512) + + _ -> throwError $ ErrorCall $ "builtins.hashString: expected \"md5\", \"sha1\", \"sha256\", or \"sha512\", got " <> show algo + + where + -- This intermidiary `a` is only needed because of the type application + mkHash :: (Show a, HashAlgorithm a) => Text -> a + 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) + NVSet mempty + . fmap (NVList . 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 + t <- fromStringNoContext =<< fromValue p + h <- + coerce @(Prim m NixString) @(m NixString) $ + (hashStringNix `on` mkNixStringWithoutContext) + "sha256" + ("nix-output:" <> t) + toValue + $ mkNixStringWithoutContext + $ Text.cons '/' + $ Base32.encode + -- Please, stop Text -> Bytestring here after migration to Text + $ case Base16.decode (bytes h) of -- The result coming out of hashString is base16 encoded +#if MIN_VERSION_base16_bytestring(1,0,0) + -- Please, stop Text -> String here after migration to Text + Left e -> error $ "Couldn't Base16 decode the text: '" <> body h <> "'.\nThe Left fail content: '" <> show e <> "'." + Right d -> d +#else + (d, "") -> d + (_, e) -> error $ "Couldn't Base16 decode the text: '" <> body h <> "'.\nUndecodable remainder: '" <> show e <> "'." +#endif + where + bytes :: NixString -> ByteString + bytes = encodeUtf8 . body + + body = ignoreContext + +readFileNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +readFileNix = toValue <=< Nix.Render.readFile <=< absolutePathFromValue <=< demand + +findFileNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +findFileNix nvaset nvfilepath = + do + aset <- demand nvaset + filePath <- demand nvfilepath + + case (aset, filePath) of + (NVList x, NVStr ns) -> + do + mres <- findPath @t @f @m x $ coerce $ toString $ ignoreContext ns + + pure $ NVPath mres + + (NVList _, _y ) -> throwError $ ErrorCall $ "expected a string, got " <> show _y + (_x , NVStr _) -> throwError $ ErrorCall $ "expected a list, got " <> show _x + (_x , _y ) -> throwError $ ErrorCall $ "Invalid types for builtins.findFile: " <> show (_x, _y) + +readDirNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +readDirNix nvpath = + do + path <- absolutePathFromValue =<< demand nvpath + items <- listDirectory path + + let + -- | Function indeed binds filepaths as keys ('VarNames') in Nix attrset. + detectFileTypes :: Path -> m (VarName, FileType) + detectFileTypes item = + do + s <- getSymbolicLinkStatus $ path item + let + t = + if + | isRegularFile s -> FileTypeRegular + | isDirectory s -> FileTypeDirectory + | isSymbolicLink s -> FileTypeSymlink + | otherwise -> FileTypeUnknown + + pure (coerce @(String -> Text) fromString item, t) + + itemsWithTypes <- + traverse + detectFileTypes + items + + (coerce :: CoerceDeeperToNValue t f m) <$> toValue (M.fromList itemsWithTypes) + +fromJSONNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +fromJSONNix nvjson = + do + j <- demand nvjson + jText <- fromStringNoContext =<< fromValue j + + either + (\ jsonError -> throwError $ ErrorCall $ "builtins.fromJSON: " <> jsonError) + jsonToNValue + -- do we really need to marshall Text -> ByteString -> Aeson.Value (that is a Text) + (A.eitherDecodeStrict' @A.Value $ encodeUtf8 jText) + + where + jsonToNValue :: (A.Value -> m (NValue t f m)) + jsonToNValue = + \case + A.Object m -> + traverseToNValue + (NVSet 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 $ mkNVStrWithoutContext s + A.Number n -> + pure $ + NVConstant $ + either + NFloat + NInt + (floatingOrInteger n) + A.Bool b -> pure $ NVBool b + A.Null -> pure NVNull + where + traverseToNValue :: Traversable t0 => (t0 (NValue t f m) -> b) -> t0 A.Value -> m b + 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 . toJSONNixString) <=< demand + +toXMLNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +toXMLNix = (fmap (NVStr . toXML) . normalForm) <=< demand + +typeOfNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +typeOfNix nvv = + do + v <- demand nvv + let + detectType = + case v of + NVConstant a -> + case a of + NURI _ -> "string" + NInt _ -> "int" + NFloat _ -> "float" + NBool _ -> "bool" + NNull -> "null" + NVStr _ -> "string" + NVList _ -> "list" + NVSet _ _ -> "set" + NVClosure{} -> "lambda" + NVPath _ -> "path" + NVBuiltin _ _ -> "lambda" + _ -> error "Pattern synonyms obscure complete patterns" + + toValue $ mkNixStringWithoutContext detectType + +tryEvalNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +tryEvalNix e = (`catch` (pure . onError)) + (onSuccess <$> demand e) + where + onSuccess v = + NVSet + mempty + $ M.fromList + [ ("success", NVBool True) + , ("value" , v ) + ] + + onError :: SomeException -> NValue t f m + onError _ = + NVSet + mempty + $ M.fromList + $ (, NVBool False) <$> + [ "success" + , "value" + ] + +traceNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +traceNix msg action = + do + traceEffect @t @f @m . toString . ignoreContext =<< fromValue msg + pure action + +-- Please, can function remember fail context +addErrorContextNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m -- action + -> m (NValue t f m) +addErrorContextNix _ = pure + +execNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +execNix 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 . fmap ignoreContext) =<< traverse (coerceStringlikeToNixString DontCopyToStore) =<< fromValue @[NValue t f m] xs + +fetchurlNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +fetchurlNix = + (\case + NVSet _ s -> fetch (M.lookup "sha256" s) =<< demand =<< attrsetGet "url" s + v@NVStr{} -> fetch Nothing v + v -> throwError $ ErrorCall $ "builtins.fetchurl: Expected URI or set, got " <> show v + ) <=< demand + + where + -- 2022-01-21: NOTE: Needs to check the hash match. + fetch :: Maybe (NValue t f m) -> NValue t f m -> m (NValue t f m) + fetch _msha = + \case + NVStr ns -> + either -- msha + throwError + toValue + =<< getURL + =<< maybe + (throwError $ ErrorCall "builtins.fetchurl: unsupported arguments to url") + pure + (getStringNoContext ns) + + v -> throwError $ ErrorCall $ "builtins.fetchurl: Expected URI or string, got " <> show v + +partitionNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +partitionNix f nvlst = + do + let + match t = (, t) <$> (fromValue =<< callFunc f t) + selection <- traverse match =<< fromValue @[NValue t f m] nvlst + + let + (right, wrong) = partition fst selection + makeSide = NVList . fmap snd + + toValue @(AttrSet (NValue t f m)) + $ M.fromList + [ ("right", makeSide right) + , ("wrong", makeSide wrong) + ] + +currentSystemNix :: MonadNix e t f m => m (NValue t f m) +currentSystemNix = + do + os <- getCurrentSystemOS + arch <- getCurrentSystemArch + + pure $ mkNVStrWithoutContext $ arch <> "-" <> os + +currentTimeNix :: MonadNix e t f m => m (NValue t f m) +currentTimeNix = + do + 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, NVConstraint f) => a -> m (NValue t f m) +getRecursiveSizeNix = fmap (NVConstant . NInt . fromIntegral) . recursiveSize + +getContextNix + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +getContextNix = + \case + (NVStr ns) -> + NVSet mempty <$> traverseToValue (getNixLikeContext $ toNixLikeContext $ getStringContext ns) + x -> throwError $ ErrorCall $ "Invalid type for builtins.getContext: " <> show x + <=< demand + +appendContextNix + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> NValue t f m + -> m (NValue t f m) +appendContextNix tx ty = + do + x <- demand tx + y <- demand ty + + case (x, y) of + (NVStr ns, NVSet _ attrs) -> + do + let + getPathNOuts :: NValue t f m -> m NixLikeContextValue + getPathNOuts tx = + do + x <- demand tx + + case x of + NVSet _ atts -> + do + -- TODO: Fail for unexpected keys. + + let + getK :: VarName -> m Bool + getK k = + maybe + (pure False) + (fromValue <=< demand) + $ M.lookup k atts + + getOutputs :: m [Text] + getOutputs = + maybe + stub + (\ touts -> + do + outs <- demand touts + + 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) + + path <- getK "path" + allOutputs <- getK "allOutputs" + + NixLikeContextValue path allOutputs <$> getOutputs + + _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 + + toValue . addContext =<< traverse getPathNOuts attrs + + _xy -> throwError $ ErrorCall $ "Invalid types for builtins.appendContext: " <> show _xy + + +nixVersionNix :: MonadNix e t f m => m (NValue t f m) +nixVersionNix = toValue $ mkNixStringWithoutContext "2.3" + +langVersionNix :: MonadNix e t f m => m (NValue t f m) +langVersionNix = toValue (5 :: Int) + +-- ** @builtinsList@ + +builtinsList :: forall e t f m . MonadNix e t f m => m [Builtin (NValue t f m)] +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 $ NVBool 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 -- Deprecated in Nix: https://github.com/NixOS/nix/pull/2524 + , add Normal "toXML" toXMLNix + , add0 Normal "true" (pure $ NVBool 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 + arity0 = Prim . pure + + arity1 :: (a -> b) -> (a -> Prim m b) + arity1 g = arity0 . g + + arity2 :: (a -> b -> c) -> (a -> b -> Prim m c) + arity2 f = arity1 . f + + mkBuiltin :: BuiltinType -> VarName -> m (NValue t f m) -> m (Builtin (NValue t f m)) + mkBuiltin t n v = wrap t n <$> mkThunk n v + where + wrap :: BuiltinType -> VarName -> v -> Builtin v + wrap t n f = Builtin t (n, f) + + mkThunk :: VarName -> m (NValue t f m) -> m (NValue t f m) + mkThunk n = defer . withFrame Info (ErrorCall $ "While calling builtin " <> toString n <> "\n") + + hAdd + :: ( VarName + -> fun + -> m (NValue t f m) + ) + -> BuiltinType + -> VarName + -> fun + -> m (Builtin (NValue t f m)) + hAdd f t n v = mkBuiltin t n $ f n v + + add0 + :: BuiltinType + -> VarName + -> m (NValue t f m) + -> m (Builtin (NValue t f m)) + add0 = hAdd (\ _ x -> x) + + add + :: BuiltinType + -> VarName + -> ( NValue t f m + -> m (NValue t f m) + ) + -> m (Builtin (NValue t f m)) + add = hAdd builtin + + add2 + :: BuiltinType + -> VarName + -> ( NValue t f m + -> NValue t f m + -> m (NValue t f m) + ) + -> m (Builtin (NValue t f m)) + add2 = hAdd builtin2 + + add3 + :: BuiltinType + -> VarName + -> ( NValue t f m + -> NValue t f m + -> NValue t f m + -> m (NValue t f m) + ) + -> m (Builtin (NValue t f m)) + add3 = hAdd builtin3 + + add' + :: ToBuiltin t f m a + => BuiltinType + -> VarName + -> a + -> m (Builtin (NValue t f m)) + add' = hAdd (toBuiltin . coerce) + + +-- * Exported + +-- | Evaluate expression in the default context. +withNixContext + :: forall e t f m r + . (MonadNix e t f m, Has e Options) + => Maybe Path + -> m r + -> m r +withNixContext mpath action = + do + base <- builtins + opts <- askOptions + + pushScope + (one ("__includes", NVList $ mkNVStrWithoutContext . fromString . coerce <$> getInclude opts)) + (pushScopes + base $ + maybe + id + (\ path act -> + do + traceM $ "Setting __cur_file = " <> show path + pushScope (one ("__cur_file", NVPath path)) act + ) + mpath + action + ) + +builtins + :: forall e t f m + . ( MonadNix e t f m + , Scoped (NValue t f m) m + ) + => m (Scopes m (NValue t f m)) +builtins = + do + ref <- defer $ NVSet 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 + + topLevelBuiltins :: m [(VarName, NValue t f m)] + topLevelBuiltins = mapping <<$>> fullBuiltinsList + + fullBuiltinsList :: m [Builtin (NValue t f m)] + fullBuiltinsList = nameBuiltins <<$>> builtinsList + where + nameBuiltins :: Builtin v -> Builtin v + nameBuiltins b@(Builtin TopLevel _) = b + nameBuiltins (Builtin Normal 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 @@ -1,9 +1,10 @@ -{-# LANGUAGE CPP #-} +{-# language CPP #-} -- | Reading and writing Nix cache files module Nix.Cache where -import qualified Data.ByteString.Lazy as BS +import Nix.Prelude +import qualified Data.ByteString.Lazy as BSL import Nix.Expr.Types.Annotated #if defined (__linux__) @@ -17,7 +18,7 @@ #endif import qualified Codec.Serialise as S -readCache :: FilePath -> IO NExprLoc +readCache :: Path -> IO NExprLoc readCache path = do #if USE_COMPACT eres <- C.unsafeReadCompact path @@ -26,17 +27,17 @@ (\ expr -> pure $ C.getCompact expr) eres #else - eres <- S.deserialiseOrFail <$> BS.readFile path + eres <- S.deserialiseOrFail <$> BSL.readFile (coerce path) either (\ err -> fail $ "Error reading cache file: " <> show err) pure eres #endif -writeCache :: FilePath -> NExprLoc -> IO () +writeCache :: Path -> NExprLoc -> IO () writeCache path expr = #ifdef USE_COMPACT C.writeCompact path =<< C.compact expr #else - BS.writeFile path (S.serialise expr) + BSL.writeFile (coerce path) (S.serialise expr) #endif diff --git a/src/Nix/Cited.hs b/src/Nix/Cited.hs --- a/src/Nix/Cited.hs +++ b/src/Nix/Cited.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE TemplateHaskell #-} +{-# language DeriveAnyClass #-} +{-# language TemplateHaskell #-} -{-# OPTIONS_GHC -Wno-missing-signatures #-} +{-# options_ghc -Wno-missing-signatures #-} 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 @@ -1,12 +1,10 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE PatternSynonyms #-} +{-# language GeneralizedNewtypeDeriving #-} +{-# language UndecidableInstances #-} +{-# language PatternSynonyms #-} module Nix.Cited.Basic where -import Prelude hiding ( force ) +import Nix.Prelude import Control.Comonad ( Comonad ) import Control.Comonad.Env ( ComonadEnv ) import Control.Monad.Catch hiding ( catchJust ) @@ -14,11 +12,10 @@ import Nix.Eval as Eval ( EvalFrame(EvaluatingExpr,ForcingExpr) ) import Nix.Exec -import Nix.Expr +import Nix.Expr.Types.Annotated import Nix.Frames import Nix.Options import Nix.Thunk -import Nix.Utils import Nix.Value @@ -83,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 (fromException -> Just (EvaluatingExpr scope (AnnE s e))) = - let e' = AnnFP s (Nothing <$ e) in - [Provenance scope e'] - go _ = mempty - ps = concatMap (go . frame) frames + fun :: SomeException -> [Provenance m (NValue u f m)] + fun (fromException -> Just (EvaluatingExpr scope (Ann s e))) = + one $ Provenance scope $ AnnF s (Nothing <$ e) + 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 @@ -180,8 +179,8 @@ -> m a -> m a displayProvenance = - list + handlePresence id - (\ (Provenance scope e@(AnnFP s _) : _) -> + (\ (Provenance scope e@(AnnF s _) : _) -> withFrame Info $ ForcingExpr scope $ wrapExprLoc s e ) diff --git a/src/Nix/Context.hs b/src/Nix/Context.hs --- a/src/Nix/Context.hs +++ b/src/Nix/Context.hs @@ -1,32 +1,33 @@ - module Nix.Context where +import Nix.Prelude import Nix.Options ( Options ) import Nix.Scope ( Scopes ) import Nix.Frames ( Frames ) import Nix.Expr.Types.Annotated ( SrcSpan , nullSpan ) -import Nix.Utils ( Has(..) ) -data Context m t = Context - { scopes :: Scopes m t - , source :: SrcSpan - , frames :: Frames - , options :: Options +-- 2021-07-18: NOTE: It should be Options -> Scopes -> Frames -> Source(span) +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 @@ -1,11 +1,10 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE IncoherentInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# language AllowAmbiguousTypes #-} +{-# language ConstraintKinds #-} +{-# language IncoherentInstances #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# options_ghc -fno-warn-name-shadowing #-} -- | Although there are a lot of instances in this file, really it's just a -- combinatorial explosion of the following combinations: @@ -16,19 +15,17 @@ module Nix.Convert where -import Prelude hiding ( force ) +import Nix.Prelude import Control.Monad.Free import qualified Data.HashMap.Lazy as M import Nix.Atoms import Nix.Effects import Nix.Expr.Types -import Nix.Expr.Types.Annotated import Nix.Frames import Nix.String import Nix.Value import Nix.Value.Monad import Nix.Thunk ( MonadThunk(force) ) -import Nix.Utils newtype Deeper a = Deeper a deriving (Typeable, Functor, Foldable, Traversable) @@ -50,13 +47,45 @@ -} +type Convertible e t f m + = (Framed e m, MonadDataErrorContext t f m, MonadThunk t m (NValue t f m)) + +-- | Transform Nix -> Hask. Run function. Convert Hask -> Nix. +inHask :: forall a1 a2 v b m . (Monad m, FromValue a1 m v, ToValue a2 m b) => (a1 -> a2) -> v -> m b +inHask f = toValue . f <=< fromValue + +inHaskM :: forall a1 a2 v b m . (Monad m, FromValue a1 m v, ToValue a2 m b) => (a1 -> m a2) -> v -> m b +inHaskM f = toValue <=< f <=< fromValue + +-- | Maybe transform Nix -> Hask. Run function. Convert Hask -> Nix. +inHaskMay :: forall a1 a2 v b m . (Monad m, FromValue a1 m v, ToValue a2 m b) => (Maybe a1 -> a2) -> v -> m b +inHaskMay f = toValue . f <=< fromValueMay + + -- * FromValue class FromValue a m v where fromValue :: v -> m a fromValueMay :: v -> m (Maybe a) +traverseFromValue + :: ( Applicative m + , Traversable t + , FromValue b m a + ) + => t a + -> m (Maybe (t b)) +traverseFromValue = traverse2 fromValueMay +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. fromMayToValue :: forall t f m a e @@ -67,12 +96,10 @@ -> NValue' t f m (NValue t f m) -> m a fromMayToValue t v = - do - v' <- fromValueMay v - maybe - (throwError $ Expectation @t @f @m t (Free v)) - pure - v' + maybe + (throwError $ Expectation @t @f @m t (Free v)) + pure + =<< fromValueMay v fromMayToDeeperValue :: forall t f m a e m1 @@ -83,15 +110,10 @@ -> Deeper (NValue' t f m (NValue t f m)) -> m (m1 a) fromMayToDeeperValue t v = - do - v' <- fromValueMay v - maybe - (throwError $ Expectation @t @f @m t $ Free $ (coerce :: CoerceDeeperToNValue' t f m) v) - pure - v' - -type Convertible e t f m - = (Framed e m, MonadDataErrorContext t f m, MonadThunk t m (NValue t f m)) + maybe + (throwError $ Expectation @t @f @m t $ Free $ (coerce :: CoerceDeeperToNValue' t f m) v) + pure + =<< fromValueMay v instance ( Convertible e t f m , MonadValue (NValue t f m) m @@ -117,9 +139,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 @@ -135,7 +158,7 @@ fromValueMay = pure . \case - NVConstant' NNull -> pass + NVConstant' NNull -> stub _ -> mempty fromValue = fromMayToValue TNull @@ -195,17 +218,18 @@ \case NVStr' ns -> pure $ pure ns NVPath' p -> - fmap - (pure . (\s -> makeNixStringWithSingletonContext s (StringContext s DirectPath)) . toText . unStorePath) - (addPath p) - NVSet' s _ -> + (\path -> pure $ mkNixStringWithSingletonContext (StringContext DirectPath path) path) . fromString . coerce <$> + addPath p + NVSet' _ s -> maybe stub fromValueMay (M.lookup "outPath" s) _ -> stub - fromValue = fromMayToValue $ TString NoContext + -- 2021-07-18: NOTE: There may be cases where conversion wrongly marks the content to have a context. + -- See: https://github.com/haskell-nix/hnix/pull/958#issuecomment-881949183 thread. + fromValue = fromMayToValue $ TString HasContext instance Convertible e t f m => FromValue ByteString m (NValue' t f m (NValue t f m)) where @@ -213,15 +237,22 @@ fromValueMay = pure . \case - NVStr' ns -> encodeUtf8 <$> getStringNoContext ns + NVStr' ns -> encodeUtf8 <$> getStringNoContext ns _ -> mempty - fromValue = fromMayToValue $ TString NoContext + fromValue = fromMayToValue $ TString mempty +instance Convertible e t f m + => FromValue Text m (NValue' t f m (NValue t f m)) where -newtype Path = Path { getPath :: FilePath } - deriving Show + fromValueMay = + pure . + \case + NVStr' ns -> getStringNoContext ns + _ -> mempty + fromValue = fromMayToValue $ TString mempty + instance ( Convertible e t f m , MonadValue (NValue t f m) m ) @@ -229,14 +260,14 @@ fromValueMay = \case - NVPath' p -> pure $ pure $ Path p - NVStr' ns -> pure $ Path . toString <$> getStringNoContext ns - NVSet' s _ -> + NVPath' p -> pure $ pure $ coerce p + NVStr' ns -> pure $ coerce . toString <$> getStringNoContext ns + NVSet' _ s -> maybe - (pure Nothing) + stub (fromValueMay @Path) (M.lookup "outPath" s) - _ -> pure Nothing + _ -> stub fromValue = fromMayToValue TPath @@ -257,7 +288,7 @@ => FromValue [a] m (Deeper (NValue' t f m (NValue t f m))) where fromValueMay = \case - Deeper (NVList' l) -> sequence <$> traverse fromValueMay l + Deeper (NVList' l) -> traverseFromValue l _ -> stub @@ -269,7 +300,7 @@ fromValueMay = pure . \case - NVSet' s _ -> pure s + NVSet' _ s -> pure s _ -> mempty fromValue = fromMayToValue TSet @@ -281,19 +312,19 @@ fromValueMay = \case - Deeper (NVSet' s _) -> sequence <$> traverse fromValueMay s + Deeper (NVSet' _ s) -> traverseFromValue s _ -> stub fromValue = fromMayToDeeperValue TSet instance Convertible e t f m - => FromValue (AttrSet (NValue t f m), AttrSet SourcePos) m + => FromValue (AttrSet (NValue t f m), PositionSet) m (NValue' t f m (NValue t f m)) where fromValueMay = pure . \case - NVSet' s p -> pure (s, p) + NVSet' p s -> pure (s, p) _ -> mempty fromValue = fromMayToValue TSet @@ -301,12 +332,12 @@ instance ( Convertible e t f m , FromValue a m (NValue t f m) ) - => FromValue (AttrSet a, AttrSet SourcePos) m + => FromValue (AttrSet a, PositionSet) m (Deeper (NValue' t f m (NValue t f m))) where fromValueMay = \case - Deeper (NVSet' s p) -> fmap (, p) . sequence <$> traverse fromValueMay s + Deeper (NVSet' p s) -> (, p) <<$>> traverseFromValue s _ -> stub fromValue = fromMayToDeeperValue TSet @@ -325,93 +356,100 @@ class ToValue a m v where toValue :: a -> m v -instance (Convertible e t f m, ToValue a m (NValue' t f m (NValue t f m))) +instance (Convertible e t f m + , ToValue a m (NValue' t f m (NValue t f m)) + ) => ToValue a m (NValue t f m) where toValue v = Free <$> toValue v instance ( Convertible e t f m - , ToValue a m (Deeper (NValue' t f m (NValue t f m))) - ) + , ToValue a m (Deeper (NValue' t f m (NValue t f m))) + ) => ToValue a m (Deeper (NValue t f m)) where toValue v = Free <<$>> toValue v 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 . NVConstant' . 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 . NVConstant' . 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 . NVConstant' . 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 . NVConstant' . NFloat instance Convertible e t f m => ToValue NixString m (NValue' t f m (NValue t f m)) where - toValue = pure . nvStr' + toValue = pure . NVStr' instance Convertible e t f m => ToValue ByteString m (NValue' t f m (NValue t f m)) where - toValue = pure . nvStr' . makeNixStringWithoutContext . decodeUtf8 + toValue = pure . NVStr' . mkNixStringWithoutContext . decodeUtf8 instance Convertible e t f m + => ToValue Text m (NValue' t f m (NValue t f m)) where + toValue = pure . NVStr' . mkNixStringWithoutContext + +instance Convertible e t f m => ToValue Path m (NValue' t f m (NValue t f m)) where - toValue = pure . nvPath' . getPath + toValue = pure . NVPath' instance Convertible e t f m => ToValue StorePath m (NValue' t f m (NValue t f m)) where - toValue = toValue . Path . unStorePath + toValue = toValue @Path . coerce -instance ( Convertible e t f m - ) - => ToValue SourcePos m (NValue' t f m (NValue t f m)) where - toValue (SourcePos f l c) = do - f' <- toValue $ makeNixStringWithoutContext $ toText f - l' <- toValue $ unPos l - c' <- toValue $ unPos c - let pos = M.fromList [("file" :: Text, f'), ("line", l'), ("column", c')] - pure $ nvSet' mempty pos +instance Convertible e t f m + => ToValue NSourcePos m (NValue' t f m (NValue t f m)) where + toValue (NSourcePos f l c) = do + f' <- toValue $ mkNixStringWithoutContext $ fromString $ coerce f + l' <- toValue $ unPos $ coerce l + c' <- toValue $ unPos $ coerce c + let pos = M.fromList [("file" :: VarName, f'), ("line", l'), ("column", c')] + pure $ NVSet' 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 . NVList' -instance (Convertible e t f m, ToValue a m (NValue t f m)) +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' <$> traverse toValue l + toValue l = Deeper . NVList' <$> 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 $ NVSet' 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) - (traverse toValue s) + liftA2 (\ v s -> Deeper $ NVSet' s v) + (traverseToValue s) stub instance Convertible e t f m - => ToValue (AttrSet (NValue t f m), AttrSet SourcePos) 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 $ NVSet' p s instance (Convertible e t f m, ToValue a m (NValue t f m)) - => ToValue (AttrSet a, AttrSet SourcePos) 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) - (traverse toValue s) + liftA2 (\ v s -> Deeper $ NVSet' s v) + (traverseToValue s) (pure p) instance Convertible e t f m @@ -427,21 +465,21 @@ allOutputs <- g nlcvAllOutputs outputs <- do let - outputs = makeNixStringWithoutContext <$> nlcvOutputs nlcv + outputs = mkNixStringWithoutContext <$> nlcvOutputs nlcv - ts :: [NValue t f m] <- traverse toValue outputs - list + ts :: [NValue t f m] <- traverseToValue outputs + handlePresence (pure Nothing) (fmap pure . toValue) ts - pure $ nvSet' mempty $ M.fromList $ catMaybes + pure $ NVSet' 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 @@ -1,24 +1,23 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE PackageImports #-} -- 2021-07-05: Due to hashing Haskell IT system situation, in HNix we currently ended-up with 2 hash package dependencies @{hashing, cryptonite}@ +{-# language AllowAmbiguousTypes #-} +{-# language CPP #-} +{-# language DefaultSignatures #-} +{-# language TypeFamilies #-} +{-# language DataKinds #-} +{-# language GeneralizedNewtypeDeriving #-} +{-# language UndecidableInstances #-} +{-# language PackageImports #-} -- 2021-07-05: Due to hashing Haskell IT system situation, in HNix we currently ended-up with 2 hash package dependencies @{hashing, cryptonite}@ +{-# language TypeOperators #-} -{-# OPTIONS_GHC -Wno-orphans #-} +{-# options_ghc -Wno-orphans #-} module Nix.Effects where -import Prelude hiding ( traceM - , putStr - , putStrLn +import Nix.Prelude hiding ( putStrLn , print ) -import qualified Prelude -import Nix.Utils +import qualified Nix.Prelude as Prelude +import GHC.Exception ( ErrorCall(ErrorCall) ) import qualified Data.HashSet as HS import qualified Data.Text as Text import Network.HTTP.Client hiding ( path, Proxy ) @@ -26,23 +25,22 @@ import Network.HTTP.Types import qualified "cryptonite" Crypto.Hash as Hash import Nix.Utils.Fix1 -import Nix.Expr +import Nix.Expr.Types.Annotated import Nix.Frames hiding ( Proxy ) import Nix.Parser import Nix.Render import Nix.Value import qualified Paths_hnix import System.Exit -import qualified System.Environment as Env -import System.FilePath ( takeFileName ) import qualified System.Info import System.Process import qualified System.Nix.Store.Remote as Store.Remote import qualified System.Nix.StorePath as Store +import qualified System.Nix.Nar as Store.Nar -- | A path into the nix store -newtype StorePath = StorePath { unStorePath :: FilePath } +newtype StorePath = StorePath Path -- All of the following type classes defer to the underlying 'm'. @@ -62,16 +60,15 @@ ) => MonadEffects t f m where - -- | Determine the absolute path of relative path in the current context - makeAbsolutePath :: FilePath -> m FilePath - findEnvPath :: String -> m FilePath + -- | Determine the absolute path in the current context. + toAbsolutePath :: Path -> m Path + findEnvPath :: String -> m Path - -- | Having an explicit list of sets corresponding to the NIX_PATH - -- and a file path try to find an existing path - findPath :: [NValue t f m] -> FilePath -> m FilePath + -- | Having an explicit list of sets corresponding to the @NIX_PATH@ and a file path try to find an existing path. + findPath :: [NValue t f m] -> Path -> m Path - importPath :: FilePath -> m (NValue t f m) - pathToDefaultNix :: FilePath -> m FilePath + importPath :: Path -> m (NValue t f m) + pathToDefaultNix :: Path -> m Path derivationStrict :: NValue t f m -> m (NValue t f m) @@ -108,7 +105,7 @@ #ifdef MIN_VERSION_ghc_datasize recursiveSize #else - \_ -> pure 0 + const $ pure 0 #endif deriving @@ -140,9 +137,9 @@ exec' = \case [] -> pure $ Left $ ErrorCall "exec: missing program" (prog : args) -> do - (exitCode, out, _) <- liftIO $ readProcessWithExitCode (toString prog) (toString <$> args) "" + (exitCode, out, _) <- liftIO $ readProcessWithExitCode (toString prog) (toString <$> args) mempty let - t = Text.strip $ toText out + t = Text.strip $ fromString out emsg = "program[" <> prog <> "] args=" <> show args case exitCode of ExitSuccess -> @@ -191,7 +188,7 @@ readProcessWithExitCode "nix-instantiate" ["--eval", "--expr", toString expr] - "" + mempty pure $ case exitCode of @@ -199,7 +196,7 @@ either (\ e -> Left $ ErrorCall $ "Error parsing output of nix-instantiate: " <> show e) pure - (parseNixTextLoc $ toText out) + (parseNixTextLoc $ fromString out) status -> Left $ ErrorCall $ "nix-instantiate failed: " <> show status <> ": " <> err deriving @@ -235,12 +232,12 @@ -- ** Instances instance MonadEnv IO where - getEnvVar = (<<$>>) toText . Env.lookupEnv . toString + getEnvVar = (<<$>>) fromString . lookupEnv . toString - getCurrentSystemOS = pure $ toText System.Info.os + getCurrentSystemOS = pure $ fromString System.Info.os -- Invert the conversion done by GHC_CONVERT_CPU in GHC's aclocal.m4 - getCurrentSystemArch = pure $ toText $ case System.Info.arch of + getCurrentSystemArch = pure $ fromString $ case System.Info.arch of "i386" -> "i686" arch -> arch @@ -260,15 +257,15 @@ class Monad m => MonadPaths m where - getDataDir :: m FilePath - default getDataDir :: (MonadTrans t, MonadPaths m', m ~ t m') => m FilePath + getDataDir :: m Path + default getDataDir :: (MonadTrans t, MonadPaths m', m ~ t m') => m Path getDataDir = lift getDataDir -- ** Instances instance MonadPaths IO where - getDataDir = Paths_hnix.getDataDir + getDataDir = coerce Paths_hnix.getDataDir deriving instance @@ -291,29 +288,39 @@ default getURL :: (MonadTrans t, MonadHttp m', m ~ t m') => Text -> m (Either ErrorCall StorePath) getURL = lift . getURL +baseNameOf :: Text -> Text +baseNameOf a = Text.takeWhileEnd (/='/') $ Text.dropWhileEnd (=='/') a +-- conversion from Store.StorePath to Effects.StorePath, different type with the same name. +toStorePath :: Store.StorePath -> StorePath +toStorePath = StorePath . coerce . decodeUtf8 @FilePath @ByteString . Store.storePathToRawFilePath + -- ** Instances instance MonadHttp IO where - getURL url = do - let urlstr = toString url - traceM $ "fetching HTTP URL: " <> urlstr - req <- parseRequest urlstr - manager <- - if secure req - then newTlsManager - else newManager defaultManagerSettings - -- print req - response <- httpLbs (req { method = "GET" }) manager - let status = statusCode $ responseStatus response - pure $ Left $ ErrorCall $ if status /= 200 - then - "fail, got " <> show status <> " when fetching url:" <> urlstr - else - -- do - -- let bstr = responseBody response - "success in downloading but hnix-store is not yet ready; url = " <> urlstr + getURL url = + do + let urlstr = toString url + traceM $ "fetching HTTP URL: " <> urlstr + req <- parseRequest urlstr + manager <- + bool + (newManager defaultManagerSettings) + newTlsManager + (secure req) + response <- httpLbs (req { method = "GET" }) manager + let status = statusCode $ responseStatus response + let body = responseBody response + -- let digest::Hash.Digest Hash.SHA256 = Hash.hash $ (B.concat . BL.toChunks) body + let name = baseNameOf url + bool + (pure $ Left $ ErrorCall $ "fail, got " <> show status <> " when fetching url = " <> urlstr) + -- using addTextToStore' result in different hash from the addToStore. + -- see https://github.com/haskell-nix/hnix/pull/1051#issuecomment-1031380804 + (addToStore name (NarText $ toStrict body) False False) + (status == 200) + deriving instance MonadHttp (t (Fix1 t)) @@ -328,7 +335,7 @@ -- * @class MonadPutStr m@ class - Monad m + (Monad m, MonadIO m) => MonadPutStr m where --TODO: Should this be used *only* when the Nix to be evaluated invokes a @@ -336,7 +343,7 @@ -- 2021-04-01: Due to trace operation here, leaving it as String. putStr :: String -> m () default putStr :: (MonadTrans t, MonadPutStr m', m ~ t m') => String -> m () - putStr = lift . putStr + putStr = lift . Prelude.putStr -- ** Instances @@ -358,7 +365,7 @@ -- ** Functions putStrLn :: MonadPutStr m => String -> m () -putStrLn = putStr . (<> "\n") +putStrLn = Nix.Effects.putStr . (<> "\n") print :: (MonadPutStr m, Show a) => a -> m () print = putStrLn . show @@ -370,20 +377,27 @@ type RecursiveFlag = Bool type RepairFlag = Bool type StorePathName = Text -type FilePathFilter m = FilePath -> m Bool +type PathFilter m = Path -> m Bool type StorePathSet = HS.HashSet StorePath + -- ** @class MonadStore m@ +data NarContent = NarFile Path | NarText ByteString +-- | convert NarContent to NarSource needed in the store API +toNarSource :: MonadIO m => NarContent -> Store.Nar.NarSource m +toNarSource (NarFile path) = Store.Nar.dumpPath $ coerce path +toNarSource (NarText text) = Store.Nar.dumpString text + class Monad m => MonadStore m where - -- | Copy the contents of a local path to the store. The resulting store + -- | Copy the contents of a local path(Or pure text) to the store. The resulting store -- path is returned. Note: This does not support yet support the expected -- `filter` function that allows excluding some files. - addToStore :: StorePathName -> FilePath -> RecursiveFlag -> RepairFlag -> m (Either ErrorCall StorePath) - default addToStore :: (MonadTrans t, MonadStore m', m ~ t m') => StorePathName -> FilePath -> RecursiveFlag -> RepairFlag -> m (Either ErrorCall StorePath) + addToStore :: StorePathName -> NarContent -> RecursiveFlag -> RepairFlag -> m (Either ErrorCall StorePath) + default addToStore :: (MonadTrans t, MonadStore m', m ~ t m') => StorePathName -> NarContent -> RecursiveFlag -> RepairFlag -> m (Either ErrorCall StorePath) addToStore a b c d = lift $ addToStore a b c d -- | Like addToStore, but the contents written to the output path is a @@ -397,16 +411,15 @@ instance MonadStore IO where - addToStore name path recursive repair = + addToStore name content recursive repair = either (\ err -> pure $ Left $ ErrorCall $ "String '" <> show name <> "' is not a valid path name: " <> err) (\ pathName -> do - -- TODO: redesign the filter parameter - res <- Store.Remote.runStore $ Store.Remote.addToStore @Hash.SHA256 pathName path recursive (const False) repair + res <- Store.Remote.runStore $ Store.Remote.addToStore @Hash.SHA256 pathName (toNarSource content) recursive repair either Left -- err - (pure . StorePath . decodeUtf8 . Store.storePathToRawFilePath) -- store path + (pure . toStorePath) -- store path <$> parseStoreResult "addToStore" res ) (Store.makeStorePathName name) @@ -416,20 +429,19 @@ res <- Store.Remote.runStore $ Store.Remote.addTextToStore name text references repair either Left -- err - (pure . StorePath . decodeUtf8 . Store.storePathToRawFilePath) -- path + (pure . toStorePath) -- path <$> parseStoreResult "addTextToStore" res -- ** Functions parseStoreResult :: Monad m => Text -> (Either String a, [Store.Remote.Logger]) -> m (Either ErrorCall a) -parseStoreResult name res = - pure $ either - (\ msg -> Left $ ErrorCall $ "Failed to execute '" <> toString name <> "': " <> msg <> "\n" <> show logs) - pure -- result - (fst res) - where - logs = snd res +parseStoreResult name (res, logs) = + pure $ + either + (\ msg -> Left $ ErrorCall $ "Failed to execute '" <> toString name <> "': " <> msg <> "\n" <> show logs) + pure + res addTextToStore :: (Framed e m, MonadStore m) => StorePathName -> Text -> Store.StorePathSet -> RepairFlag -> m StorePath addTextToStore a b c d = @@ -438,12 +450,14 @@ pure =<< addTextToStore' a b c d -addPath :: (Framed e m, MonadStore m) => FilePath -> m StorePath +-- 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 throwError pure - =<< addToStore (toText $ takeFileName p) p True False + =<< addToStore (fromString $ coerce takeFileName p) (NarFile p) True False -toFile_ :: (Framed e m, MonadStore m) => FilePath -> String -> m StorePath -toFile_ p contents = addTextToStore (toText p) (toText contents) mempty False +toFile_ :: (Framed e m, MonadStore m) => Path -> Text -> m StorePath +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 @@ -1,27 +1,24 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} +{-# language CPP #-} module Nix.Effects.Basic where -import Prelude hiding ( traceM - , head +import Nix.Prelude hiding ( head ) import Relude.Unsafe ( head ) -import Nix.Utils +import GHC.Exception ( ErrorCall(ErrorCall) ) import Control.Monad ( foldM ) import qualified Data.HashMap.Lazy as M import Data.List.Split ( splitOn ) import qualified Data.Text as Text import Prettyprinter ( fillSep ) -import System.FilePath import Nix.Convert import Nix.Effects import Nix.Exec ( MonadNix , evalExprLoc , nixInstantiateExpr ) -import Nix.Expr +import Nix.Expr.Types +import Nix.Expr.Types.Annotated import Nix.Frames import Nix.Parser import Nix.Render @@ -34,137 +31,134 @@ import GHC.DataSize #endif -defaultMakeAbsolutePath :: MonadNix e t f m => FilePath -> m FilePath -defaultMakeAbsolutePath origPath = do - origPathExpanded <- expandHomePath origPath - absPath <- - bool - (do - cwd <- do - mres <- lookupVar "__cur_file" - maybe - getCurrentDirectory - ( - (\case - NVPath s -> pure $ takeDirectory s - val -> throwError $ ErrorCall $ "when resolving relative path, __cur_file is in scope, but is not a path; it is: " <> show val - ) <=< demand + + + +defaultToAbsolutePath :: forall e t f m . MonadNix e t f m => Path -> m Path +defaultToAbsolutePath origPath = + do + origPathExpanded <- expandHomePath origPath + fmap + removeDotDotIndirections + . canonicalizePath + =<< bool + (fmap + ( origPathExpanded) + $ maybe + getCurrentDirectory + ( (\case + NVPath s -> pure $ takeDirectory s + val -> throwError $ ErrorCall $ "when resolving relative path, __cur_file is in scope, but is not a path; it is: " <> show val + ) <=< demand + ) + =<< lookupVar "__cur_file" ) - mres - pure $ cwd origPathExpanded - ) - (pure origPathExpanded) - (isAbsolute origPathExpanded) - removeDotDotIndirections <$> canonicalizePath absPath + (pure origPathExpanded) + (isAbsolute origPathExpanded) -expandHomePath :: MonadFile m => FilePath -> m FilePath -expandHomePath ('~' : xs) = (<> xs) <$> getHomeDirectory +expandHomePath :: MonadFile m => Path -> m Path +expandHomePath (coerce -> ('~' : xs)) = (<> coerce xs) <$> getHomeDirectory expandHomePath p = pure p -- | Incorrectly normalize paths by rewriting patterns like @a/b/..@ to @a@. -- This is incorrect on POSIX systems, because if @b@ is a symlink, its -- parent may be a different directory from @a@. See the discussion at -- https://hackage.haskell.org/package/directory-1.3.1.5/docs/System-Directory.html#v:canonicalizePath -removeDotDotIndirections :: FilePath -> FilePath -removeDotDotIndirections = intercalate "/" . go mempty . splitOn "/" +removeDotDotIndirections :: Path -> Path +removeDotDotIndirections = coerce . intercalate "/" . go mempty . splitOn "/" . coerce where go s [] = reverse s go (_ : s) (".." : rest) = go s rest go s (this : rest) = go (this : s) rest infixr 9 -() :: FilePath -> FilePath -> FilePath -x y | isAbsolute y || "." `isPrefixOf` y = x y - | otherwise = joinByLargestOverlap x y +() :: Path -> Path -> Path +x y + | isAbsolute y || "." `isPrefixOf` coerce y = x y + | otherwise = joinByLargestOverlap x y where + joinByLargestOverlap :: Path -> Path -> Path joinByLargestOverlap (splitDirectories -> xs) (splitDirectories -> ys) = joinPath $ head [ xs <> drop (length tx) ys | tx <- tails xs, tx `elem` inits ys ] -defaultFindEnvPath :: MonadNix e t f m => String -> m FilePath -defaultFindEnvPath = findEnvPathM - -findEnvPathM :: forall e t f m . MonadNix e t f m => FilePath -> m FilePath -findEnvPathM name = do - mres <- lookupVar "__nixPath" +defaultFindEnvPath :: MonadNix e t f m => String -> m Path +defaultFindEnvPath = findEnvPathM . coerce +findEnvPathM :: forall e t f m . MonadNix e t f m => Path -> m Path +findEnvPathM name = maybe (fail "impossible") - ( - (\ nv -> - do - (l :: [NValue t f m]) <- fromValue nv - findPathBy nixFilePath l name - ) <=< demand + (\ v -> + do + l <- fromValue @[NValue t f m] =<< demand v + findPathBy nixFilePath l name ) - mres + =<< lookupVar "__nixPath" where - nixFilePath :: MonadEffects t f m => FilePath -> m (Maybe FilePath) - nixFilePath path = do - absPath <- makeAbsolutePath @t @f path - isDir <- doesDirectoryExist absPath - absFile <- - bool - (pure absPath) - (makeAbsolutePath @t @f $ absPath "default.nix") - isDir - exists <- doesFileExist absFile - pure $ - bool - mempty - (pure absFile) - exists + nixFilePath :: MonadEffects t f m => Path -> m (Maybe Path) + nixFilePath path = + do + absPath <- toAbsolutePath @t @f path + isDir <- doesDirectoryExist absPath + absFile <- + bool + (pure absPath) + (toAbsolutePath @t @f $ absPath "default.nix") + isDir + (pure absFile `whenTrue`) <$> doesFileExist absFile + findPathBy :: forall e t f m . MonadNix e t f m - => (FilePath -> m (Maybe FilePath)) + => (Path -> m (Maybe Path)) -> [NValue t f m] - -> FilePath - -> m FilePath -findPathBy finder ls name = do - mpath <- foldM go mempty ls + -> Path + -> m Path +findPathBy finder ls name = maybe - (throwError $ ErrorCall $ "file '" <> name <> "' was not found in the Nix search path (add it's using $NIX_PATH or -I)") + (throwError $ ErrorCall $ "file ''" <> coerce name <> "'' was not found in the Nix search path (add it's using $NIX_PATH or -I)") pure - mpath + =<< foldM fun mempty ls where - go :: Maybe FilePath -> NValue t f m -> m (Maybe FilePath) - go mp = + fun + :: MonadNix e t f m + => Maybe Path + -> NValue t f m + -> m (Maybe Path) + fun = maybe (\ nv -> do - (s :: HashMap Text (NValue t f m)) <- fromValue =<< demand nv + (s :: HashMap VarName (NValue t f m)) <- fromValue =<< demand nv p <- resolvePath s - nvpath <- demand p - (Path path) <- fromValue nvpath + path <- fromValue =<< demand p maybe (tryPath path mempty) (\ nv' -> do - mns <- fromValueMay =<< demand nv' + mns <- fromValueMay @NixString =<< demand nv' tryPath path $ - case mns of - Just (nsPfx :: NixString) -> - let pfx = stringIgnoreContext nsPfx in - bool - mempty - (pure (toString pfx)) - (not $ Text.null pfx) - _ -> mempty + whenJust + (\ nsPfx -> + let pfx = ignoreContext nsPfx in + pure $ coerce $ toString pfx `whenFalse` Text.null pfx + ) + mns ) (M.lookup "prefix" s) ) (const . pure . pure) - mp - tryPath :: FilePath -> Maybe FilePath -> m (Maybe FilePath) + tryPath :: Path -> Maybe Path -> m (Maybe Path) tryPath p (Just n) | n' : ns <- splitDirectories name, n == n' = finder $ p joinPath ns tryPath p _ = finder $ p name + resolvePath :: HashMap VarName (NValue t f m) -> m (NValue t f m) resolvePath s = maybe (maybe @@ -176,22 +170,29 @@ (M.lookup "path" s) fetchTarball - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> m (NValue t f m) fetchTarball = \case - NVSet s _ -> + NVSet _ s -> maybe (throwError $ ErrorCall "builtins.fetchTarball: Missing url attribute") - (go (M.lookup "sha256" s) <=< demand) + (fetchFromString (M.lookup "sha256" s) <=< demand) (M.lookup "url" s) - v@NVStr{} -> go Nothing v + v@NVStr{} -> fetchFromString Nothing v v -> throwError $ ErrorCall $ "builtins.fetchTarball: Expected URI or set, got " <> show v <=< demand where - go :: Maybe (NValue t f m) -> NValue t f m -> m (NValue t f m) - go msha = \case - NVStr ns -> fetch (stringIgnoreContext ns) msha - v -> throwError $ ErrorCall $ "builtins.fetchTarball: Expected URI or string, got " <> show v + fetchFromString + :: Maybe (NValue t f m) + -> NValue t f m + -> m (NValue t f m) + fetchFromString msha = + \case + 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 fetch :: Text -> Maybe (NThunk m) -> m (NValue t f m) @@ -206,68 +207,73 @@ -} fetch :: Text -> Maybe (NValue t f m) -> m (NValue t f m) - fetch uri Nothing = - nixInstantiateExpr $ "builtins.fetchTarball \"" <> uri <> "\"" - fetch url (Just t) = - (\nv -> do - nsSha <- fromValue nv + fetch uri = + maybe + (nixInstantiateExpr $ + "builtins.fetchTarball \"" <> uri <> "\"" + ) + (\ v -> + do + nsSha <- fromValue =<< demand v - let sha = stringIgnoreContext nsSha + let sha = ignoreContext nsSha - nixInstantiateExpr - $ "builtins.fetchTarball { " <> "url = \"" <> url <> "\"; " <> "sha256 = \"" <> sha <> "\"; }" - ) =<< demand t + nixInstantiateExpr $ + "builtins.fetchTarball { " <> "url = \"" <> uri <> "\"; " <> "sha256 = \"" <> sha <> "\"; }" + ) -defaultFindPath :: MonadNix e t f m => [NValue t f m] -> FilePath -> m FilePath +defaultFindPath :: MonadNix e t f m => [NValue t f m] -> Path -> m Path defaultFindPath = findPathM findPathM :: forall e t f m . MonadNix e t f m => [NValue t f m] - -> FilePath - -> m FilePath + -> Path + -> m Path findPathM = findPathBy existingPath where - existingPath :: MonadEffects t f m => FilePath -> m (Maybe FilePath) + existingPath :: MonadEffects t f m => Path -> m (Maybe Path) existingPath path = do - apath <- makeAbsolutePath @t @f path + apath <- toAbsolutePath @t @f path doesExist <- doesPathExist apath pure $ pure apath `whenTrue` doesExist defaultImportPath - :: (MonadNix e t f m, MonadState (HashMap FilePath NExprLoc, b) m) - => FilePath + :: (MonadNix e t f m, MonadState (HashMap Path NExprLoc, b) m) + => Path -> m (NValue t f m) -defaultImportPath path = do - traceM $ "Importing file " <> path - withFrame Info (ErrorCall $ "While importing file " <> show path) $ do - imports <- gets fst - evalExprLoc =<< - maybe - (do - eres <- parseNixFileLoc path - either - (\ err -> throwError $ ErrorCall . show $ fillSep ["Parse during import failed:", err]) - (\ expr -> - do - modify (first (M.insert path expr)) - pure expr +defaultImportPath path = + do + traceM $ "Importing file " <> coerce path + withFrame + Info + (ErrorCall $ "While importing file " <> show path) + $ evalExprLoc =<< + (maybe + (either + (\ err -> throwError $ ErrorCall . show $ fillSep ["Parse during import failed:", err]) + (\ expr -> + do + modify $ first $ M.insert path expr + pure expr + ) + =<< parseNixFileLoc path ) - eres - ) - pure -- return expr - (M.lookup path imports) + pure -- return expr + . M.lookup path + ) =<< gets fst -defaultPathToDefaultNix :: MonadNix e t f m => FilePath -> m FilePath +defaultPathToDefaultNix :: MonadNix e t f m => Path -> m Path defaultPathToDefaultNix = pathToDefaultNixFile -- Given a path, determine the nix file to load -pathToDefaultNixFile :: MonadFile m => FilePath -> m FilePath -pathToDefaultNixFile p = do - isDir <- doesDirectoryExist p - pure $ p "default.nix" `whenTrue` isDir +pathToDefaultNixFile :: MonadFile m => Path -> m Path +pathToDefaultNixFile p = + do + isDir <- doesDirectoryExist p + pure $ p "default.nix" `whenTrue` isDir defaultTraceEffect :: MonadPutStr m => String -> m () defaultTraceEffect = Nix.Effects.putStrLn 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 @@ -1,12 +1,12 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE PackageImports #-} -- 2021-07-05: Due to hashing Haskell IT system situation, in HNix we currently ended-up with 2 hash package dependencies @{hashing, cryptonite}@ +{-# language DataKinds #-} +{-# language NamedFieldPuns #-} +{-# language RecordWildCards #-} +{-# language PackageImports #-} -- 2021-07-05: Due to hashing Haskell IT system situation, in HNix we currently ended-up with 2 hash package dependencies @{hashing, cryptonite}@ module Nix.Effects.Derivation ( defaultDerivationStrict ) where -import Nix.Utils +import Nix.Prelude hiding ( readFile ) +import GHC.Exception ( ErrorCall(ErrorCall) ) import Data.Char ( isAscii , isAlphaNum ) @@ -24,13 +24,14 @@ import qualified "cryptonite" Crypto.Hash as Hash -- 2021-07-05: Attrocity of Haskell hashing situation, in HNix we ended-up with 2 hash package dependencies @{hashing, cryptonite}@ import Nix.Atoms +import Nix.Expr.Types hiding ( Recursive ) import Nix.Convert import Nix.Effects import Nix.Exec ( MonadNix , callFunc ) import Nix.Frames -import Nix.Json ( nvalueToJSONNixString ) +import Nix.Json ( toJSONNixString ) import Nix.Render import Nix.String import Nix.String.Coerce @@ -40,9 +41,9 @@ import qualified System.Nix.ReadonlyStore as Store import qualified System.Nix.Hash as Store import qualified System.Nix.StorePath as Store -import Prelude hiding (readFile) +-- 2021-07-17: NOTE: Derivation consists of @"keys"@ @"vals"@ (of text), so underlining type boundary currently stops here. data Derivation = Derivation { name :: Text , outputs :: Map Text Text @@ -75,11 +76,11 @@ let (inputSrcs, inputDrvs) = inputs references <- Set.fromList <$> traverse parsePath (Set.toList $ inputSrcs <> Set.fromList (Map.keys inputDrvs)) path <- addTextToStore (Text.append name ".drv") (unparseDrv drv) (S.fromList $ Set.toList references) False - parsePath $ toText $ unStorePath path + parsePath $ fromString $ coerce path -- | Traverse the graph of inputDrvs to replace fixed output derivations with their fixed output hash. -- this avoids propagating changes to their .drv when the output hash stays the same. -hashDerivationModulo :: (MonadNix e t f m, MonadState (b, AttrSet Text) m) => Derivation -> m (Hash.Digest Hash.SHA256) +hashDerivationModulo :: (MonadNix e t f m, MonadState (b, KeyMap Text) m) => Derivation -> m (Hash.Digest Hash.SHA256) hashDerivationModulo Derivation { mFixed = Just (Store.SomeDigest (digest :: Hash.Digest hashType)) @@ -91,7 +92,7 @@ Hash.hash @ByteString @Hash.SHA256 $ encodeUtf8 $ "fixed:out" - <> (if hashMode == Recursive then ":r" else "") + <> (if hashMode == Recursive then ":r" else mempty) <> ":" <> (Store.algoName @hashType) <> ":" <> Store.encodeDigestWith Store.Base16 digest <> ":" <> path @@ -110,7 +111,7 @@ (\(path, outs) -> maybe (do - drv' <- readDerivation $ toString path + drv' <- readDerivation $ coerce $ toString path hash <- Store.encodeDigestWith Store.Base16 <$> hashDerivationModulo drv' pure (hash, outs) ) @@ -144,7 +145,7 @@ ] where produceOutputInfo (outputName, outputPath) = - let prefix = if hashMode == Recursive then "r:" else "" in + let prefix = if hashMode == Recursive then "r:" else mempty in parens $ (s <$>) $ ([outputName, outputPath] <>) $ maybe [mempty, mempty] @@ -168,13 +169,13 @@ escape '\t' = "\\t" escape c = one c -readDerivation :: (Framed e m, MonadFile m) => FilePath -> m Derivation +readDerivation :: (Framed e m, MonadFile m) => Path -> m Derivation readDerivation path = do - content <- decodeUtf8 <$> readFile path + content <- readFile path either (\ err -> throwError $ ErrorCall $ "Failed to parse " <> show path <> ":\n" <> show err) pure - (parse derivationParser path content) + (parse derivationParser (coerce path) content) derivationParser :: Parsec () Text Derivation derivationParser = do @@ -199,13 +200,13 @@ let outputs = Map.fromList $ (\(a, b, _, _) -> (a, b)) <$> fullOutputs let (mFixed, hashMode) = parseFixed fullOutputs - let name = "" -- FIXME (extract from file path ?) - let useJson = ["__json"] == Map.keys env + let name = mempty -- FIXME (extract from file path ?) + let useJson = one "__json" == Map.keys env pure $ Derivation {inputs = (inputSrcs, inputDrvs), ..} where s :: Parsec () Text Text - s = fmap toText $ string "\"" *> manyTill (escaped <|> regular) (string "\"") + s = fmap fromString $ string "\"" *> manyTill (escaped <|> regular) (string "\"") escaped = char '\\' *> ( '\n' <$ string "n" <|> '\r' <$ string "r" @@ -218,12 +219,13 @@ string o *> sepBy p (string ",") <* string c parens :: Parsec () Text a -> Parsec () Text [a] - parens p = wrap "(" ")" p - serializeList p = wrap "[" "]" p + parens = wrap "(" ")" + serializeList :: Parsec () Text a -> Parsec () Text [a] + serializeList = wrap "[" "]" parseFixed :: [(Text, Text, Text, Text)] -> (Maybe Store.SomeNamedDigest, HashMode) parseFixed fullOutputs = case fullOutputs of - [("out", _path, rht, hash)] | rht /= "" && hash /= "" -> + [("out", _path, rht, hash)] | rht /= mempty && hash /= mempty -> let (hashType, hashMode) = case Text.splitOn ":" rht of ["r", ht] -> (ht, Recursive) @@ -238,9 +240,9 @@ _ -> (Nothing, Flat) -defaultDerivationStrict :: forall e t f m b. (MonadNix e t f m, MonadState (b, AttrSet Text) m) => NValue t f m -> m (NValue t f m) +defaultDerivationStrict :: forall e t f m b. (MonadNix e t f m, MonadState (b, KeyMap Text) m) => NValue t f m -> m (NValue t f m) defaultDerivationStrict val = do - s <- fromValue @(AttrSet (NValue t f m)) val + s <- M.mapKeys coerce <$> fromValue @(AttrSet (NValue t f m)) val (drv, ctx) <- runWithStringContextT' $ buildDerivationWithContext s drvName <- makeStorePathName $ name drv let @@ -266,57 +268,61 @@ ifNotJsonModEnv (\ baseEnv -> foldl' - (\m k -> Map.insert k "" m) + (\m k -> Map.insert k mempty m) baseEnv (Map.keys $ outputs drv) ) } - outputs' <- sequence $ Map.mapWithKey (\o _ -> makeOutputPath o hash drvName) $ outputs drv + outputs' <- sequenceA $ Map.mapWithKey (\o _ -> makeOutputPath o hash drvName) $ outputs drv pure $ drv { inputs , outputs = outputs' - , env = ifNotJsonModEnv $ (outputs' <>) + , env = ifNotJsonModEnv (outputs' <>) } - drvPath <- pathToText <$> writeDerivation drv' + (coerce @Text @VarName -> drvPath) <- pathToText <$> writeDerivation drv' -- Memoize here, as it may be our last chance in case of readonly stores. drvHash <- Store.encodeDigestWith Store.Base16 <$> hashDerivationModulo drv' - modify $ second $ MS.insert drvPath drvHash + modify $ second $ MS.insert (coerce drvPath) drvHash let outputsWithContext = Map.mapWithKey - (\out path -> makeNixStringWithSingletonContext path $ StringContext drvPath $ DerivationOutput out) + (\out (coerce -> path) -> mkNixStringWithSingletonContext (StringContext (DerivationOutput out) drvPath) path) (outputs drv') - drvPathWithContext = makeNixStringWithSingletonContext drvPath $ StringContext drvPath AllOutputs - attrSet = nvStr <$> M.fromList (("drvPath", drvPathWithContext) : Map.toList outputsWithContext) + drvPathWithContext = mkNixStringWithSingletonContext (StringContext AllOutputs drvPath) drvPath + attrSet = NVStr <$> M.fromList (("drvPath", drvPathWithContext) : Map.toList outputsWithContext) -- TODO: Add location information for all the entries. -- here --v - pure $ nvSet mempty attrSet + pure $ NVSet mempty $ M.mapKeys coerce attrSet where pathToText = decodeUtf8 . Store.storePathToRawFilePath makeOutputPath o h n = do - name <- makeStorePathName $ Store.unStorePathName n <> if o == "out" then "" else "-" <> o + name <- makeStorePathName $ Store.unStorePathName n <> if o == "out" then mempty else "-" <> o pure $ pathToText $ Store.makeStorePath "/nix/store" ("output:" <> encodeUtf8 o) h name - toStorePaths ctx = foldl (flip addToInputs) (mempty, mempty) ctx - addToInputs (StringContext path kind) = case kind of - DirectPath -> first (Set.insert path) - DerivationOutput o -> second (Map.insertWith (<>) path [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." + toStorePaths :: HashSet StringContext -> (Set Text, Map Text [Text]) + toStorePaths = foldl (flip addToInputs) mempty + addToInputs :: Bifunctor p => StringContext -> p (Set Text) (Map Text [Text]) -> p (Set Text) (Map Text [Text]) + 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. -- This is complex from a typing standpoint, but it allows to perform the -- full computation without worrying too much about all the string's contexts. -buildDerivationWithContext :: forall e t f m. (MonadNix e t f m) => AttrSet (NValue t f m) -> WithStringContextT m Derivation +buildDerivationWithContext :: forall e t f m. (MonadNix e t f m) => KeyMap (NValue t f m) -> WithStringContextT m Derivation buildDerivationWithContext drvAttrs = do -- Parse name first, so we can add an informative frame drvName <- getAttr "name" $ assertDrvStoreName <=< extractNixString @@ -330,13 +336,13 @@ platform <- getAttr "system" $ assertNonNull <=< extractNoCtx mHash <- getAttrOr "outputHash" mempty $ (pure . pure) <=< extractNoCtx hashMode <- getAttrOr "outputHashMode" Flat $ parseHashMode <=< extractNoCtx - outputs <- getAttrOr "outputs" ["out"] $ traverse (extractNoCtx <=< fromValue') + outputs <- getAttrOr "outputs" (one "out") $ traverse (extractNoCtx <=< fromValue') mFixedOutput <- maybe (pure Nothing) (\ hash -> do - when (outputs /= ["out"]) $ lift $ throwError $ ErrorCall "Multiple outputs are not supported for fixed-output derivations" + when (outputs /= one "out") $ lift $ throwError $ ErrorCall "Multiple outputs are not supported for fixed-output derivations" hashType <- getAttr "outputHashAlgo" extractNoCtx digest <- lift $ either (throwError . ErrorCall) pure $ Store.mkNamedDigest hashType hash pure $ pure digest) @@ -362,19 +368,19 @@ env <- if useJson then do - jsonString :: NixString <- lift $ nvalueToJSONNixString $ nvSet mempty $ + jsonString :: NixString <- lift $ toJSONNixString $ NVSet 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 , name = drvName , outputs = Map.fromList $ (, mempty) <$> outputs , mFixed = mFixedOutput - , inputs = (mempty, mempty) -- stub for now + , inputs = mempty -- stub for now } where @@ -386,7 +392,7 @@ withFrame' :: (Framed e m, Exception s) => NixLevel -> s -> WithStringContextT m a -> WithStringContextT m a withFrame' level f = join . lift . withFrame level f . pure - -- shortcuts to get the (forced) value of an AttrSet field + -- shortcuts to get the (forced) value of an KeyMap field getAttrOr' :: forall v a. (MonadNix e t f m, FromValue v m (NValue' t f m (NValue t f m))) => Text -> m a -> (v -> WithStringContextT m a) -> WithStringContextT m a @@ -395,7 +401,7 @@ Just v -> withFrame' Info (ErrorCall $ "While evaluating attribute '" <> show n <> "'") $ f =<< fromValue' v - getAttrOr n d f = getAttrOr' n (pure d) f + getAttrOr n = getAttrOr' n . pure getAttr n = getAttrOr' n (throwError $ ErrorCall $ "Required attribute '" <> show n <> "' not found.") @@ -431,6 +437,6 @@ -- Other helpers - deleteKeys :: [Text] -> AttrSet a -> AttrSet a + deleteKeys :: [Text] -> KeyMap a -> KeyMap a deleteKeys keys attrSet = foldl' (flip M.delete) attrSet keys diff --git a/src/Nix/Eval.hs b/src/Nix/Eval.hs --- a/src/Nix/Eval.hs +++ b/src/Nix/Eval.hs @@ -1,38 +1,39 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - +{-# language AllowAmbiguousTypes #-} +{-# language ConstraintKinds #-} +{-# language RankNTypes #-} module Nix.Eval where +import Nix.Prelude +import Relude.Extra ( set ) import Control.Monad ( foldM ) import Control.Monad.Fix ( MonadFix ) +import GHC.Exception ( ErrorCall(ErrorCall) ) import Data.Semialign.Indexed ( ialignWith ) import qualified Data.HashMap.Lazy as M import Data.List ( partition ) import Data.These ( These(..) ) import Nix.Atoms import Nix.Convert -import Nix.Expr +import Nix.Expr.Types +import Nix.Expr.Types.Annotated import Nix.Expr.Strings ( runAntiquoted ) import Nix.Frames import Nix.String import Nix.Scope -import Nix.Utils import Nix.Value.Monad class (Show v, Monad m) => MonadEval v m where - freeVariable :: Text -> m v - synHole :: Text -> m v - attrMissing :: NonEmpty Text -> Maybe v -> m v - evaledSym :: Text -> v -> m v + freeVariable :: VarName -> m v + synHole :: VarName -> m v + attrMissing :: NonEmpty VarName -> Maybe v -> m v + evaledSym :: VarName -> v -> m v evalCurPos :: m v evalConstant :: NAtom -> m v evalString :: NString (m v) -> m v - evalLiteralPath :: FilePath -> m v - evalEnvPath :: FilePath -> m v + evalLiteralPath :: Path -> m v + evalEnvPath :: Path -> m v evalUnary :: NUnaryOp -> v -> m v evalBinary :: NBinaryOp -> v -> m v -> m v -- ^ The second argument is an action because operators such as boolean && @@ -60,9 +61,9 @@ evalListElem :: [m v] -> Int -> m v -> m v evalList :: [v] -> m v evalSetElem :: AttrSet (m v) -> Text -> m v -> m v - evalSet :: AttrSet v -> AttrSet SourcePos -> m v + evalSet :: AttrSet v -> PositionSet -> m v evalRecSetElem :: AttrSet (m v) -> Text -> m v -> m v - evalRecSet :: AttrSet v -> AttrSet SourcePos -> m v + evalRecSet :: AttrSet v -> PositionSet -> m v evalLetElem :: Text -> m v -> m v evalLet :: m v -> m v -} @@ -76,14 +77,14 @@ , ToValue Bool m v , ToValue [v] m v , FromValue NixString m v - , ToValue (AttrSet v, AttrSet SourcePos) m v - , FromValue (AttrSet v, AttrSet SourcePos) m v + , ToValue (AttrSet v, PositionSet) m v + , FromValue (AttrSet v, PositionSet) m v ) 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) @@ -118,10 +119,10 @@ eval (NEnvPath p ) = evalEnvPath p eval (NUnary op arg ) = evalUnary op =<< arg -eval (NBinary NApp fun arg) = +eval (NApp fun arg ) = do f <- fun - scope <- currentScopes :: m (Scopes m v) + scope <- askScopes evalApp f $ withScopes scope arg eval (NBinary op larg rarg) = @@ -129,12 +130,12 @@ lav <- larg evalBinary op lav rarg -eval (NSelect aset attr alt ) = +eval (NSelect alt aset attr) = do let useAltOrReportMissing (s, ks) = fromMaybe (attrMissing ks $ pure s) alt eAttr <- evalSelect aset attr - either useAltOrReportMissing id eAttr + either useAltOrReportMissing id (coerce eAttr) eval (NHasAttr aset attr) = do @@ -143,24 +144,18 @@ eval (NList l ) = do - scope <- currentScopes - lst <- traverse (defer @v @m . withScopes @v scope) l - toValue lst - -eval (NSet NNonRecursive binds) = - do - attrSet <- evalBinds False $ desugarBinds (eval . NSet NNonRecursive) binds - toValue attrSet + scope <- askScopes + toValue =<< traverse (defer @v @m . withScopes @v scope) l -eval (NSet NRecursive binds) = +eval (NSet r binds) = do - attrSet <- evalBinds True $ desugarBinds (eval . NSet NNonRecursive) binds + attrSet <- evalBinds (r == Recursive) $ desugarBinds (eval . NSet mempty) binds toValue attrSet eval (NLet binds body ) = do (attrSet, _) <- evalBinds True binds - pushScope attrSet body + pushScope (coerce attrSet) body eval (NIf cond t f ) = do @@ -179,158 +174,182 @@ -- 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. - scope <- currentScopes :: m (Scopes m v) + curScope <- askScopes let - withScope = withScopes scope - withScopeInform = withScope . inform + withCurScope = withScopes curScope - evalAbs - params - (\arg k -> - withScope $ + fun :: m v -> (AttrSet (m v) -> m v -> m r) -> m r + fun arg k = + withCurScope $ do - args <- buildArgument params arg + (coerce -> newScopeToAdd) <- buildArgument params arg pushScope - args $ + newScopeToAdd $ k - (withScopeInform <$> args) + (coerce $ withCurScope . inform <$> newScopeToAdd) body - ) + evalAbs + params + fun + eval (NSynHole name) = synHole name -- | If you know that the 'scope' action will result in an 'AttrSet v', then -- 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 - scope <- 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 -- computed once. - deferredAset <- defer $ withScopes scope aset - let attrSet = fst <$> (fromValue @(AttrSet v, AttrSet SourcePos) =<< demand deferredAset) + deferredAset <- defer $ withScopes scopes aset + let weakscope = coerce . fst <$> (fromValue @(AttrSet v, PositionSet) =<< demand deferredAset) - pushWeakScope attrSet body + pushWeakScope weakscope body attrSetAlter :: forall v m . MonadNixEval v m - => [Text] - -> SourcePos + => [VarName] + -> NSourcePos -> AttrSet (m v) - -> AttrSet SourcePos + -> PositionSet -> m v - -> m (AttrSet (m v), AttrSet SourcePos) -attrSetAlter [] _ _ _ _ = evalError @v $ ErrorCall "invalid selector with no components" -attrSetAlter (k : ks) pos m p val = - bool - go - (maybe - (recurse mempty mempty) - (\x -> - do - (st, sp) <- fromValue @(AttrSet v, AttrSet SourcePos) =<< x - recurse (demand <$> st) sp - ) - (M.lookup k m) - ) - (not $ null ks) + -> m (AttrSet (m v), PositionSet) +attrSetAlter ks' pos m' p' val = + swap <$> go p' m' ks' where - go = pure (M.insert k val m, M.insert k pos p) - - recurse st sp = - (\(st', _) -> - (M.insert - k - (toValue @(AttrSet v, AttrSet SourcePos) =<< (, mempty) <$> sequence st') - m - , M.insert k pos p + -- This `go` does traverse in disquise. Notice how it traverses `ks`. + go + :: PositionSet + -> AttrSet (m v) + -> [VarName] + -> m (PositionSet, AttrSet (m v)) + go _ _ [] = evalError @v $ ErrorCall "invalid selector with no components" + go p m (k : ks) = + bool + (pure $ insertVal val) + (maybe + (recurse mempty mempty) + (\x -> + do + -- 2021-10-12: NOTE: swapping sourcewide into (PositionSet, AttrSet) would optimize code and remove this `swap` + (swap -> (sp, st)) <- fromValue @(AttrSet v, PositionSet) =<< x + recurse sp $ demand <$> st + ) + ((`M.lookup` m) k) ) - ) <$> attrSetAlter ks pos st sp val + (isPresent ks) + where + insertVal :: m v -> (PositionSet, AttrSet (m v)) + insertVal v = + ( insertPos + , insertV v + ) + where + insertV v' = M.insert k v' m + insertPos = M.insert k pos p + recurse + :: PositionSet + -> AttrSet (m v) + -> m ( PositionSet + , AttrSet (m v) + ) + recurse p'' m'' = + 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 (go <=< collect) binds) mempty +desugarBinds embed = (`evalState` mempty) . traverse (findBinding <=< collect) where collect :: Binding r -> State - (HashMap VarName (SourcePos, [Binding r])) + (AttrSet (NSourcePos, [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 $ - M.insert - x - (maybe - (p, [bindValAt p]) - (\ (q, v) -> (q, bindValAt q : v)) - (M.lookup x m) - ) - m + modify updateBindingInformation pure $ Left x where - bindValAt pos = NamedVar (y :| ys) val pos + updateBindingInformation + :: AttrSet (NSourcePos, [Binding r]) + -> AttrSet (NSourcePos, [Binding r]) + updateBindingInformation = + M.insert x + =<< maybe + (mkBindingSingleton oldPosition) + (\ (foundPosition, newBindings) -> second (<> newBindings) $ mkBindingSingleton foundPosition) + . M.lookup x + mkBindingSingleton :: NSourcePos -> (NSourcePos, [Binding r]) + mkBindingSingleton np = (np , one $ bindValAt np) + where + bindValAt :: NSourcePos -> Binding r + bindValAt = NamedVar (y :| ys) val collect x = pure $ pure x - go + findBinding :: Either VarName (Binding r) - -> State (HashMap VarName (SourcePos, [Binding r])) (Binding r) - go = + -> State (AttrSet (NSourcePos, [Binding r])) (Binding r) + findBinding = either - (\ x -> do - maybeValue <- gets $ M.lookup x + (\ x -> maybe (error $ "No binding " <> show x) - (\ (p, v) -> pure $ NamedVar (StaticKey x :| mempty) (embed v) p) - maybeValue + (\ (p, v) -> pure $ NamedVar (one $ StaticKey x) (embed v) p) + =<< gets (M.lookup x) ) pure evalBinds :: forall v m . MonadNixEval v m +-- 2021-07-19: NOTE: Recutsivity data type => Bool -> [Binding (m v)] - -> m (AttrSet v, AttrSet SourcePos) -evalBinds recursive binds = +-- 2021-07-19: NOTE: AttrSet is a Scope + -> m (AttrSet v, PositionSet) +evalBinds isRecursive binds = do - scope <- currentScopes :: m (Scopes m v) + scope <- askScopes - buildResult scope . concat =<< traverse (applyBindToAdt scope) (moveOverridesLast binds) + buildResult scope . fold =<< (`traverse` moveOverridesLast binds) (applyBindToAdt scope) where buildResult :: Scopes m v - -> [([Text], SourcePos, m v)] - -> m (AttrSet v, AttrSet SourcePos) - buildResult scope bindings = + -> [([VarName], NSourcePos, m v)] + -> m (AttrSet v, PositionSet) + buildResult scopes bindings = do - (s, p) <- foldM insert (mempty, mempty) bindings + (coerce -> scope, p) <- foldM insert mempty bindings res <- bool - (traverse mkThunk s) - (loebM $ encapsulate <$> s) - recursive + (traverse mkThunk) + (loebM . fmap encapsulate) + isRecursive + scope - pure (res, p) + pure (coerce res, p) where + insert :: (AttrSet (m v), PositionSet) -> ([VarName], NSourcePos, m v) -> m (AttrSet (m v), PositionSet) insert (m, p) (path, pos, value) = attrSetAlter path pos m p value - mkThunk = defer . withScopes scope + mkThunk = defer . withScopes scopes encapsulate f attrs = mkThunk $ pushScope attrs f - applyBindToAdt :: Scopes m v -> Binding (m v) -> m [([Text], SourcePos, m v)] + applyBindToAdt :: Scopes m v -> Binding (m v) -> m [([VarName], NSourcePos, m v)] applyBindToAdt _ (NamedVar (StaticKey "__overrides" :| []) finalValue pos) = do (o', p') <- fromValue =<< finalValue -- jww (2018-05-09): What to do with the key position here? pure $ (\ (k, v) -> - ( [k] + ( one k , fromMaybe pos $ M.lookup k p' , demand v ) @@ -341,19 +360,19 @@ -- When there are no path segments, e.g. `${null} = 5;`, we don't -- bind anything ([], _, _) -> mempty - result -> [result] + result -> one result ) <$> processAttrSetKeys pathExpr where - processAttrSetKeys :: NAttrPath (m v) -> m ([Text], SourcePos, m v) + processAttrSetKeys :: NAttrPath (m v) -> m ([VarName], NSourcePos, m v) processAttrSetKeys (h :| t) = maybe -- Empty attrset - return a stub. - (pure ( mempty, nullPos, toValue @(AttrSet v, AttrSet SourcePos) (mempty, mempty)) ) + (pure (mempty, nullPos, toValue @(AttrSet v, PositionSet) mempty) ) (\ k -> - list + handlePresence -- No more keys in the attrset - return the result - (pure ( [k], pos, finalValue ) ) + (pure ( one k, pos, finalValue ) ) -- There are unprocessed keys in attrset - recurse appending the results (\ (x : xs) -> do @@ -364,37 +383,28 @@ ) =<< evalSetterKeyName h - applyBindToAdt scope (Inherit ms names pos) = - catMaybes <$> - traverse - processScope - names + applyBindToAdt scopes (Inherit ms names pos) = + pure $ processScope <$> names where processScope - :: NKeyName (m v) - -> m (Maybe ([Text], SourcePos, m v)) - processScope nkeyname = - (\ mkey -> - do - key <- mkey - pure - ([key] - , pos - , maybe - (attrMissing (key :| mempty) Nothing) - demand - =<< maybe - (withScopes scope $ lookupVar key) - (\ s -> - do - (attrset, _) <- fromValue @(AttrSet v, AttrSet SourcePos) =<< s + :: VarName + -> ([VarName], NSourcePos, m v) + processScope var = + ( one var + , pos + , maybe + (attrMissing (one var) Nothing) + demand + =<< maybe + (withScopes scopes $ lookupVar var) + (\ s -> + do + (coerce -> scope, _) <- fromValue @(AttrSet v, PositionSet) =<< s - clearScopes @v $ pushScope attrset $ lookupVar key - ) - ms - ) - ) <$> - evalSetterKeyName nkeyname + clearScopes $ pushScope @v scope $ lookupVar var + ) + ms + ) moveOverridesLast = uncurry (<>) . partition (\case @@ -407,30 +417,33 @@ . MonadNixEval v m => m v -> NAttrPath (m v) - -> m (Either (v, NonEmpty Text) (m v)) + -> m (Either (v, NonEmpty VarName) (m v)) evalSelect aset attr = do s <- aset path <- traverse evalGetterKeyName attr - extract s path + extract path s where - extract x path@(k :| ks) = - do - x' <- fromValueMay x - - case x' of - Nothing -> pure $ Left (x, path) - Just (s :: AttrSet v, p :: AttrSet SourcePos) - | Just t <- M.lookup k s -> - do - list - (pure . pure) - (\ (y : ys) -> ((`extract` (y :| ys)) =<<)) - ks - $ demand t - | otherwise -> Left . (, path) <$> toValue (s, p) + extract :: NonEmpty VarName -> v -> m (Either (v, NonEmpty VarName) (m v)) + extract path@(k :| ks) x = + maybe + left + (maybe + left + (handlePresence + (pure . pure) + (\ (y : ys) -> (extract (y :| ys) =<<)) + ks + . demand + ) + . M.lookup k . fst + ) + =<< fromValueMay @(AttrSet v, PositionSet) x + where + left :: m (Either (v, NonEmpty VarName) b) + left = pure $ Left (x, path) -- | Evaluate a component of an attribute path in a context where we are -- *retrieving* a value @@ -438,7 +451,7 @@ :: forall v m . (MonadEval v m, FromValue NixString m v) => NKeyName (m v) - -> m Text + -> m VarName evalGetterKeyName = maybe (evalError @v $ ErrorCall "value is null while a string was expected") @@ -450,77 +463,71 @@ evalSetterKeyName :: (MonadEval v m, FromValue NixString m v) => NKeyName (m v) - -> m (Maybe Text) + -> m (Maybe VarName) evalSetterKeyName = \case StaticKey k -> pure $ pure k DynamicKey k -> - maybe - mempty - (pure . stringIgnoreContext) - <$> runAntiquoted "\n" assembleString (fromValueMay =<<) k + coerce . ignoreContext <<$>> runAntiquoted "\n" assembleString (fromValueMay =<<) k assembleString :: forall v m . (MonadEval v m, FromValue NixString m v) => NString (m v) -> m (Maybe NixString) -assembleString = - fromParts . - \case - Indented _ parts -> parts - DoubleQuoted parts -> parts +assembleString = fromParts . stringParts where - fromParts xs = (mconcat <$>) . sequence <$> traverse go xs + fromParts :: [Antiquoted Text (m v)] -> m (Maybe NixString) + fromParts xs = fold <<$>> traverse2 fun xs - go = + fun :: Antiquoted Text (m v) -> m (Maybe NixString) + fun = runAntiquoted "\n" - (pure . pure . makeNixStringWithoutContext) + (pure . pure . mkNixStringWithoutContext) (fromValueMay =<<) buildArgument :: forall v m . MonadNixEval v m => Params (m v) -> m v -> m (AttrSet v) buildArgument params arg = do - scope <- currentScopes :: m (Scopes m v) - let argThunk = defer $ withScopes scope arg + scope <- askScopes + let + argThunk = defer $ withScopes scope arg case params of - Param name -> M.singleton name <$> argThunk - ParamSet s isVariadic m -> + Param name -> one . (name,) <$> argThunk + ParamSet mname variadic pset -> do - (args, _) <- fromValue @(AttrSet v, AttrSet SourcePos) =<< arg + (args, _) <- fromValue @(AttrSet v, PositionSet) =<< arg let inject = maybe id - (\ n -> M.insert n $ const argThunk) -- why insert into const? - m - loebM - (inject $ - M.mapMaybe - id - (ialignWith - (assemble scope isVariadic) + (`M.insert` const argThunk) -- why insert into const? Thunk value getting magic point? + mname + loebM $ + inject $ + M.mapMaybe + id + $ ialignWith + (assemble scope variadic) args - $ M.fromList s - ) - ) + $ M.fromList pset where assemble :: Scopes m v - -> Bool - -> Text + -> Variadic + -> VarName -> These v (Maybe (m v)) -> Maybe (AttrSet v -> m v) - assemble scope isVariadic k = - \case - That Nothing -> pure $ const $ evalError @v $ ErrorCall $ "Missing value for parameter: " <> show k - That (Just f) -> pure $ \args -> defer $ withScopes scope $ pushScope args f - This _ - | isVariadic -> Nothing - | otherwise -> pure $ const $ evalError @v $ ErrorCall $ "Unexpected parameter: " <> show k - These x _ -> pure $ const $ pure x + assemble _ Variadic _ (This _) = Nothing + assemble scope _ k t = + pure $ + case t of + That Nothing -> const $ evalError @v $ ErrorCall $ "Missing value for parameter: ''" <> show k + That (Just f) -> coerce $ defer . withScopes scope . (`pushScope` f) + This _ -> const $ evalError @v $ ErrorCall $ "Unexpected parameter: " <> show k + These x _ -> const $ pure x -- | Add source positions to @NExprLoc@. -- @@ -533,7 +540,7 @@ -- > -> NExprLoc -> m a addSourcePositions :: (MonadReader e m, Has e SrcSpan) => Transform NExprLocF (m a) -addSourcePositions f (v@(AnnE ann _) :: NExprLoc) = +addSourcePositions f (v@(Ann ann _) :: NExprLoc) = local (set hasLens ann) $ f v addStackFrames @@ -542,7 +549,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@ @@ -551,15 +558,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) @@ -571,4 +578,4 @@ :: MonadNixEval v m => AnnF ann NExprF (m v) -> m v -evalContent = eval . stripAnn +evalContent = eval . stripAnnF diff --git a/src/Nix/Exec.hs b/src/Nix/Exec.hs --- a/src/Nix/Exec.hs +++ b/src/Nix/Exec.hs @@ -1,23 +1,22 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# language AllowAmbiguousTypes #-} +{-# language CPP #-} +{-# language ConstraintKinds #-} +{-# language PartialTypeSignatures #-} +{-# language RankNTypes #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# options_ghc -Wno-orphans #-} +{-# options_ghc -fno-warn-name-shadowing #-} module Nix.Exec where -import Prelude hiding ( putStr +import Nix.Prelude hiding ( putStr , putStrLn , print ) - +import GHC.Exception ( ErrorCall(ErrorCall) ) import Control.Monad.Catch hiding ( catchJust ) import Control.Monad.Fix import Data.Fix @@ -29,7 +28,8 @@ import Nix.Convert import Nix.Effects import Nix.Eval as Eval -import Nix.Expr +import Nix.Expr.Types +import Nix.Expr.Types.Annotated import Nix.Frames import Nix.Options import Nix.Pretty @@ -38,14 +38,13 @@ import Nix.String import Nix.String.Coerce import Nix.Thunk -import Nix.Utils import Nix.Value import Nix.Value.Equal import Nix.Value.Monad import Prettyprinter import qualified Text.Show.Pretty as PS -#ifdef MIN_VERSION_ghc_datasize +#ifdef MIN_VERSION_ghc_datasize import GHC.DataSize #endif @@ -55,57 +54,77 @@ , 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) $ NVConstant 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) $ NVStr x -nvPathP +mkNVPathWithProvenance :: MonadCited t f m - => Provenance m (NValue t f m) - -> FilePath + => 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) $ NVPath 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) $ NVClosure x f -nvSetP +mkNVUnaryOpWithProvenance :: MonadCited t f m - => Provenance m (NValue t f m) - -> AttrSet SourcePos - -> 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 + -> NValue t f m +mkNVUnaryOpWithProvenance scope span op val = + addProvenance (Provenance scope $ NUnaryAnnF span op val) -nvClosureP +mkNVAppOpWithProvenance :: MonadCited t f m - => Provenance m (NValue t f m) - -> Params () - -> (NValue t f m -> m (NValue t f m)) + => Scopes m (NValue t f m) + -> SrcSpan + -> Maybe (NValue t f m) + -> Maybe (NValue t f m) -> NValue t f m -nvClosureP p x f = addProvenance p $ nvClosure x f + -> NValue t f m +mkNVAppOpWithProvenance scope span lval rval = + addProvenance (Provenance scope $ NAppAnnF span lval rval) -nvBuiltinP +mkNVBinaryOpWithProvenance :: MonadCited t f m - => Provenance m (NValue t f m) - -> Text - -> (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) @@ -136,148 +155,154 @@ 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 $ Fix (NSym_ span "") <$ x +wrapExprLoc span x = Fix $ NSymAnn span "" <$ x {-# inline wrapExprLoc #-} -- 2021-01-07: NOTE: This instance belongs to be beside MonadEval type class. -- Currently instance is stuck in orphanage between the requirements to be MonadEval, aka Eval stage, and emposed requirement to be MonadNix (Execution stage). MonadNix constraint tries to put the cart before horse and seems superflous, since Eval in Nix also needs and can throw exceptions. It is between `nverr` and `evalError`. instance MonadNix e t f m => MonadEval (NValue t f m) m where freeVariable var = - nverr @e @t @f $ ErrorCall $ "Undefined variable '" <> toString 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 = Fix $ NSynHole_ 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 ks - - evalCurPos = do - scope <- currentScopes - span@(SrcSpan delta _) <- currentPos - addProvenance @_ @_ @(NValue t f m) - (Provenance scope $ NSym_ span "__curPos") <$> - toValue delta + attr = Text.intercalate "." $ NE.toList $ coerce ks - evaledSym name val = do - scope <- currentScopes - span <- currentPos - pure $ + evalCurPos = + do + scope <- askScopes + span@(SrcSpan delta _) <- askSpan addProvenance @_ @_ @(NValue t f m) - (Provenance scope $ NSym_ span name) - val + (Provenance scope . NSymAnnF span $ coerce @Text "__curPos") <$> + toValue delta - evalConstant c = do - scope <- currentScopes - span <- currentPos - pure $ nvConstantP (Provenance scope $ NConstant_ span c) 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 $ - nvStrP - (Provenance - scope - (NStr_ span $ DoubleQuoted [Plain $ stringIgnoreContext ns]) - ) - ns + scope <- askScopes + span <- askSpan + pure $ mkNVStrWithProvenance scope span ns ) <=< assembleString - evalLiteralPath p = do - scope <- currentScopes - span <- currentPos - nvPathP (Provenance scope $ NLiteralPath_ span p) <$> - makeAbsolutePath @t @f @m 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 $ NEnvPath_ span p) <$> - findEnvPath @t @f @m 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 . NWith_ 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 t f = do - scope <- currentScopes - span <- currentPos - b <- fromValue c + evalIf c tVal fVal = + do + scope <- askScopes + span <- askSpan + bl <- fromValue c - let - fun x y z = addProvenance (Provenance scope $ NIf_ span (pure c) x y) z - -- Note: join acts as \ f x -> f x x - false = join (fun Nothing . pure) <$> f - true = join (flip fun Nothing . pure) <$> t + 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 - false - true - b + bool + falseVal + trueVal + bl evalAssert c body = do - span <- currentPos + span <- askSpan b <- fromValue c bool (nverr $ Assertion span c) (do - scope <- currentScopes - let f = join (addProvenance . Provenance scope . NAssert_ span (pure c) . pure) - f <$> body + scope <- askScopes + join (addProvenance . Provenance scope . NAssertAnnF span (pure c) . pure) <$> body ) b - evalApp f x = do - scope <- currentScopes - span <- currentPos - addProvenance (Provenance scope $ NBinary_ span NApp (pure f) Nothing) <$> - (callFunc f =<< defer x) + evalApp f x = + do + scope <- askScopes + span <- askSpan + mkNVAppOpWithProvenance scope span (pure f) Nothing <$> (callFunc f =<< defer x) - evalAbs p k = do - scope <- currentScopes - span <- currentPos - pure $ - nvClosureP - (Provenance scope $ NAbs_ span (Nothing <$ p) Nothing) - (void p) - (\arg -> snd <$> k (pure arg) (\_ b -> ((), ) <$> b)) + 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 @@ -290,40 +315,42 @@ -> 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 case fun' of - NVClosure _params f -> f arg NVBuiltin name f -> do - span <- currentPos + 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 + NVClosure _params f -> f arg + (NVSet _ m) | Just f <- M.lookup "__functor" m -> + (`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 -> NValue t f m -> m (NValue t f m) -execUnaryOp scope span op arg = do +execUnaryOp scope span op arg = 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 $ NUnary_ 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) . NVConstant $ c (b a) execBinaryOp :: forall e t f m @@ -351,6 +378,7 @@ where + helperEq :: (Bool -> Bool) -> m (NValue t f m) helperEq flag = do rval <- rarg @@ -373,10 +401,7 @@ toBoolOp :: Maybe (NValue t f m) -> Bool -> m (NValue t f m) toBoolOp r b = - pure $ - nvConstantP - (Provenance scope $ NBinary_ span op (pure lval) r) - (NBool b) + pure $ mkNVBinaryOpWithProvenance scope span op (pure lval) r $ NVConstant $ NBool b execBinaryOpForced :: forall e t f m @@ -388,93 +413,103 @@ -> 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 +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 - NUpdate -> - case (lval, rval) of - (NVSet ls lp, NVSet rs rp) -> pure $ nvSetP prov (rp <> lp) (rs <> ls) - (NVSet ls lp, NVConstant NNull) -> pure $ nvSetP prov lp ls - (NVConstant NNull, NVSet rs rp) -> pure $ nvSetP prov rp rs - _ -> unsupportedTypes + 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 - NPlus -> - case (lval, rval) of - (NVConstant _, NVConstant _) -> numBinOp (+) + 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) - (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 <$> - makeAbsolutePath @t @f (ls <> toString rs2) - ) - (getStringNoContext rs) - (NVPath ls, NVPath rs) -> nvPathP prov <$> makeAbsolutePath @t @f (ls <> rs) + (ls@NVSet{}, NVStr rs) -> + mkStrP . (<> rs) <$> + coerceAnyToNixString callFunc DontCopyToStore ls + (NVStr ls, rs@NVSet{}) -> + mkStrP . (ls <>) <$> + coerceAnyToNixString callFunc DontCopyToStore rs + _ -> unsupportedTypes + _other -> shouldBeAlreadyHandled - (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 + where + addProv :: NValue t f m -> NValue t f m + addProv = + mkNVBinaryOpWithProvenance scope span op (pure lval) (pure rval) - NEq -> alreadyHandled - NNEq -> alreadyHandled - NAnd -> alreadyHandled - NOr -> alreadyHandled - NImpl -> alreadyHandled - NApp -> throwError $ ErrorCall "NApp should be handled by evalApp" + mkBoolP :: Bool -> m (NValue t f m) + mkBoolP = pure . addProv . NVConstant . NBool - where - prov :: Provenance m (NValue t f m) - prov = Provenance scope $ NBinary_ span op (pure lval) (pure rval) + mkIntP :: Integer -> m (NValue t f m) + mkIntP = pure . addProv . NVConstant . NInt - 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 + mkFloatP :: Float -> m (NValue t f m) + mkFloatP = pure . addProv . NVConstant . NFloat - toInt = pure . nvConstantP prov . NInt - toFloat = pure . nvConstantP prov . NFloat + mkListP :: [NValue t f m] -> NValue t f m + mkListP = addProv . NVList - numBinOp :: (forall a. Num a => a -> a -> a) -> m (NValue t f m) - numBinOp op = numBinOp' op op + mkStrP :: NixString -> NValue t f m + mkStrP = addProv . NVStr - numBinOp' + mkPathP :: Path -> NValue t f m + mkPathP = addProv . NVPath + + mkSetP :: (PositionSet -> AttrSet (NValue t f m) -> NValue t f m) + mkSetP x s = addProv $ NVSet 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) -> toInt $ li `intOp` ri - (NInt li, NFloat rf) -> toFloat $ fromInteger li `floatOp` rf - (NFloat lf, NInt ri) -> toFloat $ lf `floatOp` fromInteger ri - (NFloat lf, NFloat rf) -> toFloat $ 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 @@ -502,16 +537,15 @@ depth <- ask guard $ depth < 2000 local succ $ do - v'@(AnnFP span x) <- sequence v + 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 @@ -519,27 +553,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,251 +1,452 @@ - --- | A bunch of shorthands for making nix expressions. +-- | Shorthands for making Nix expressions. -- --- Functions with an @F@ suffix return a more general type without the outer --- 'Fix' wrapper. +-- 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 -import Text.Megaparsec.Pos ( SourcePos ) --- | Make an integer literal expression. -mkInt :: Integer -> NExpr -mkInt = Fix . mkIntF +-- * Basic expression builders +-- | Put @NAtom@ as expression +mkConst :: NAtom -> NExpr +mkConst = Fix . NConstant -mkIntF :: Integer -> NExprF a -mkIntF = NConstant . NInt +-- | Put null. +mkNull :: NExpr +mkNull = Fix mkNullF --- | Make an floating point literal expression. +-- | Put boolean. +mkBool :: Bool -> NExpr +mkBool = Fix . mkBoolF + +-- | Put integer. +mkInt :: Integer -> NExpr +mkInt = Fix . mkIntF + +-- | Put floating point number. mkFloat :: Float -> NExpr mkFloat = Fix . mkFloatF -mkFloatF :: Float -> NExprF a -mkFloatF = NConstant . NFloat - --- | Make a regular (double-quoted) string. +-- | Put a regular (double-quoted) string. mkStr :: Text -> NExpr -mkStr = Fix . NStr . DoubleQuoted . \case - "" -> mempty - x -> [Plain x] +mkStr = Fix . NStr . DoubleQuoted . + whenText + mempty + (one . Plain) --- | Make an indented string. +-- | Put an indented string. mkIndentedStr :: Int -> Text -> NExpr -mkIndentedStr w = Fix . NStr . Indented w . \case - "" -> mempty - x -> [Plain x] +mkIndentedStr w = Fix . NStr . Indented w . + whenText + mempty + (one . Plain) --- | Make a path. Use 'True' if the path should be read from the --- environment, else 'False'. +-- | Put a path. Use @True@ if the path should be read from the environment, else use @False@. mkPath :: Bool -> FilePath -> NExpr mkPath b = Fix . mkPathF b -mkPathF :: Bool -> FilePath -> NExprF a -mkPathF False = NLiteralPath -mkPathF True = NEnvPath - --- | Make a path expression which pulls from the NIX_PATH env variable. +-- | Put a path expression which pulls from the @NIX_PATH@ @env@ variable. mkEnvPath :: FilePath -> NExpr mkEnvPath = Fix . mkEnvPathF -mkEnvPathF :: FilePath -> NExprF a -mkEnvPathF = mkPathF True - --- | Make a path expression which references a relative path. +-- | Put a path which references a relative path. mkRelPath :: FilePath -> NExpr mkRelPath = Fix . mkRelPathF -mkRelPathF :: FilePath -> NExprF a -mkRelPathF = mkPathF False - --- | Make a variable (symbol) +-- | Put a variable (symbol). mkSym :: Text -> NExpr mkSym = Fix . mkSymF -mkSymF :: Text -> NExprF a -mkSymF = NSym - +-- | Put syntactic hole. mkSynHole :: Text -> NExpr mkSynHole = Fix . mkSynHoleF -mkSynHoleF :: Text -> NExprF a -mkSynHoleF = NSynHole - mkSelector :: Text -> NAttrPath NExpr -mkSelector = (:| mempty) . StaticKey +mkSelector = one . StaticKey . coerce -mkBool :: Bool -> NExpr -mkBool = Fix . mkBoolF +-- | Put a binary operator. +-- @since +mkApp :: NExpr -> NExpr -> NExpr +mkApp a = Fix . NApp a +-- | Put an unary operator. -mkBoolF :: Bool -> NExprF a -mkBoolF = NConstant . NBool +-- @since 0.15.0 +mkOp :: NUnaryOp -> NExpr -> NExpr +mkOp op = Fix . NUnary op -mkNull :: NExpr -mkNull = Fix mkNullF +-- | Logical negation: @not@. +mkNot :: NExpr -> NExpr +mkNot = mkOp NNot -mkNullF :: NExprF a -mkNullF = NConstant NNull +-- | Number negation: @-@. +-- +-- Negation in the language works with integers and floating point. +-- @since 0.15.0 +mkNeg :: NExpr -> NExpr +mkNeg = mkOp NNeg -mkOper :: NUnaryOp -> NExpr -> NExpr -mkOper op = Fix . NUnary op +-- | Put a binary operator. +-- @since 0.15.0 +mkOp2 :: NBinaryOp -> NExpr -> NExpr -> NExpr +mkOp2 op a = Fix . NBinary op a -mkOper2 :: NBinaryOp -> NExpr -> NExpr -> NExpr -mkOper2 op a = Fix . NBinary op a +-- | > { x } +-- @since 0.15.0 +mkParamSet :: [(Text, Maybe NExpr)] -> Params NExpr +mkParamSet pset = mkGeneralParamSet Nothing pset False -mkParamset :: [(Text, Maybe NExpr)] -> Bool -> Params NExpr -mkParamset params variadic = ParamSet params variadic mempty +-- | > { x, ... } +-- @since 0.15.0 +mkVariadicParamSet :: [(Text, Maybe NExpr)] -> Params NExpr +mkVariadicParamSet pset = mkGeneralParamSet Nothing pset True +-- | > s@{ x } +-- @since 0.15.0 +mkNamedParamSet :: Text -> [(Text, Maybe NExpr)] -> Params NExpr +mkNamedParamSet name pset = mkGeneralParamSet (pure name) pset False + +-- | > s@{ x, ... } +-- @since 0.15.0 +mkNamedVariadicParamSet :: Text -> [(Text, Maybe NExpr)] -> Params NExpr +mkNamedVariadicParamSet name params = mkGeneralParamSet (pure name) params True + +-- | Args: +-- +-- 1. Maybe name: +-- +-- > Nothing -> {} +-- > Just "s" -> s@{} +-- +-- 2. key:expr pairs +-- +-- 3. Is variadic or not: +-- +-- > True -> {...} +-- > False -> {} +-- @since 0.15.0 +mkGeneralParamSet :: Maybe Text -> [(Text, Maybe NExpr)] -> Bool -> Params NExpr +mkGeneralParamSet mname params variadic = ParamSet (coerce mname) (Variadic `whenTrue` variadic) (coerce params) + +-- | > rec { .. } mkRecSet :: [Binding NExpr] -> NExpr -mkRecSet = Fix . NSet NRecursive +mkRecSet = mkSet Recursive +-- | Put a non-recursive set. +-- +-- > { .. } mkNonRecSet :: [Binding NExpr] -> NExpr -mkNonRecSet = Fix . NSet NNonRecursive +mkNonRecSet = mkSet mempty -mkLets :: [Binding NExpr] -> NExpr -> NExpr -mkLets bindings = Fix . NLet bindings +-- | General set builder function. +mkSet :: Recursivity -> [Binding NExpr] -> NExpr +mkSet r = Fix . NSet r +-- | Empty set. +-- +-- Monoid. Use @//@ operation (shorthand $//) to extend the set. +-- @since 0.15.0 +emptySet :: NExpr +emptySet = mkNonRecSet mempty + +-- | Put a list. mkList :: [NExpr] -> NExpr mkList = Fix . NList +-- @since 0.15.0 +emptyList :: NExpr +emptyList = mkList mempty + +-- | Wrap in a @let@. +-- +-- (Evaluate the second argument after introducing the bindings.) +-- +-- +------------------------+-----------------+ +-- | Haskell | Nix | +-- +========================+=================+ +-- | @mkLets bindings expr@ | @let bindings;@ | +-- | | @in expr@ | +-- +------------------------+-----------------+ +mkLets :: [Binding NExpr] -> NExpr -> NExpr +mkLets bindings = Fix . NLet bindings + +-- | Create a @whith@: +-- 1st expr - what to bring into the scope. +-- 2nd - expression that recieves the scope extention. +-- +-- +--------------------+-------------------+ +-- | Haskell | Nix | +-- +====================+===================+ +-- | @mkWith body main@ | @with body; expr@ | +-- +--------------------+-------------------+ mkWith :: NExpr -> NExpr -> NExpr mkWith e = Fix . NWith e +-- | Create an @assert@: +-- 1st expr - asserting itself, must return @true@. +-- 2nd - main expression to evaluated after assertion. +-- +-- +-----------------------+----------------------+ +-- | Haskell | Nix | +-- +=======================+======================+ +-- | @mkAssert check eval@ | @assert check; eval@ | +-- +-----------------------+----------------------+ mkAssert :: NExpr -> NExpr -> NExpr -mkAssert e = Fix . NWith e +mkAssert e = Fix . NAssert e +-- | Put: +-- +-- > if expr1 +-- > then expr2 +-- > else expr3 mkIf :: NExpr -> NExpr -> NExpr -> NExpr mkIf e1 e2 = Fix . NIf e1 e2 +-- | Lambda function, analog of Haskell's @\\ x -> x@: +-- +-- +-----------------------+-----------+ +-- | Haskell | Nix | +-- +=======================+===========+ +-- | @ mkFunction x expr @ | @x: expr@ | +-- +-----------------------+-----------+ mkFunction :: Params NExpr -> NExpr -> NExpr mkFunction params = Fix . NAbs params -{- -mkDot :: NExpr -> Text -> NExpr -mkDot e key = mkDots e [key] +-- | General dot-reference with optional alternative if the key does not exist. +-- @since 0.15.0 +getRefOrDefault :: Maybe NExpr -> NExpr -> Text -> NExpr +getRefOrDefault alt obj = Fix . NSelect alt obj . mkSelector --- | Create a dotted expression using only text. -mkDots :: NExpr -> [Text] -> NExpr -mkDots e [] = e -mkDots (Fix (NSelect e keys' x)) keys = - -- Special case: if the expression in the first argument is already - -- a dotted expression, just extend it. - Fix (NSelect e (keys' <> fmap (`StaticKey` Nothing) keys) x) -mkDots e keys = Fix $ NSelect e (fmap (`StaticKey` Nothing) keys) Nothing --} +-- ** Base functor builders for basic expressions builders *sic --- | An `inherit` clause without an expression to pull from. -inherit :: [NKeyName e] -> SourcePos -> Binding e -inherit = Inherit Nothing +-- | Unfixed @mkNull@. +mkNullF :: NExprF a +mkNullF = NConstant NNull +-- | Unfixed @mkBool@. +mkBoolF :: Bool -> NExprF a +mkBoolF = NConstant . NBool + +-- | Unfixed @mkInt@. +mkIntF :: Integer -> NExprF a +mkIntF = NConstant . NInt + +-- | Unfixed @mkFloat@. +mkFloatF :: Float -> NExprF a +mkFloatF = NConstant . NFloat + +-- | Unfixed @mkPath@. +mkPathF :: Bool -> FilePath -> NExprF a +mkPathF False = NLiteralPath . coerce +mkPathF True = NEnvPath . coerce + +-- | Unfixed @mkEnvPath@. +mkEnvPathF :: FilePath -> NExprF a +mkEnvPathF = mkPathF True + +-- | Unfixed @mkRelPath@. +mkRelPathF :: FilePath -> NExprF a +mkRelPathF = mkPathF False + +-- | Unfixed @mkSym@. +mkSymF :: Text -> NExprF a +mkSymF = NSym . coerce + +-- | Unfixed @mkSynHole@. +mkSynHoleF :: Text -> NExprF a +mkSynHoleF = NSynHole . coerce + + +-- * Other +-- (org this better/make a better name for section(s)) + -- | An `inherit` clause with an expression to pull from. -inheritFrom :: e -> [NKeyName e] -> SourcePos -> Binding e -inheritFrom expr = Inherit (pure expr) +-- +-- +------------------------+--------------------+------------+ +-- | Hask | Nix | pseudocode | +-- +========================+====================+============+ +-- | @inheritFrom x [a, b]@ | @inherit (x) a b;@ | @a = x.a;@ | +-- | | | @b = x.b;@ | +-- +------------------------+--------------------+------------+ +inheritFrom :: e -> [VarName] -> Binding e +inheritFrom expr ks = Inherit (pure expr) ks nullPos --- | Shorthand for producing a binding of a name to an expression: @= -bindTo :: Text -> NExpr -> Binding NExpr -bindTo name x = NamedVar (mkSelector name) x nullPos +-- | An `inherit` clause without an expression to pull from. +-- +-- +----------------------+----------------+------------------+ +-- | Hask | Nix | pseudocode | +-- +======================+================+==================+ +-- | @inheritFrom [a, b]@ | @inherit a b;@ | @a = outside.a;@ | +-- | | | @b = outside.b;@ | +-- +----------------------+----------------+------------------+ +inherit :: [VarName] -> Binding e +inherit ks = Inherit Nothing ks nullPos --- | Infix version of @bindTo@: @=@ +-- | Nix @=@ (bind operator). ($=) :: Text -> NExpr -> Binding NExpr ($=) = bindTo - infixr 2 $= +-- | Shorthand for producing a binding of a name to an expression: Nix's @=@. +bindTo :: Text -> NExpr -> Binding NExpr +bindTo name x = NamedVar (mkSelector name) x nullPos + -- | Append a list of bindings to a set or let expression. --- For example, adding `[a = 1, b = 2]` to `let c = 3; in 4` produces --- `let a = 1; b = 2; c = 3; in 4`. +-- For example: +-- adding `[a = 1, b = 2]` +-- to `let c = 3; in 4` +-- produces `let a = 1; b = 2; c = 3; in 4`. appendBindings :: [Binding NExpr] -> NExpr -> NExpr -appendBindings newBindings (Fix e) = case e of - NLet bindings e' -> Fix $ NLet (bindings <> newBindings) e' - NSet recur bindings -> Fix $ NSet recur (bindings <> newBindings) - _ -> error "Can only append bindings to a set or a let" +appendBindings newBindings (Fix e) = + case e of + NLet bindings e' -> mkLets (bindings <> newBindings) e' + NSet recur bindings -> Fix $ NSet recur (bindings <> newBindings) + _ -> error "Can only append bindings to a set or a let" --- | Applies a transformation to the body of a nix function. +-- | Applies a transformation to the body of a Nix function. modifyFunctionBody :: (NExpr -> NExpr) -> NExpr -> NExpr -modifyFunctionBody f (Fix (NAbs params body)) = Fix $ NAbs params $ f body +modifyFunctionBody transform (Fix (NAbs params body)) = mkFunction params $ transform body modifyFunctionBody _ _ = error "Not a function" --- | A let statement with multiple assignments. +-- | A @let@ statement with multiple assignments. letsE :: [(Text, NExpr)] -> NExpr -> NExpr -letsE pairs = Fix . NLet (uncurry bindTo <$> pairs) +letsE pairs = mkLets $ uncurry ($=) <$> pairs -- | Wrapper for a single-variable @let@. letE :: Text -> NExpr -> NExpr -> NExpr -letE varName varExpr = letsE [(varName, varExpr)] +letE varName varExpr = letsE $ one (varName, varExpr) --- | Make an attribute set (non-recursive). +-- | Make a non-recursive attribute set. attrsE :: [(Text, NExpr)] -> NExpr -attrsE pairs = Fix $ NSet NNonRecursive $ uncurry bindTo <$> pairs +attrsE pairs = mkNonRecSet $ uncurry ($=) <$> pairs --- | Make an attribute set (recursive). +-- | Make a recursive attribute set. recAttrsE :: [(Text, NExpr)] -> NExpr -recAttrsE pairs = Fix $ NSet NRecursive $ uncurry bindTo <$> pairs +recAttrsE pairs = mkRecSet $ uncurry ($=) <$> pairs --- | Logical negation. -mkNot :: NExpr -> NExpr -mkNot = Fix . NUnary NNot --- -- | Dot-reference into an attribute set. --- (!.) :: NExpr -> Text -> NExpr --- (!.) = mkDot --- infixl 8 !. - -- * Nix binary operators --- | Nix binary operator builder. -mkBinop :: NBinaryOp -> NExpr -> NExpr -> NExpr -mkBinop op e1 e2 = Fix $ NBinary op e1 e2 - (@@), ($==), ($!=), ($<), ($<=), ($>), ($>=), ($&&), ($||), ($->), ($//), ($+), ($-), ($*), ($/), ($++) :: NExpr -> NExpr -> NExpr +-- 2021-07-10: NOTE: Probably the presedence of some operators is still needs to be tweaked. + +-- | Dot-reference into an attribute set: @attrSet.k@ +(@.) :: NExpr -> Text -> NExpr +(@.) = getRefOrDefault Nothing +infix 9 @. + +-- | Dot-reference into an attribute set with alternative if the key does not exist. +-- +-- > s.x or y +-- @since 0.15.0 +(@.<|>) :: NExpr -> Text -> NExpr -> NExpr +(@.<|>) obj name alt = getRefOrDefault (pure alt ) obj name +infix 9 @.<|> + -- | Function application (@' '@ in @f x@) -(@@) = mkBinop NApp -infixl 1 @@ --- | Equality: @==@ -($==) = mkBinop NEq --- | Inequality: @!=@ -($!=) = mkBinop NNEq --- | Less than: @<@ -($<) = mkBinop NLt --- | Less than OR equal: @<=@ -($<=) = mkBinop NLte +(@@) = mkApp +infixl 8 @@ + +-- | List concatenation: @++@ +($++) = mkOp2 NConcat +infixr 7 $++ + +-- | Multiplication: @*@ +($*) = mkOp2 NMult +infixl 6 $* + +-- | Division: @/@ +($/) = mkOp2 NDiv +infixl 6 $/ + +-- | Addition: @+@ +($+) = mkOp2 NPlus +infixl 5 $+ + +-- | Subtraction: @-@ +($-) = mkOp2 NMinus +infixl 5 $- + +-- | Extend/override the left attr set, with the right one: @//@ +($//) = mkOp2 NUpdate +infixr 5 $// + -- | Greater than: @>@ -($>) = mkBinop NGt +($>) = mkOp2 NGt +infix 4 $> + -- | Greater than OR equal: @>=@ -($>=) = mkBinop NGte +infix 4 $>= +($>=) = mkOp2 NGte + +-- | Less than OR equal: @<=@ +($<=) = mkOp2 NLte +infix 4 $<= + +-- | Less than: @<@ +($<) = mkOp2 NLt +infix 4 $< + +-- | Equality: @==@ +($==) = mkOp2 NEq +infix 3 $== + +-- | Inequality: @!=@ +($!=) = mkOp2 NNEq +infix 3 $!= + -- | AND: @&&@ -($&&) = mkBinop NAnd +($&&) = mkOp2 NAnd +infixl 2 $&& + -- | OR: @||@ -($||) = mkBinop NOr --- | Logical implication: @->@ -($->) = mkBinop NImpl --- | Extend/override the left attr set, with the right one: @//@ -($//) = mkBinop NUpdate --- | Addition: @+@ -($+) = mkBinop NPlus --- | Subtraction: @-@ -($-) = mkBinop NMinus --- | Multiplication: @*@ -($*) = mkBinop NMult --- | Division: @/@ -($/) = mkBinop NDiv --- | List concatenation: @++@ -($++) = mkBinop NConcat +($||) = mkOp2 NOr +infixl 2 $|| +-- | Logical implication: @->@ +($->) = mkOp2 NImpl +infix 1 $-> --- | Lambda function. --- > x ==> x ---Haskell: --- > \\ x -> x ---Nix: --- > x: x +-- | Lambda function, analog of Haskell's @\\ x -> x@: +-- +-- +---------------+-----------+ +-- | Haskell | Nix | +-- +===============+===========+ +-- | @x ==> expr @ | @x: expr@ | +-- +---------------+-----------+ (==>) :: Params NExpr -> NExpr -> NExpr (==>) = mkFunction infixr 1 ==> --- | Dot-reference into an attribute set: @attrSet.k@ -(@.) :: NExpr -> Text -> NExpr -(@.) obj name = Fix $ NSelect obj (StaticKey name :| mempty) Nothing -infixl 2 @. + +-- * Under deprecation + +-- NOTE: Remove after 2023-07 +-- | __@Deprecated@__: Please, use `mkOp` +-- Put an unary operator. +mkOper :: NUnaryOp -> NExpr -> NExpr +mkOper = mkOp + +-- NOTE: Remove after 2023-07 +-- | __@Deprecated@__: Please, use `mkOp2` +-- | Put a binary operator. +mkOper2 :: NBinaryOp -> NExpr -> NExpr -> NExpr +mkOper2 = mkOp2 + +-- NOTE: Remove after 2023-07 +-- | __@Deprecated@__: Please, use `mkOp2` +-- | Nix binary operator builder. +mkBinop :: NBinaryOp -> NExpr -> NExpr -> NExpr +mkBinop = mkOp2 + +-- NOTE: Remove after 2023-07 +-- | __@Deprecated@__: Please, use: +-- * `mkParamSet` is for closed sets; +-- * `mkVariadicSet` is for variadic; +-- * `mkGeneralParamSet` a general constructor. +mkParamset :: [(Text, Maybe NExpr)] -> Bool -> Params NExpr +mkParamset params variadic = ParamSet Nothing (Variadic `whenTrue` variadic) (coerce params) 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,8 +1,7 @@ - -- | Functions for manipulating nix strings. module Nix.Expr.Strings where -import Nix.Utils +import Nix.Prelude import Relude.Unsafe as Unsafe -- Please, switch things to NonEmpty import Data.List ( dropWhileEnd @@ -10,7 +9,7 @@ , lookup ) import qualified Data.Text as T -import Nix.Expr +import Nix.Expr.Types -- | Merge adjacent @Plain@ values with @<>@. mergePlain :: [Antiquoted Text r] -> [Antiquoted Text r] @@ -22,8 +21,8 @@ -- | Remove 'Plain' values equal to 'mempty', as they don't have any -- informational content. -removePlainEmpty :: [Antiquoted Text r] -> [Antiquoted Text r] -removePlainEmpty = filter f where +removeEmptyPlains :: [Antiquoted Text r] -> [Antiquoted Text r] +removeEmptyPlains = filter f where f (Plain x) = x /= mempty f _ = True @@ -40,19 +39,22 @@ 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 where +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 [] = (mempty, mempty) + 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 -- of 'splitLines'. unsplitLines :: [[Antiquoted Text r]] -> [Antiquoted Text r] -unsplitLines = intercalate [Plain "\n"] +unsplitLines = intercalate $ one $ Plain "\n" -- | Form an indented string by stripping spaces equal to the minimal indent. stripIndent :: [Antiquoted Text r] -> NString r @@ -60,7 +62,7 @@ stripIndent xs = Indented minIndent - (removePlainEmpty $ + (removeEmptyPlains $ mergePlain $ (snd <$>) $ dropWhileEnd @@ -70,7 +72,7 @@ where pairWithLast ys = zip - (list + (handlePresence Nothing (pure . Unsafe.last) <$> inits ys @@ -81,7 +83,7 @@ ls' = dropSpaces minIndent <$> ls minIndent = - list + handlePresence 0 (minimum . (countSpaces . mergePlain <$>)) (stripEmptyLines ls) @@ -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` fmap swap escapeCodes) +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 @@ -1,125 +1,211 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} +{-# language ConstraintKinds #-} +{-# language CPP #-} +{-# language DeriveAnyClass #-} +{-# language FunctionalDependencies #-} +{-# language RankNTypes #-} +{-# language TemplateHaskell #-} +{-# language TypeFamilies #-} -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -Wno-missing-signatures #-} +{-# options_ghc -Wno-orphans #-} +{-# options_ghc -Wno-name-shadowing #-} +{-# options_ghc -Wno-missing-signatures #-} -- | The Nix expression type and supporting types. -- --- For a brief introduction of the Nix expression language, see --- . +-- [Brief introduction of the Nix expression language.](https://nixos.org/nix/manual/#ch-expression-language) -- -- This module is a beginning of a deep embedding (term) of a Nix language into Haskell. --- Shallow/deep embedding brief: --- +-- [Brief on shallow & deep embedding.](https://web.archive.org/web/20201112031804/https://alessandrovermeulen.me/2013/07/13/the-difference-between-shallow-and-deep-embedding/) -- --- (additiona info for dev): Big use of TemplateHaskell in the module requires proper (top-down) organization of declarations -module Nix.Expr.Types where +-- (additiona info for dev): Big use of TemplateHaskell in the module requires proper (top-down) organization of declarations. +module Nix.Expr.Types + ( module Nix.Expr.Types + , SourcePos(..) + , unPos + , mkPos + ) +where -import qualified Codec.Serialise as Serialise +import Nix.Prelude +import qualified Codec.Serialise as Serialise import Codec.Serialise ( Serialise ) -import Control.DeepSeq +import Control.DeepSeq ( NFData1(..) ) import Data.Aeson -import Data.Aeson.TH import qualified Data.Binary as Binary import Data.Binary ( Binary ) import Data.Data -import Data.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 +import Data.Traversable ( fmapDefault, foldMapDefault ) import GHC.Generics import qualified Language.Haskell.TH.Syntax as TH import Lens.Family2 import Lens.Family2.TH -import Text.Megaparsec.Pos ( SourcePos(SourcePos) - , Pos +import Text.Megaparsec.Pos ( Pos , mkPos , unPos + , SourcePos(SourcePos) ) -import Text.Show.Deriving -import Text.Read.Deriving -import Data.Eq.Deriving -import Data.Ord.Deriving +import Text.Show.Deriving ( deriveShow1, deriveShow2 ) +import Text.Read.Deriving ( deriveRead1, deriveRead2 ) +import Data.Eq.Deriving ( deriveEq1 , deriveEq2 ) +import Data.Ord.Deriving ( deriveOrd1 , deriveOrd2 ) +import Data.Aeson.TH ( deriveJSON2 ) import qualified Type.Reflection as Reflection -import Type.Reflection ( eqTypeRep ) import Nix.Atoms -import Nix.Utils #if !MIN_VERSION_text(1,2,4) -- NOTE: Remove package @th-lift-instances@ removing this -import Instances.TH.Lift () -- importing Lift Text fo GHC 8.6 +import Instances.TH.Lift () -- importing Lift Text for GHC 8.6 #endif --- * Utilitary: orphan instances +-- * utils --- Placed here because TH inference depends on declaration sequence. +newtype NPos = NPos Pos + deriving + ( Eq, Ord + , Read, Show + , Data, NFData + , Generic + ) --- Upstreaming so far was not pursued. +instance Semigroup NPos where + (NPos x) <> (NPos y) = NPos (x <> y) -instance Serialise Pos where - encode = Serialise.encode . unPos - decode = mkPos <$> Serialise.decode +-- | Represents source positions. +-- Source line & column positions change intensively during parsing, +-- so they are declared strict to avoid memory leaks. +-- +-- The data type is a reimplementation of 'Text.Megaparsec.Pos' 'SourcePos'. +data NSourcePos = + NSourcePos + { -- | Name of source file + getSourceName :: Path, + -- | Line number + getSourceLine :: !NPos, + -- | Column number + getSourceColumn :: !NPos + } + deriving + ( Eq, Ord + , Read, Show + , Data, NFData + , Generic + ) -instance Serialise SourcePos where - encode (SourcePos f l c) = +-- | Helper for 'SourcePos' -> 'NSourcePos' coersion. +toNSourcePos :: SourcePos -> NSourcePos +toNSourcePos (SourcePos f l c) = + NSourcePos (coerce f) (coerce l) (coerce c) + +-- | Helper for 'NSourcePos' -> 'SourcePos' coersion. +toSourcePos :: NSourcePos -> SourcePos +toSourcePos (NSourcePos f l c) = + SourcePos (coerce f) (coerce l) (coerce c) + +-- 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 NSourcePos@. +type PositionSet = AttrSet NSourcePos + +-- ** Additional N{,Source}Pos instances + +-- Placed here because TH inference depends on declaration sequence. + +instance Serialise NPos where + encode = Serialise.encode . unPos . coerce + decode = coerce . mkPos <$> Serialise.decode + +instance Serialise NSourcePos where + encode (NSourcePos f l c) = + coerce $ Serialise.encode f <> Serialise.encode l <> Serialise.encode c decode = - liftA3 SourcePos + liftA3 NSourcePos Serialise.decode Serialise.decode Serialise.decode -instance Hashable Pos where - hashWithSalt salt = hashWithSalt salt . unPos +instance Hashable NPos where + hashWithSalt salt = hashWithSalt salt . unPos . coerce -instance Hashable SourcePos where - hashWithSalt salt (SourcePos f l c) = +instance Hashable NSourcePos where + hashWithSalt salt (NSourcePos f l c) = salt `hashWithSalt` f `hashWithSalt` l `hashWithSalt` c -instance Binary Pos where - put = Binary.put . unPos - get = mkPos <$> Binary.get -instance Binary SourcePos - -instance ToJSON Pos where - toJSON = toJSON . unPos -instance ToJSON SourcePos +instance Binary NPos where + put = (Binary.put @Int) . unPos . coerce + get = coerce . mkPos <$> Binary.get +instance Binary NSourcePos -instance FromJSON Pos where - parseJSON = fmap mkPos . parseJSON -instance FromJSON SourcePos +instance ToJSON NPos where + toJSON = toJSON . unPos . coerce +instance ToJSON NSourcePos +instance FromJSON NPos where + parseJSON = coerce . fmap mkPos . parseJSON +instance FromJSON NSourcePos -- * Components of Nix expressions -- NExpr is a composition of --- * direct reuse of the Haskell types (list, FilePath, Text) +-- * direct reuse of the Haskell types (list, Path, Text) -- * NAtom -- * Types in this section -- * Fixpoint nature -type VarName = Text +-- ** newtype VarName +newtype VarName = VarName Text + deriving + ( Eq, Ord, Generic + , Typeable, Data, NFData, Serialise, Binary, ToJSON, FromJSON + , Show, Read, Hashable + ) --- ** @Params@ +instance IsString VarName where + fromString = coerce . fromString @Text +instance ToString VarName where + toString = toString @Text . coerce + +-- ** data Params + +-- *** utils + -- This uses an association list because nix XML serialization preserves the -- order of the param set. type ParamSet r = [(VarName, Maybe r)] +data Variadic = Closed | Variadic + deriving + ( Eq, Ord, Generic + , Typeable, Data, NFData, Serialise, Binary, ToJSON, FromJSON + , Show, Read, Hashable + ) + +instance Semigroup Variadic where + (<>) Closed Closed = Closed + (<>) _ _ = Variadic + +instance Monoid Variadic where + mempty = Closed + +-- *** data Params + -- | @Params@ represents all the ways the formal parameters to a -- function can be represented. data Params r @@ -127,20 +213,18 @@ -- ^ For functions with a single named argument, such as @x: x + 1@. -- -- > Param "x" ~ x - | ParamSet !(ParamSet r) !Bool !(Maybe VarName) - -- 2021-05-15: NOTE: Seems like we should flip the ParamSet, so partial application kicks in for Bool? - -- 2021-05-15: NOTE: '...' variadic property probably needs a Bool synonym. + | ParamSet !(Maybe VarName) !Variadic !(ParamSet r) -- ^ Explicit parameters (argument must be a set). Might specify a name to -- bind to the set in the function body. The bool indicates whether it is -- variadic or not. -- - -- > ParamSet [("x",Nothing)] False Nothing ~ { x } - -- > ParamSet [("x",pure y)] True (pure "s") ~ s@{ x ? y, ... } + -- > ParamSet Nothing False [("x",Nothing)] ~ { x } + -- > ParamSet (pure "s") True [("x", pure y)] ~ s@{ x ? y, ... } deriving ( Eq, Ord, Generic, Generic1 , Typeable, Data, NFData, NFData1, Serialise, Binary, ToJSON, ToJSON1, FromJSON, FromJSON1 , Functor, Foldable, Traversable - , Show, Hashable + , Show, Read, Hashable ) instance IsString (Params r) where @@ -153,12 +237,12 @@ deriving instance Hashable1 Params --- *** Lens traversals +-- *** lens traversals $(makeTraversals ''Params) --- ** @Antiquoted@ +-- ** data Antiquoted -- | 'Antiquoted' represents an expression that is either -- antiquoted (surrounded by ${...}) or plain (not antiquoted). @@ -181,11 +265,6 @@ , 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) @@ -196,26 +275,31 @@ $(deriveOrd2 ''Antiquoted) $(deriveJSON2 defaultOptions ''Antiquoted) -deriving instance Hashable v => Hashable1 (Antiquoted v) +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 --- *** Lens traversals +deriving instance (Hashable v) => Hashable1 (Antiquoted (v :: Type)) +-- *** lens traversals + $(makeTraversals ''Antiquoted) --- ** @NString@ +-- ** data NString -- | An 'NString' is a list of things that are either a plain string -- or an antiquoted expression. After the antiquotes have been evaluated, -- the final string is constructed by concatenating all the parts. data NString r = DoubleQuoted ![Antiquoted Text r] - -- ^ Strings wrapped with double-quotes (") can contain literal newline + -- ^ Strings wrapped with double-quotes (__@"@__) can contain literal newline -- characters, but the newlines are preserved and no indentation is stripped. -- -- > DoubleQuoted [Plain "x",Antiquoted y] ~ "x${y}" | Indented !Int ![Antiquoted Text r] - -- ^ Strings wrapped with two single quotes ('') can contain newlines, and + -- ^ Strings wrapped with two single quotes (__@''@__) can contain newlines, and -- their indentation will be stripped, but the amount stripped is -- remembered. -- @@ -236,7 +320,7 @@ -- | For the the 'IsString' instance, we use a plain doublequoted string. instance IsString (NString r) where fromString "" = DoubleQuoted mempty - fromString string = DoubleQuoted [Plain $ toText string] + fromString string = DoubleQuoted $ one $ Plain $ fromString string $(deriveShow1 ''NString) $(deriveRead1 ''NString) @@ -245,12 +329,12 @@ deriving instance Hashable1 NString --- *** Lens traversals +-- *** lens traversals $(makeTraversals ''NString) --- ** @NKeyName@ +-- ** data NKeyName -- | A 'KeyName' is something that can appear on the left side of an -- equals sign. For example, @a@ is a 'KeyName' in @{ a = 3; }@, @let a = 3; @@ -287,9 +371,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. @@ -318,11 +402,12 @@ -- occurs not only as last argument in @Antiquoted (NString r) r@ instance Show1 NKeyName where liftShowsPrec sp sl p = \case - DynamicKey a -> showsUnaryWith - (liftShowsPrec2 (liftShowsPrec sp sl) (liftShowList sp sl) sp sl) - "DynamicKey" - p - a + DynamicKey a -> + showsUnaryWith + (liftShowsPrec2 (liftShowsPrec sp sl) (liftShowList sp sl) sp sl) + "DynamicKey" + p + a StaticKey t -> showsUnaryWith Text.Show.showsPrec "StaticKey" p t -- Deriving this instance automatically is not possible because @r@ @@ -344,12 +429,12 @@ DynamicKey EscapedNewline -> pure $ DynamicKey EscapedNewline StaticKey key -> pure $ StaticKey key --- *** Lens traversals +-- *** lens traversals $(makeTraversals ''NKeyName) --- ** @NAttrPath@ +-- ** type NAttrPath -- | A selector (for example in a @let@ or an attribute set) is made up -- of strung-together key names. @@ -358,7 +443,7 @@ type NAttrPath r = NonEmpty (NKeyName r) --- ** @Binding@ +-- ** data Binding #if !MIN_VERSION_hashable(1,3,1) -- Required by Hashable Binding deriving. There was none of this Hashable instance before mentioned version, remove this in year >2022 @@ -367,23 +452,23 @@ -- | A single line of the bindings section of a let expression or of a set. data Binding r - = NamedVar !(NAttrPath r) !r !SourcePos + = NamedVar !(NAttrPath r) !r !NSourcePos -- ^ An explicit naming. -- - -- > NamedVar (StaticKey "x" :| [StaticKey "y"]) z SourcePos{} ~ x.y = z; - | Inherit !(Maybe r) ![NKeyName r] !SourcePos + -- > NamedVar (StaticKey "x" :| [StaticKey "y"]) z NSourcePos{} ~ x.y = z; + | Inherit !(Maybe r) ![VarName] !NSourcePos -- ^ Inheriting an attribute (binding) into the attribute set from the other scope (attribute set). No denoted scope means to inherit from the closest outside scope. -- - -- +---------------------------------------------------------------+--------------------+-----------------------+ - -- | Hask | Nix | pseudocode | - -- +===============================================================+====================+=======================+ - -- | @Inherit Nothing [StaticKey "a"] SourcePos{}@ | @inherit a;@ | @a = outside.a;@ | - -- +---------------------------------------------------------------+--------------------+-----------------------+ - -- | @Inherit (pure x) [StaticKey "a"] SourcePos{}@ | @inherit (x) a;@ | @a = x.a;@ | - -- +---------------------------------------------------------------+--------------------+-----------------------+ - -- | @Inherit (pure x) [StaticKey "a", StaticKey "b"] SourcePos{}@ | @inherit (x) a b;@ | @a = x.a;@ | - -- | | | @b = x.b;@ | - -- +---------------------------------------------------------------+--------------------+-----------------------+ + -- +----------------------------------------------------------------+--------------------+-----------------------+ + -- | Hask | Nix | pseudocode | + -- +================================================================+====================+=======================+ + -- | @Inherit Nothing [StaticKey "a"] NSourcePos{}@ | @inherit a;@ | @a = outside.a;@ | + -- +----------------------------------------------------------------+--------------------+-----------------------+ + -- | @Inherit (pure x) [StaticKey "a"] NSourcePos{}@ | @inherit (x) a;@ | @a = x.a;@ | + -- +----------------------------------------------------------------+--------------------+-----------------------+ + -- | @Inherit (pure x) [StaticKey "a", StaticKey "b"] NSourcePos{}@ | @inherit (x) a b;@ | @a = x.a;@ | + -- | | | @b = x.b;@ | + -- +----------------------------------------------------------------+--------------------+-----------------------+ -- -- (2021-07-07 use details): -- Inherits the position of the first name through @unsafeGetAttrPos@. The position of the scope inherited from else - the position of the first member of the binds list. @@ -401,27 +486,33 @@ deriving instance Hashable1 Binding --- *** Lens traversals +-- *** lens traversals $(makeTraversals ''Binding) --- ** @NRecordType@ +-- ** data Recursivity --- | 'NRecordType' distinguishes between recursive and non-recursive attribute +-- | Distinguishes between recursive and non-recursive. Mainly for attribute -- sets. -data NRecordType - = NNonRecursive -- ^ > { ... } - | NRecursive -- ^ > rec { ... } +data Recursivity + = NonRecursive -- ^ > { ... } + | Recursive -- ^ > rec { ... } deriving ( Eq, Ord, Enum, Bounded, Generic , Typeable, Data, NFData, Serialise, Binary, ToJSON, FromJSON , Show, Read, Hashable ) +instance Semigroup Recursivity where + (<>) NonRecursive NonRecursive = NonRecursive + (<>) _ _ = Recursive --- ** @NUnaryOp@ +instance Monoid Recursivity where + mempty = NonRecursive +-- ** data NUnaryOp + -- | There are two unary operations: logical not and integer negation. data NUnaryOp = NNeg -- ^ @-@ @@ -432,12 +523,11 @@ , Show, Read, Hashable ) --- *** Lens traversals +-- *** lens traversals $(makeTraversals ''NUnaryOp) - --- ** @NBinaryOp@ +-- ** data NBinaryOp -- | Binary operators expressible in the nix language. data NBinaryOp @@ -456,23 +546,20 @@ | NMult -- ^ Multiplication (@*@) | NDiv -- ^ Division (@/@) | NConcat -- ^ List concatenation (@++@) - | NApp -- ^ Apply a function to an argument. - -- - -- > NBinary NApp f x ~ f x deriving ( Eq, Ord, Enum, Bounded, Generic , Typeable, Data, NFData, Serialise, Binary, ToJSON, FromJSON , Show, Read, Hashable ) --- *** Lens traversals +-- *** lens traversals $(makeTraversals ''NBinaryOp) --- ** @NExprF@ - Nix expressions, base functor +-- * 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. @@ -490,23 +577,27 @@ -- ^ A list literal. -- -- > NList [x,y] ~ [ x y ] - | NSet !NRecordType ![Binding r] + | NSet !Recursivity ![Binding r] -- ^ An attribute set literal -- - -- > NSet NRecursive [NamedVar x y _] ~ rec { x = y; } - -- > NSet NNonRecursive [Inherit Nothing [x] _] ~ { inherit x; } - | NLiteralPath !FilePath + -- > NSet Recursive [NamedVar x y _] ~ rec { x = y; } + -- > NSet NonRecursive [Inherit Nothing [x] _] ~ { inherit x; } + | NLiteralPath !Path -- ^ A path expression, which is evaluated to a store path. The path here -- can be relative, in which case it's evaluated relative to the file in -- which it appears. -- -- > NLiteralPath "/x" ~ /x -- > NLiteralPath "x/y" ~ x/y - | NEnvPath !FilePath + | NEnvPath !Path -- ^ A path which refers to something in the Nix search path (the NIX_PATH -- environment variable. For example, @@. -- -- > NEnvPath "x" ~ + | NApp !r !r + -- ^ Functional application (aka F.A., apply a function to an argument). + -- + -- > NApp f x ~ f x | NUnary !NUnaryOp !r -- ^ Application of a unary operator to an expression. -- @@ -517,14 +608,12 @@ -- -- > NBinary NPlus x y ~ x + y -- > NBinary NApp f x ~ f x - | NSelect !r !(NAttrPath r) !(Maybe r) - -- 2021-05-15: NOTE: Default value should be first argument to leverage partial application. - -- Cascading change diff is not that big. + | NSelect !(Maybe r) !r !(NAttrPath r) -- ^ Dot-reference into an attribute set, optionally providing an -- alternative if the key doesn't exist. -- - -- > NSelect s (x :| []) Nothing ~ s.x - -- > NSelect s (x :| []) (pure y) ~ s.x or y + -- > NSelect Nothing s (x :| []) ~ s.x + -- > NSelect (pure y) s (x :| []) ~ s.x or y | NHasAttr !r !(NAttrPath r) -- ^ Ask if a set contains a given attribute path. -- @@ -549,7 +638,7 @@ -- -- > NWith x y ~ with x; y | NAssert !r !r - -- ^ Assert that the first returns @true@ before evaluating the second. + -- ^ Checks that the first argument is a predicate that is @true@ before evaluating the second argument. -- -- > NAssert x y ~ assert x; y | NSynHole !VarName @@ -573,12 +662,12 @@ deriving instance Hashable1 NExprF --- *** Lens traversals +-- ** lens traversals $(makeTraversals ''NExprF) --- *** @NExpr@ +-- ** type NExpr -- | The monomorphic expression type is a fixed point of the polymorphic one. type NExpr = Fix NExprF @@ -600,13 +689,13 @@ -- Reflection is a key strategy in metaprogramming. -- HRefl <- - eqTypeRep + Reflection.eqTypeRep (Reflection.typeRep @Text) (Reflection.typeOf b ) pure [| $(TH.lift b) |] ) #if MIN_VERSION_template_haskell(2,17,0) - liftTyped = TH.liftTyped + liftTyped = TH.unsafeCodeCoerce . TH.lift #elif MIN_VERSION_template_haskell(2,16,0) liftTyped = TH.unsafeTExpCoerce . TH.lift #endif @@ -624,31 +713,47 @@ #else hashAt :: VarName -> Lens' (AttrSet v) (Maybe v) #endif -hashAt = flip alterF +hashAt = alterF + where + alterF + :: (Functor f) + => VarName + -> (Maybe v -> f (Maybe v)) + -> AttrSet v + -> f (AttrSet v) + alterF (coerce -> k) f m = + maybe + (MapL.delete k m) + (\ v -> MapL.insert k v m) + <$> f (MapL.lookup k m) -- | Get the name out of the parameter (there might be none). paramName :: Params r -> Maybe VarName -paramName (Param n ) = pure n -paramName (ParamSet _ _ n) = n +paramName (Param name ) = pure name +paramName (ParamSet mname _ _) = mname +stringParts :: NString r -> [Antiquoted Text r] +stringParts (DoubleQuoted parts) = parts +stringParts (Indented _ parts) = parts + stripPositionInfo :: NExpr -> NExpr stripPositionInfo = transport phi where transport f (Fix x) = Fix $ transport f <$> f x - phi (NSet recur binds) = NSet recur $ go <$> binds - phi (NLet binds body) = NLet (go <$> binds) body + phi (NSet recur binds) = NSet recur $ erasePositions <$> binds + phi (NLet binds body) = NLet (erasePositions <$> binds) body phi x = x - go (NamedVar path r _pos) = NamedVar path r nullPos - go (Inherit ms names _pos) = Inherit ms names nullPos + erasePositions (NamedVar path r _pos) = NamedVar path r nullPos + erasePositions (Inherit ms names _pos) = Inherit ms names nullPos -nullPos :: SourcePos -nullPos = on (SourcePos "") mkPos 1 1 +nullPos :: NSourcePos +nullPos = on (NSourcePos "") (coerce . mkPos) 1 1 -- * Dead code --- ** @class NExprAnn@ +-- ** class NExprAnn class NExprAnn ann g | g -> ann where fromNExpr :: g r -> (NExprF r, ann) @@ -657,37 +762,108 @@ -- ** Other ekey - :: NExprAnn ann g - => NonEmpty Text - -> SourcePos + :: forall ann g + . NExprAnn ann g + => NonEmpty VarName + -> NSourcePos -> Lens' (Fix g) (Maybe (Fix g)) -ekey keys pos f e@(Fix x) | (NSet NNonRecursive xs, ann) <- fromNExpr x = - case go xs of - ((v, [] ) : _) -> fromMaybe e <$> f (pure v) - ((v, r : rest) : _) -> ekey (r :| rest) pos f v +ekey keys pos f e@(Fix x) + | (NSet NonRecursive xs, ann) <- fromNExpr x = + let + vals :: [(Fix g, [VarName])] + vals = + do + let keys' = NE.toList keys + (ks, rest) <- zip (inits keys') (tails keys') + handlePresence + mempty + (\ (j : js) -> + do + NamedVar ns v _p <- xs + guard $ (j : js) == (NE.toList ns ^.. traverse . _StaticKey) + pure (v, rest) + ) + ks + in + case vals of + ((v, [] ) : _) -> fromMaybe e <$> f (pure v) + ((v, r : rest) : _) -> ekey (r :| rest) pos f v - _ -> - maybe - e - (\ v -> - let entry = NamedVar (StaticKey <$> keys) v pos in - Fix $ toNExpr ( NSet NNonRecursive $ [entry] <> xs, ann ) - ) - <$> - f Nothing - where - go xs = - do - let keys' = NE.toList keys - (ks, rest) <- zip (inits keys') (tails keys') - list - mempty - (\ (j : js) -> - do - NamedVar ns v _p <- xs - guard $ (j : js) == (NE.toList ns ^.. traverse . _StaticKey) - pure (v, rest) + _ -> + maybe + e + (\ v -> + let entry = NamedVar (StaticKey <$> keys) v pos in + Fix $ toNExpr ( NSet mempty $ one entry <> xs, ann ) ) - ks - + <$> 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 + (NApp left right ) -> collectFreeVars left right + (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 @@ -1,21 +1,19 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} +{-# language CPP #-} +{-# language DeriveAnyClass #-} +{-# language KindSignatures #-} +{-# language PatternSynonyms #-} +{-# language RankNTypes #-} +{-# language TemplateHaskell #-} -- | The source location annotated nix expression type and supporting types. -- module Nix.Expr.Types.Annotated ( module Nix.Expr.Types.Annotated , module Data.Functor.Compose - , SourcePos(..) - , unPos - , mkPos ) where +import Nix.Prelude import Codec.Serialise import Control.DeepSeq import Data.Aeson ( ToJSON(..) @@ -26,17 +24,14 @@ import Data.Data import Data.Eq.Deriving import Data.Fix ( Fix(..) - , unfoldFix ) + , unfoldFix + ) import Data.Functor.Compose import Data.Hashable.Lifted import Data.Ord.Deriving import GHC.Generics import Nix.Atoms import Nix.Expr.Types -import Text.Megaparsec ( unPos - , mkPos - ) -import Text.Megaparsec.Pos ( SourcePos(..) ) import Text.Read.Deriving import Text.Show.Deriving @@ -44,18 +39,18 @@ -- | Demarcation of a chunk in a source file. data SrcSpan = SrcSpan - { spanBegin :: SourcePos - , spanEnd :: SourcePos - } - deriving (Ord, Eq, Generic, Typeable, Data, Show, NFData, Hashable) + { getSpanBegin :: NSourcePos + , getSpanEnd :: NSourcePos + } + deriving (Ord, Eq, Generic, Typeable, Data, Show, NFData, Hashable) -- ** Instances instance Semigroup SrcSpan where s1 <> s2 = SrcSpan - ((min `on` spanBegin) s1 s2) - ((max `on` spanEnd ) s1 s2) + (on min getSpanBegin s1 s2) + (on max getSpanEnd s1 s2) instance Binary SrcSpan instance ToJSON SrcSpan @@ -65,70 +60,78 @@ -- * data type @Ann@ +-- 2021-08-02: NOTE: Annotation needs to be after what is annotated. -- | A type constructor applied to a type along with an annotation -- -- Intended to be used with 'Fix': --- @type MyType = Fix (Compose (Ann Annotation) F)@ -data Ann ann a = Ann - { annotation :: ann - , annotated :: a - } - deriving (Ord, Eq, Data, Generic, Generic1, Typeable, Functor, Foldable, - Traversable, Read, Show, NFData, Hashable) +-- @type MyType = Fix (Compose (AnnUnit Annotation) F)@ +data AnnUnit ann expr = AnnUnit + { annotation :: ann + , annotated :: expr + } + deriving + ( Eq, Ord, Data, Typeable, Hashable + , Generic, Generic1, NFData + , Functor, Foldable, Traversable + , Show, Read + ) -type AnnF ann f = Compose (Ann ann) f +type AnnF ann f = Compose (AnnUnit ann) f --- | Pattern: @(Compose (Ann _ _))@. -pattern AnnFP +-- | Pattern: @(Compose (AnnUnit _ _))@. +pattern AnnF :: ann -> f a - -> Compose (Ann ann) f a -pattern AnnFP ann f = Compose (Ann ann f) -{-# complete AnnFP #-} + -> Compose (AnnUnit ann) f a +pattern AnnF ann f = Compose (AnnUnit ann f) +{-# complete AnnF #-} --- | Pattern: @Fix (Compose (Ann _ _))@. + +type Ann ann f = Fix (AnnF ann f) + +-- | Pattern: @Fix (Compose (AnnUnit _ _))@. -- Fix composes units of (annotations & the annotated) into one object. -- Giving annotated expression. -pattern AnnE +pattern Ann :: forall ann (f :: Type -> Type) . ann - -> f (Fix (AnnF ann f)) - -> Fix (AnnF ann f) -pattern AnnE ann a = Fix (AnnFP ann a) -{-# complete AnnE #-} + -> f (Ann ann f) + -> Ann ann f +pattern Ann ann a = Fix (AnnF ann a) +{-# complete Ann #-} -annToAnnF :: Ann ann (f (Fix (AnnF ann f))) -> Fix (AnnF ann f) -annToAnnF (Ann ann a) = AnnE ann a +annUnitToAnn :: AnnUnit ann (f (Ann ann f)) -> Ann ann f +annUnitToAnn (AnnUnit ann a) = Ann ann a -- ** Instances -instance Hashable ann => Hashable1 (Ann ann) +instance NFData ann => NFData1 (AnnUnit ann) -instance NFData ann => NFData1 (Ann ann) +instance (Binary ann, Binary a) => Binary (AnnUnit ann a) -instance (Binary ann, Binary a) => Binary (Ann ann a) +$(deriveEq1 ''AnnUnit) +$(deriveEq2 ''AnnUnit) +$(deriveOrd1 ''AnnUnit) +$(deriveOrd2 ''AnnUnit) +$(deriveRead1 ''AnnUnit) +$(deriveRead2 ''AnnUnit) +$(deriveShow1 ''AnnUnit) +$(deriveShow2 ''AnnUnit) +$(deriveJSON1 defaultOptions ''AnnUnit) +$(deriveJSON2 defaultOptions ''AnnUnit) -$(deriveEq1 ''Ann) -$(deriveEq2 ''Ann) -$(deriveOrd1 ''Ann) -$(deriveOrd2 ''Ann) -$(deriveRead1 ''Ann) -$(deriveRead2 ''Ann) -$(deriveShow1 ''Ann) -$(deriveShow2 ''Ann) -$(deriveJSON1 defaultOptions ''Ann) -$(deriveJSON2 defaultOptions ''Ann) +instance Hashable ann => Hashable1 (AnnUnit ann) -instance (Serialise ann, Serialise a) => Serialise (Ann ann a) +instance (Serialise ann, Serialise a) => Serialise (AnnUnit ann a) -- ** @NExprLoc{,F}@ - annotated Nix expression type NExprLocF = AnnF SrcSpan NExprF instance Serialise r => Serialise (NExprLocF r) where - encode (AnnFP ann a) = encode ann <> encode a + encode (AnnF ann a) = encode ann <> encode a decode = - liftA2 AnnFP + liftA2 AnnF decode decode @@ -143,105 +146,160 @@ -- * Other -stripAnnotation :: Functor f => Fix (AnnF ann f) -> Fix f -stripAnnotation = unfoldFix (stripAnn . unFix) +stripAnnF :: AnnF ann f r -> f r +stripAnnF = annotated . getCompose -stripAnn :: AnnF ann f r -> f r -stripAnn = annotated . getCompose +stripAnnotation :: Functor f => Ann ann f -> Fix f +stripAnnotation = unfoldFix (stripAnnF . unFix) -nUnary :: Ann SrcSpan NUnaryOp -> NExprLoc -> NExprLoc -nUnary (Ann s1 u) e1@(AnnE s2 _) = AnnE (s1 <> s2) $ NUnary u e1 -{-# inline nUnary #-} +annNUnary :: AnnUnit SrcSpan NUnaryOp -> NExprLoc -> NExprLoc +annNUnary (AnnUnit s1 u) e1@(Ann s2 _) = NUnaryAnn (s1 <> s2) u e1 +{-# inline annNUnary #-} -nBinary :: Ann SrcSpan NBinaryOp -> NExprLoc -> NExprLoc -> NExprLoc -nBinary (Ann s1 b) e1@(AnnE s2 _) e2@(AnnE s3 _) = - AnnE (s1 <> s2 <> s3) $ NBinary b e1 e2 +annNBinary :: AnnUnit SrcSpan NBinaryOp -> NExprLoc -> NExprLoc -> NExprLoc +annNBinary (AnnUnit s1 b) e1@(Ann s2 _) e2@(Ann s3 _) = NBinaryAnn (s1 <> s2 <> s3) b e1 e2 -nSelectLoc - :: NExprLoc -> Ann SrcSpan (NAttrPath NExprLoc) -> Maybe NExprLoc -> NExprLoc -nSelectLoc e1@(AnnE s1 _) (Ann s2 ats) = - -- 2021-05-16: NOTE: This could been rewritten into function application of @(s3, pure e2)@ - -- if @SrcSpan@ was Monoid, which requires @SorcePos@ to be a Monoid, and upstream code prevents it. - -- Question upstream: https://github.com/mrkkrp/megaparsec/issues/450 - maybe - ( AnnE s1s2 $ NSelect e1 ats Nothing) - (\ e2@(AnnE s3 _) -> AnnE (s1s2 <> s3) $ NSelect e1 ats $ pure e2) - where - s1s2 = s1 <> s2 +annNSelect + :: Maybe NExprLoc -> NExprLoc -> AnnUnit SrcSpan (NAttrPath NExprLoc) -> NExprLoc +annNSelect Nothing e2@(Ann s2 _) (AnnUnit s1 ats) = NSelectAnn ( s2 <> s1) Nothing e2 ats +annNSelect (Just e3@(Ann s3 _)) e2@(Ann s2 _) (AnnUnit s1 ats) = NSelectAnn (s3 <> s2 <> s1) (pure e3) e2 ats -nHasAttr :: NExprLoc -> Ann SrcSpan (NAttrPath NExprLoc) -> NExprLoc -nHasAttr e1@(AnnE s1 _) (Ann s2 ats) = AnnE (s1 <> s2) $ NHasAttr e1 ats +annNHasAttr :: NExprLoc -> AnnUnit SrcSpan (NAttrPath NExprLoc) -> NExprLoc +annNHasAttr e1@(Ann s1 _) (AnnUnit s2 ats) = NHasAttrAnn (s1 <> s2) e1 ats -nApp :: NExprLoc -> NExprLoc -> NExprLoc -nApp e1@(AnnE s1 _) e2@(AnnE s2 _) = AnnE (s1 <> s2) $ NBinary NApp e1 e2 +annNApp :: NExprLoc -> NExprLoc -> NExprLoc +annNApp e1@(Ann s1 _) e2@(Ann s2 _) = NAppAnn (s1 <> s2) e1 e2 -nAbs :: Ann SrcSpan (Params NExprLoc) -> NExprLoc -> NExprLoc -nAbs (Ann s1 ps) e1@(AnnE s2 _) = AnnE (s1 <> s2) $ NAbs ps e1 +annNAbs :: AnnUnit SrcSpan (Params NExprLoc) -> NExprLoc -> NExprLoc +annNAbs (AnnUnit s1 ps) e1@(Ann s2 _) = NAbsAnn (s1 <> s2) ps e1 -nStr :: Ann SrcSpan (NString NExprLoc) -> NExprLoc -nStr (Ann s1 s) = AnnE s1 $ NStr s +annNStr :: AnnUnit SrcSpan (NString NExprLoc) -> NExprLoc +annNStr (AnnUnit s1 s) = NStrAnn s1 s -deltaInfo :: SourcePos -> (Text, Int, Int) -deltaInfo (SourcePos fp l c) = (toText fp, unPos l, unPos c) +deltaInfo :: NSourcePos -> (Text, Int, Int) +deltaInfo (NSourcePos fp l c) = (fromString $ coerce fp, unPos $ coerce l, unPos $ coerce c) -nNull :: NExprLoc -nNull = AnnE nullSpan $ NConstant NNull -{-# inline nNull #-} +annNNull :: NExprLoc +annNNull = NConstantAnn nullSpan NNull +{-# inline annNNull #-} nullSpan :: SrcSpan nullSpan = SrcSpan nullPos nullPos {-# inline nullSpan #-} --- | Pattern systems for matching on NExprLocF constructions. +-- ** Patterns -pattern NConstant_ :: SrcSpan -> NAtom -> NExprLocF r -pattern NConstant_ ann x = AnnFP ann (NConstant x) +-- *** Patterns to match on 'NExprLocF' constructions (for 'SrcSpan'-based annotations). -pattern NStr_ :: SrcSpan -> NString r -> NExprLocF r -pattern NStr_ ann x = AnnFP ann (NStr x) +pattern NConstantAnnF :: SrcSpan -> NAtom -> NExprLocF r +pattern NConstantAnnF ann x = AnnF ann (NConstant x) -pattern NSym_ :: SrcSpan -> VarName -> NExprLocF r -pattern NSym_ ann x = AnnFP ann (NSym x) +pattern NStrAnnF :: SrcSpan -> NString r -> NExprLocF r +pattern NStrAnnF ann x = AnnF ann (NStr x) -pattern NList_ :: SrcSpan -> [r] -> NExprLocF r -pattern NList_ ann x = AnnFP ann (NList x) +pattern NSymAnnF :: SrcSpan -> VarName -> NExprLocF r +pattern NSymAnnF ann x = AnnF ann (NSym x) -pattern NSet_ :: SrcSpan -> NRecordType -> [Binding r] -> NExprLocF r -pattern NSet_ ann recur x = AnnFP ann (NSet recur x) +pattern NListAnnF :: SrcSpan -> [r] -> NExprLocF r +pattern NListAnnF ann x = AnnF ann (NList x) -pattern NLiteralPath_ :: SrcSpan -> FilePath -> NExprLocF r -pattern NLiteralPath_ ann x = AnnFP ann (NLiteralPath x) +pattern NSetAnnF :: SrcSpan -> Recursivity -> [Binding r] -> NExprLocF r +pattern NSetAnnF ann rec x = AnnF ann (NSet rec x) -pattern NEnvPath_ :: SrcSpan -> FilePath -> NExprLocF r -pattern NEnvPath_ ann x = AnnFP ann (NEnvPath x) +pattern NLiteralPathAnnF :: SrcSpan -> Path -> NExprLocF r +pattern NLiteralPathAnnF ann x = AnnF ann (NLiteralPath x) -pattern NUnary_ :: SrcSpan -> NUnaryOp -> r -> NExprLocF r -pattern NUnary_ ann op x = AnnFP ann (NUnary op x) +pattern NEnvPathAnnF :: SrcSpan -> Path -> NExprLocF r +pattern NEnvPathAnnF ann x = AnnF ann (NEnvPath x) -pattern NBinary_ :: SrcSpan -> NBinaryOp -> r -> r -> NExprLocF r -pattern NBinary_ ann op x y = AnnFP ann (NBinary op x y) +pattern NUnaryAnnF :: SrcSpan -> NUnaryOp -> r -> NExprLocF r +pattern NUnaryAnnF ann op x = AnnF ann (NUnary op x) -pattern NSelect_ :: SrcSpan -> r -> NAttrPath r -> Maybe r -> NExprLocF r -pattern NSelect_ ann x p v = AnnFP ann (NSelect x p v) +pattern NAppAnnF :: SrcSpan -> r -> r -> NExprLocF r +pattern NAppAnnF ann x y = AnnF ann (NApp x y) -pattern NHasAttr_ :: SrcSpan -> r -> NAttrPath r -> NExprLocF r -pattern NHasAttr_ ann x p = AnnFP ann (NHasAttr x p) +pattern NBinaryAnnF :: SrcSpan -> NBinaryOp -> r -> r -> NExprLocF r +pattern NBinaryAnnF ann op x y = AnnF ann (NBinary op x y) -pattern NAbs_ :: SrcSpan -> Params r-> r -> NExprLocF r -pattern NAbs_ ann x b = AnnFP ann (NAbs x b) +pattern NSelectAnnF :: SrcSpan -> Maybe r -> r -> NAttrPath r -> NExprLocF r +pattern NSelectAnnF ann v x p = AnnF ann (NSelect v x p) -pattern NLet_ :: SrcSpan -> [Binding r] -> r -> NExprLocF r -pattern NLet_ ann x b = AnnFP ann (NLet x b) +pattern NHasAttrAnnF :: SrcSpan -> r -> NAttrPath r -> NExprLocF r +pattern NHasAttrAnnF ann x p = AnnF ann (NHasAttr x p) -pattern NIf_ :: SrcSpan -> r -> r -> r -> NExprLocF r -pattern NIf_ ann c t e = AnnFP ann (NIf c t e) +pattern NAbsAnnF :: SrcSpan -> Params r-> r -> NExprLocF r +pattern NAbsAnnF ann x b = AnnF ann (NAbs x b) -pattern NWith_ :: SrcSpan -> r -> r -> NExprLocF r -pattern NWith_ ann x y = AnnFP ann (NWith x y) +pattern NLetAnnF :: SrcSpan -> [Binding r] -> r -> NExprLocF r +pattern NLetAnnF ann x b = AnnF ann (NLet x b) -pattern NAssert_ :: SrcSpan -> r -> r -> NExprLocF r -pattern NAssert_ ann x y = AnnFP ann (NAssert x y) +pattern NIfAnnF :: SrcSpan -> r -> r -> r -> NExprLocF r +pattern NIfAnnF ann c t e = AnnF ann (NIf c t e) -pattern NSynHole_ :: SrcSpan -> Text -> NExprLocF r -pattern NSynHole_ ann x = AnnFP ann (NSynHole x) -{-# complete NConstant_, NStr_, NSym_, NList_, NSet_, NLiteralPath_, NEnvPath_, NUnary_, NBinary_, NSelect_, NHasAttr_, NAbs_, NLet_, NIf_, NWith_, NAssert_, NSynHole_ #-} +pattern NWithAnnF :: SrcSpan -> r -> r -> NExprLocF r +pattern NWithAnnF ann x y = AnnF ann (NWith x y) + +pattern NAssertAnnF :: SrcSpan -> r -> r -> NExprLocF r +pattern NAssertAnnF ann x y = AnnF ann (NAssert x y) + +pattern NSynHoleAnnF :: SrcSpan -> VarName -> NExprLocF r +pattern NSynHoleAnnF ann x = AnnF ann (NSynHole x) +{-# complete NConstantAnnF, NStrAnnF, NSymAnnF, NListAnnF, NSetAnnF, NLiteralPathAnnF, NEnvPathAnnF, NUnaryAnnF, NBinaryAnnF, NSelectAnnF, NHasAttrAnnF, NAbsAnnF, NLetAnnF, NIfAnnF, NWithAnnF, NAssertAnnF, NSynHoleAnnF #-} + + +-- *** Patterns to match on 'NExprLoc' constructions (for 'SrcSpan'-based annotations). + +pattern NConstantAnn :: SrcSpan -> NAtom -> NExprLoc +pattern NConstantAnn ann x = Ann ann (NConstant x) + +pattern NStrAnn :: SrcSpan -> NString NExprLoc -> NExprLoc +pattern NStrAnn ann x = Ann ann (NStr x) + +pattern NSymAnn :: SrcSpan -> VarName -> NExprLoc +pattern NSymAnn ann x = Ann ann (NSym x) + +pattern NListAnn :: SrcSpan -> [NExprLoc] -> NExprLoc +pattern NListAnn ann x = Ann ann (NList x) + +pattern NSetAnn :: SrcSpan -> Recursivity -> [Binding NExprLoc] -> NExprLoc +pattern NSetAnn ann rec x = Ann ann (NSet rec x) + +pattern NLiteralPathAnn :: SrcSpan -> Path -> NExprLoc +pattern NLiteralPathAnn ann x = Ann ann (NLiteralPath x) + +pattern NEnvPathAnn :: SrcSpan -> Path -> NExprLoc +pattern NEnvPathAnn ann x = Ann ann (NEnvPath x) + +pattern NUnaryAnn :: SrcSpan -> NUnaryOp -> NExprLoc -> NExprLoc +pattern NUnaryAnn ann op x = Ann ann (NUnary op x) + +pattern NAppAnn :: SrcSpan -> NExprLoc -> NExprLoc -> NExprLoc +pattern NAppAnn ann x y = Ann ann (NApp x y) + +pattern NBinaryAnn :: SrcSpan -> NBinaryOp -> NExprLoc -> NExprLoc -> NExprLoc +pattern NBinaryAnn ann op x y = Ann ann (NBinary op x y) + +pattern NSelectAnn :: SrcSpan -> Maybe NExprLoc -> NExprLoc -> NAttrPath NExprLoc -> NExprLoc +pattern NSelectAnn ann v x p = Ann ann (NSelect v x p) + +pattern NHasAttrAnn :: SrcSpan -> NExprLoc -> NAttrPath NExprLoc -> NExprLoc +pattern NHasAttrAnn ann x p = Ann ann (NHasAttr x p) + +pattern NAbsAnn :: SrcSpan -> Params NExprLoc -> NExprLoc -> NExprLoc +pattern NAbsAnn ann x b = Ann ann (NAbs x b) + +pattern NLetAnn :: SrcSpan -> [Binding NExprLoc] -> NExprLoc -> NExprLoc +pattern NLetAnn ann x b = Ann ann (NLet x b) + +pattern NIfAnn :: SrcSpan -> NExprLoc -> NExprLoc -> NExprLoc -> NExprLoc +pattern NIfAnn ann c t e = Ann ann (NIf c t e) + +pattern NWithAnn :: SrcSpan -> NExprLoc -> NExprLoc -> NExprLoc +pattern NWithAnn ann x y = Ann ann (NWith x y) + +pattern NAssertAnn :: SrcSpan -> NExprLoc -> NExprLoc -> NExprLoc +pattern NAssertAnn ann x y = Ann ann (NAssert x y) + +pattern NSynHoleAnn :: SrcSpan -> VarName -> NExprLoc +pattern NSynHoleAnn ann x = Ann ann (NSynHole x) +{-# complete NConstantAnn, NStrAnn, NSymAnn, NListAnn, NSetAnn, NLiteralPathAnn, NEnvPathAnn, NUnaryAnn, NBinaryAnn, NSelectAnn, NHasAttrAnn, NAbsAnn, NLetAnn, NIfAnn, NWithAnn, NAssertAnn, NSynHoleAnn #-} diff --git a/src/Nix/Frames.hs b/src/Nix/Frames.hs --- a/src/Nix/Frames.hs +++ b/src/Nix/Frames.hs @@ -1,38 +1,30 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# language ConstraintKinds #-} +{-# language ExistentialQuantification #-} -- | Definitions of Frames. Frames are messages that gather and ship themself with a context related to the message. For example - the message about some exception would also gather, keep and bring with it the tracing information. module Nix.Frames ( NixLevel(..) , Frames + , askFrames , Framed , NixFrame(..) , NixException(..) , withFrame , throwError , module Data.Typeable - , module Control.Exception ) where -import Prelude hiding ( traceM ) +import Nix.Prelude import Data.Typeable hiding ( typeOf ) import Control.Monad.Catch ( MonadThrow(..) ) -import Control.Exception hiding ( catch - , evaluate - ) import qualified Text.Show -import Nix.Utils ( Has(..) - , view - , over - , traceM - ) data NixLevel = Fatal | Error | Warning | Info | Debug - deriving (Ord, Eq, Bounded, Enum, Show) + deriving (Ord, Eq, Bounded, Enum, Show) -data NixFrame = NixFrame +data NixFrame = + NixFrame { frameLevel :: NixLevel , frame :: SomeException } @@ -43,10 +35,13 @@ 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 - deriving Show + deriving Show instance Exception NixException @@ -56,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 @@ -1,27 +1,27 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# language CPP #-} +{-# language GeneralizedNewtypeDeriving #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} +{-# options_ghc -Wno-orphans #-} module Nix.Fresh where +import Nix.Prelude import Control.Monad.Base ( MonadBase(..) ) import Control.Monad.Catch ( MonadCatch , MonadMask , MonadThrow ) -import Control.Monad.Except ( MonadFix ) +import Control.Monad.Fix ( MonadFix ) import Control.Monad.Ref ( MonadAtomicRef(..) , MonadRef(Ref) ) import Nix.Thunk --- 2021-06-02: NOTE: Remove singleton newtype accessor in favour of free coerce -newtype FreshIdT i m a = FreshIdT { unFreshIdT :: ReaderT (Ref m i) m a } +newtype FreshIdT i m a = FreshIdT (ReaderT (Ref m i) m a) deriving ( Functor , Applicative @@ -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 (unFreshIdT 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 @@ -1,7 +1,6 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# language CPP #-} -{-# OPTIONS_GHC -Wno-orphans #-} +{-# options_ghc -Wno-orphans #-} module Nix.Fresh.Basic where @@ -9,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 @@ -29,19 +29,36 @@ instance (MonadEffects t f m, MonadDataContext f m) => MonadEffects t f (StdIdT m) where - makeAbsolutePath = lift . makeAbsolutePath @t @f @m + + 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,47 +2,62 @@ module Nix.Json where +import Nix.Prelude import qualified Data.Aeson as A import qualified Data.Aeson.Encoding as A -import qualified Data.HashMap.Lazy as HM -import qualified Data.Text.Lazy.Encoding as TL +import qualified Data.Vector as V +import qualified Data.HashMap.Strict as HM #if MIN_VERSION_aeson(2,0,0) import qualified Data.Aeson.Key as AKM import qualified Data.Aeson.KeyMap as AKM -#else -import Nix.Expr.Types #endif -import qualified Data.Vector as V import Nix.Atoms import Nix.Effects import Nix.Exec import Nix.Frames import Nix.String -import Nix.Utils import Nix.Value import Nix.Value.Monad +import Nix.Expr.Types -nvalueToJSONNixString :: MonadNix e t f m => NValue t f m -> m NixString -nvalueToJSONNixString = +-- This was moved from Utils. +toEncodingSorted :: A.Value -> A.Encoding +toEncodingSorted = \case + A.Object m -> + A.pairs + . foldMap + (\(k, v) -> A.pair k $ toEncodingSorted v) + . sortWith fst $ +#if MIN_VERSION_aeson(2,0,0) + AKM.toList +#else + HM.toList +#endif + m + A.Array l -> A.list toEncodingSorted $ V.toList l + v -> A.toEncoding v + +toJSONNixString :: MonadNix e t f m => NValue t f m -> m NixString +toJSONNixString = runWithStringContextT . fmap - ( toStrict - . TL.decodeUtf8 + ( decodeUtf8 + -- This is completely not optimal, but seems we do not have better encoding analog (except for @unsafe*@), Aeson gatekeeps through this. . A.encodingToLazyByteString . 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 NVConstant NNull -> pure A.Null NVStr ns -> A.toJSON <$> extractNixString ns NVList l -> A.Array . V.fromList <$> traverse intoJson l - NVSet m _ -> + NVSet _ m -> maybe (A.Object <$> traverse intoJson kmap) intoJson @@ -50,17 +65,18 @@ where #if MIN_VERSION_aeson(2,0,0) lkup = AKM.lookup - kmap = AKM.fromHashMap (HM.mapKeys (AKM.fromText . coerce) m) + kmap = AKM.fromHashMap $ HM.mapKeys (AKM.fromText . coerce) m #else lkup = HM.lookup kmap = HM.mapKeys (coerce @VarName @Text) m #endif NVPath p -> do - fp <- lift $ unStorePath <$> addPath p - addSingletonStringContext $ StringContext (toText fp) DirectPath + fp <- lift $ coerce <$> addPath p + addSingletonStringContext $ StringContext DirectPath $ fromString fp pure $ A.toJSON fp v -> lift $ throwError $ CoercionToJson v where - intoJson nv = join $ lift $ nvalueToJSON <$> demand nv + intoJson :: MonadNix e t f m => NValue t f m -> WithStringContextT m A.Value + 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 @@ -1,21 +1,19 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# language ConstraintKinds #-} +{-# language CPP #-} +{-# language DataKinds #-} +{-# language GeneralizedNewtypeDeriving #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# OPTIONS_GHC -Wno-missing-methods #-} +{-# options_ghc -fno-warn-name-shadowing #-} +{-# options_ghc -Wno-missing-methods #-} module Nix.Lint where -import Prelude hiding ( head - , force - ) -import Nix.Utils +import Nix.Prelude +import Relude.Unsafe as Unsafe ( head ) +import Control.Exception ( throw ) +import GHC.Exception ( ErrorCall(ErrorCall) ) import Control.Monad ( foldM ) import Control.Monad.Catch import Control.Monad.Fix @@ -23,7 +21,7 @@ import Control.Monad.ST import qualified Data.HashMap.Lazy as M -- Plese, use NonEmpty -import Data.List +import Data.List ( intersect ) import qualified Data.List.NonEmpty as NE import qualified Data.Text as Text import qualified Text.Show @@ -32,7 +30,8 @@ import Nix.Convert import Nix.Eval ( MonadEval(..) ) import qualified Nix.Eval as Eval -import Nix.Expr +import Nix.Expr.Types +import Nix.Expr.Types.Annotated import Nix.Frames import Nix.Fresh import Nix.String @@ -53,7 +52,7 @@ = TConstant [TAtom] | TStr | TList r - | TSet (Maybe (HashMap Text r)) + | TSet (Maybe (AttrSet r)) | TClosure (Params ()) | TPath | TBuiltin Text (Symbolic m -> m r) @@ -103,8 +102,14 @@ :: MonadAtomicRef m => [NTypeF m (Symbolic m)] -> m (Symbolic m) -mkSymbolic xs = packSymbolic (NMany xs) +mkSymbolic = packSymbolic . NMany +mkSymbolic1 + :: MonadAtomicRef m + => NTypeF m (Symbolic m) + -> m (Symbolic m) +mkSymbolic1 = mkSymbolic . one + packSymbolic :: MonadAtomicRef m => NSymbolicF (NTypeF m (Symbolic m)) @@ -129,31 +134,50 @@ symerr = evalError @(Symbolic m) . ErrorCall . toString renderSymbolic :: MonadLint e m => Symbolic m -> m Text -renderSymbolic = unpackSymbolic >=> \case - NAny -> pure "" - NMany xs -> fmap (Text.intercalate ", ") $ forM xs $ \case - TConstant ys -> fmap (Text.intercalate ", ") $ forM ys $ pure . \case - TInt -> "int" - TFloat -> "float" - TBool -> "bool" - TNull -> "null" - TStr -> pure "string" - TList r -> do - x <- renderSymbolic =<< demand r - pure $ "[" <> x <> "]" - TSet Nothing -> pure "" - TSet (Just s) -> do - x <- traverse (renderSymbolic <=< demand) s - pure $ "{" <> show x <> "}" - f@(TClosure p) -> do - (args, sym) <- do - f' <- mkSymbolic [f] - lintApp (NAbs (void p) ()) f' everyPossible - args' <- traverse renderSymbolic args - sym' <- renderSymbolic sym - pure $ "(" <> show args' <> " -> " <> sym' <> ")" - TPath -> pure "path" - TBuiltin _n _f -> pure "" +renderSymbolic = + (\case + NAny -> pure "" + NMany xs -> + Text.intercalate ", " <$> + traverse + (\case + TConstant ys -> + pure $ + Text.intercalate ", " + (fmap + (\case + TInt -> "int" + TFloat -> "float" + TBool -> "bool" + TNull -> "null" + ) + ys + ) + TStr -> pure "string" + TList r -> + fmap brackets $ renderSymbolic =<< demand r + TSet Nothing -> pure "" + TSet (Just s) -> + braces . show <$> traverse (renderSymbolic <=< demand) s + f@(TClosure p) -> + do + (args, sym) <- + do + f' <- mkSymbolic1 f + lintApp (NAbs p mempty) f' everyPossible + args' <- traverse renderSymbolic args + sym' <- renderSymbolic sym + pure $ parens $ show args' <> " -> " <> sym' + TPath -> pure "path" + TBuiltin _n _f -> pure "" + ) + xs + ) <=< unpackSymbolic + where + between a b c = a <> b <> c + parens = between "(" ")" + brackets = between "[" "]" + braces = between "{" "}" -- This function is order and uniqueness preserving (of types). merge @@ -171,51 +195,55 @@ -> m [NTypeF m (Symbolic m)] go [] _ = stub go _ [] = stub - go (x : xs) (y : ys) = case (x, y) of - (TStr , TStr ) -> (TStr :) <$> go xs ys - (TPath, TPath) -> (TPath :) <$> go xs ys + go xxs@(x : xs) yys@(y : ys) = case (x, y) of + (TStr , TStr ) -> (one TStr <>) <$> rest + (TPath, TPath) -> (one TPath <>) <$> rest (TConstant ls, TConstant rs) -> - (TConstant (ls `intersect` rs) :) <$> go xs ys + (one (TConstant (ls `intersect` rs)) <>) <$> rest (TList l, TList r) -> - (\l' -> - (\r' -> do - m <- defer $ unify context l' r' - (TList m :) <$> go xs ys - ) =<< demand r - ) =<< demand l - (TSet x , TSet Nothing ) -> (TSet x :) <$> go xs ys - (TSet Nothing , TSet x ) -> (TSet x :) <$> go xs ys + do + l' <- demand l + r' <- demand r + m <- defer $ unify context l' r' + (one (TList m) <>) <$> rest + (TSet x , TSet Nothing ) -> (one (TSet x) <>) <$> rest + (TSet Nothing , TSet x ) -> (one (TSet x) <>) <$> rest (TSet (Just l), TSet (Just r)) -> do - m <- sequenceA $ M.intersectionWith - (\ i j -> - do - i'' <- demand =<< i - j'' <- demand =<< j - (defer . unify context i'') j'' - ) - (pure <$> l) - (pure <$> r) - bool + hm <- + sequenceA $ + M.intersectionWith + (\ i j -> + do + i'' <- i + j'' <- j + defer $ unify context i'' j'' + ) + (fmap demand l) + (fmap demand r) + handlePresence id - ((TSet (pure m) :) <$>) - (not $ M.null m) - (go xs ys) + (const ((one (TSet $ pure hm) <>) <$>)) + hm + rest (TClosure{}, TClosure{}) -> throwError $ ErrorCall "Cannot unify functions" (TBuiltin _ _, TBuiltin _ _) -> throwError $ ErrorCall "Cannot unify builtin functions" - _ | compareTypes x y == LT -> go xs (y : ys) - | compareTypes x y == GT -> go (x : xs) ys + _ | compareTypes x y == LT -> go xs yys + | compareTypes x y == GT -> go xxs ys | otherwise -> error "impossible" + where + rest :: m [NTypeF m (Symbolic m)] + rest = go xs ys {- mergeFunctions pl nl fl pr fr xs ys = do m <- sequenceA $ M.intersectionWith (\i j -> i >>= \i' -> j >>= \j' -> case (i', j') of - (Nothing, Nothing) -> pure $ pure Nothing - (_, Nothing) -> pure Nothing - (Nothing, _) -> pure Nothing + (Nothing, Nothing) -> stub + (_, Nothing) -> stub + (Nothing, _) -> stub (Just i'', Just j'') -> pure . pure <$> unify context i'' j'') (pure <$> pl) (pure <$> pr) @@ -230,38 +258,42 @@ -- | Result @== NMany []@ -> @unify@ fails. unify - :: forall e m + :: forall e m a . MonadLint e m - => NExprF () + => NExprF a -> Symbolic m -> Symbolic m -> m (Symbolic m) -unify context (SV x) (SV y) = do +unify (void -> context) (SV x) (SV y) = do x' <- readRef x y' <- readRef y case (x', y') of - (NAny, _) -> do - writeRef x y' - pure $ SV y - (_, NAny) -> do - writeRef y x' - pure $ SV x - (NMany xs, NMany ys) -> do - m <- merge context xs ys - bool - (do - writeRef x (NMany m) - writeRef y (NMany m) - packSymbolic (NMany m) - ) - (do - -- x' <- renderSymbolic (Symbolic x) - -- y' <- renderSymbolic (Symbolic y) + (NAny, _) -> + do + writeRef x y' + pure $ SV y + (_, NAny) -> + do + writeRef y x' + pure $ SV x + (NMany xs, NMany ys) -> + handlePresence + ( + -- x' <- renderSymbolic (Symbolic x) + -- y' <- renderSymbolic (Symbolic y) throwError $ ErrorCall "Cannot unify " -- <> show x' <> " with " <> show y' -- <> " in context: " <> show context ) - (null m) + (\ m -> + do + let + nm = NMany m + writeRef x nm + writeRef y nm + packSymbolic nm + ) + =<< merge context xs ys unify _ _ _ = error "The unexpected hath transpired!" -- These aren't worth defining yet, because once we move to Hindley-Milner, @@ -273,9 +305,9 @@ instance FromValue NixString m (Symbolic m) where -instance FromValue (AttrSet (Symbolic m), AttrSet SourcePos) m (Symbolic m) where +instance FromValue (AttrSet (Symbolic m), PositionSet) m (Symbolic m) where -instance ToValue (AttrSet (Symbolic m), AttrSet SourcePos) m (Symbolic m) where +instance ToValue (AttrSet (Symbolic m), PositionSet) m (Symbolic m) where instance (MonadThunkId m, MonadAtomicRef m, MonadCatch m) => MonadValue (Symbolic m) m where @@ -284,52 +316,53 @@ 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 - freeVariable var = symerr $ "Undefined variable '" <> var <> "'" + freeVariable var = symerr $ "Undefined variable '" <> coerce var <> "'" attrMissing ks ms = - evalError @(Symbolic m) $ ErrorCall $ toString $ + evalError @(Symbolic m) . ErrorCall . toString $ maybe ("Inheriting unknown attribute: " <> attr) (\ s -> "Could not look up attribute " <> attr <> " in " <> show s) ms where - attr = Text.intercalate "." (NE.toList ks) + attr = Text.intercalate "." $ NE.toList $ coerce ks - evalCurPos = do - f <- mkSymbolic [TPath] - l <- mkSymbolic [TConstant [TInt]] - c <- mkSymbolic [TConstant [TInt]] - mkSymbolic [TSet (pure (M.fromList [("file", f), ("line", l), ("col", c)]))] + evalCurPos = + do + f <- mkSymbolic1 TPath + l <- mkSymbolic1 $ TConstant $ one TInt + c <- mkSymbolic1 $ TConstant $ one TInt + mkSymbolic1 $ TSet . pure $ M.fromList [("file", f), ("line", l), ("col", c)] - evalConstant c = mkSymbolic [go c] + evalConstant c = mkSymbolic1 $ fun c where - go = + fun = \case NURI _ -> TStr - NInt _ -> TConstant [TInt] - NFloat _ -> TConstant [TFloat] - NBool _ -> TConstant [TBool] - NNull -> TConstant [TNull] + NInt _ -> TConstant $ one TInt + NFloat _ -> TConstant $ one TFloat + NBool _ -> TConstant $ one TBool + NNull -> TConstant $ one TNull - evalString = const $ mkSymbolic [TStr] - evalLiteralPath = const $ mkSymbolic [TPath] - evalEnvPath = const $ mkSymbolic [TPath] + evalString = const $ mkSymbolic1 TStr + evalLiteralPath = const $ mkSymbolic1 TPath + evalEnvPath = const $ mkSymbolic1 TPath evalUnary op arg = - unify (void (NUnary op arg)) arg =<< mkSymbolic [TConstant [TInt, TBool]] + unify (NUnary op arg) arg =<< mkSymbolic1 (TConstant [TInt, TBool]) evalBinary = lintBinaryOp @@ -343,7 +376,7 @@ pushWeakScope (case s of - NMany [TSet (Just s')] -> pure s' + NMany [TSet (Just (coerce -> scope))] -> pure scope NMany [TSet Nothing] -> error "NYI: with unknown" _ -> throwError $ ErrorCall "scope must be a set in with statement" ) @@ -353,20 +386,16 @@ do t' <- t f' <- f - let e = NIf cond t' f' - - _ <- unify (void e) cond =<< mkSymbolic [TConstant [TBool]] - unify (void e) t' f' + let e = unify (NIf cond t' f') + e t' f' <* (e cond =<< mkSymbolic1 (TConstant $ one TBool)) evalAssert cond body = do body' <- body - let e = NAssert cond body' - _ <- unify (void e) cond =<< mkSymbolic [TConstant [TBool]] - pure body' + body' <$ (unify (NAssert cond body') cond =<< mkSymbolic1 (TConstant $ one TBool)) - evalApp = (fmap snd .) . lintApp (NBinary NApp () ()) - evalAbs params _ = mkSymbolic [TClosure (void params)] + evalApp = (fmap snd .) . lintApp (join NApp mempty) + evalAbs params _ = mkSymbolic1 (TClosure $ void params) evalError = throwError @@ -382,43 +411,45 @@ rsym <- rarg y <- defer everyPossible - case op of - NApp -> symerr "lintBinaryOp:NApp: should never get here" - _ -> check lsym rsym $ - case op of - NEq -> [TConstant [TInt, TBool, TNull], TStr, TList y] - NNEq -> [TConstant [TInt, TBool, TNull], TStr, TList y] + check lsym rsym $ + case op of + NEq -> [TConstant [TInt, TBool, TNull], TStr, TList y] + NNEq -> [TConstant [TInt, TBool, TNull], TStr, TList y] - NLt -> [TConstant [TInt, TBool, TNull]] - NLte -> [TConstant [TInt, TBool, TNull]] - NGt -> [TConstant [TInt, TBool, TNull]] - NGte -> [TConstant [TInt, TBool, TNull]] + NLt -> one $ TConstant [TInt, TBool, TNull] + NLte -> one $ TConstant [TInt, TBool, TNull] + NGt -> one $ TConstant [TInt, TBool, TNull] + NGte -> one $ TConstant [TInt, TBool, TNull] - NAnd -> [TConstant [TBool]] - NOr -> [TConstant [TBool]] - NImpl -> [TConstant [TBool]] + NAnd -> one $ TConstant $ one TBool + NOr -> one $ TConstant $ one TBool + NImpl -> one $ TConstant $ one TBool - -- jww (2018-04-01): NYI: Allow Path + Str - NPlus -> [TConstant [TInt], TStr, TPath] - NMinus -> [TConstant [TInt]] - NMult -> [TConstant [TInt]] - NDiv -> [TConstant [TInt]] + -- jww (2018-04-01): NYI: Allow Path + Str + NPlus -> [TConstant $ one TInt, TStr, TPath] + NMinus -> one $ TConstant $ one TInt + NMult -> one $ TConstant $ one TInt + NDiv -> one $ TConstant $ one TInt - NUpdate -> [TSet mempty] + NUpdate -> one $ TSet mempty - NConcat -> [TList y] -#if __GLASGOW_HASKELL__ < 900 - _ -> fail "Should not be possible" -- symerr or this fun signature should be changed to work in type scope + NConcat -> one $ TList y +#if __GLASGOW_HASKELL__ < 810 + _ -> fail "Should not be possible" -- symerr or this fun signature should be changed to work in type scope #endif + + + where check lsym rsym xs = do - let e = NBinary op lsym rsym + let + contextUnify = unify $ NBinary op lsym rsym m <- mkSymbolic xs - _ <- unify (void e) lsym m - _ <- unify (void e) rsym m - unify (void e) lsym rsym + _ <- contextUnify lsym m + _ <- contextUnify rsym m + contextUnify lsym rsym infixl 1 `lintApp` lintApp @@ -428,25 +459,31 @@ -> Symbolic m -> m (Symbolic m) -> m (HashMap VarName (Symbolic m), Symbolic m) -lintApp context fun arg = unpackSymbolic fun >>= \case - NAny -> - throwError $ ErrorCall "Cannot apply something not known to be a function" - NMany xs -> do - (args, ys) <- fmap unzip $ forM xs $ \case - TClosure _params -> arg >>= unpackSymbolic >>= \case - NAny -> do - error "NYI" - - NMany [TSet (Just _)] -> do - error "NYI" - - NMany _ -> throwError $ ErrorCall "NYI: lintApp NMany not set" - TBuiltin _ _f -> throwError $ ErrorCall "NYI: lintApp builtin" - TSet _m -> throwError $ ErrorCall "NYI: lintApp Set" - _x -> throwError $ ErrorCall "Attempt to call non-function" +lintApp context fun arg = + (\case + NAny -> + throwError $ ErrorCall "Cannot apply something not known to be a function" + NMany xs -> + do + (args, ys) <- + unzip <$> + traverse + (\case + TClosure _params -> + (\case + NAny -> error "NYI" + NMany [TSet (Just _)] -> error "NYI" + NMany _ -> throwError $ ErrorCall "NYI: lintApp NMany not set" + ) =<< unpackSymbolic =<< arg + TBuiltin _ _f -> throwError $ ErrorCall "NYI: lintApp builtin" + TSet _m -> throwError $ ErrorCall "NYI: lintApp Set" + _x -> throwError $ ErrorCall "Attempt to call non-function" + ) + xs - y <- everyPossible - (head args, ) <$> foldM (unify context) y ys + y <- everyPossible + (Unsafe.head args, ) <$> foldM (unify context) y ys + ) =<< unpackSymbolic fun newtype Lint s a = Lint { runLint :: ReaderT (Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a } @@ -462,20 +499,20 @@ ) instance MonadThrow (Lint s) where - throwM e = Lint $ ReaderT $ \_ -> throw e + 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 $ \_ -> fail "Cannot catch in 'Lint s'" + catch _m _h = Lint $ ReaderT $ const (error "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 => m (Scopes m (Symbolic m)) -symbolicBaseEnv = pure mempty +symbolicBaseEnv = stub lint :: Options -> NExprLoc -> ST s (Symbolic (Lint s)) lint opts expr = @@ -493,7 +530,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 @@ -1,18 +1,15 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE RankNTypes #-} +{-# language AllowAmbiguousTypes #-} +{-# language ConstraintKinds #-} +{-# language DataKinds #-} +{-# language TypeFamilies #-} +{-# language RankNTypes #-} -- | Code for normalization (reduction into a normal form) of Nix expressions. -- Nix language allows recursion, so some expressions do not converge. -- And so do not converge into a normal form. module Nix.Normal where -import Prelude hiding ( force ) -import Nix.Utils +import Nix.Prelude import Control.Monad.Free ( Free(..) ) import Data.Set ( member , insert @@ -23,7 +20,7 @@ import Nix.Value newtype NormalLoop t f m = NormalLoop (NValue t f m) - deriving Show + deriving Show instance MonadDataErrorContext t f m => Exception (NormalLoop t f m) @@ -37,39 +34,42 @@ ) => NValue t f m -> m (NValue t f m) -normalizeValue v = run $ iterNValueM run (flip go) (fmap Free . sequenceNValue' run) v +normalizeValue v = run $ iterNValueM run go (fmap Free . sequenceNValue' run) v where start = 0 :: Int + maxDepth = 2000 table = mempty run :: ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r run = (`evalStateT` table) . (`runReaderT` start) go - :: t - -> ( NValue t f m + :: ( NValue t f m -> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m) ) + -> t -> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m) - go t k = do - b <- seen t + go k tnk = bool (do i <- ask - when (i > 2000) $ fail "Exceeded maximum normalization depth of 2000 levels" + when (i > maxDepth) $ fail $ "Exceeded maximum normalization depth of " <> show maxDepth <> " levels." (lifted . lifted) - (=<< force t) - (local succ . k) + (=<< force tnk) + (local (+1) . k) ) - (pure $ pure t) - b - - seen t = do - let tid = thunkId t - lift $ do - res <- gets $ member tid - unless res $ modify $ insert tid - pure res + (pure $ pure tnk) + =<< seen tnk + where + seen :: t -> ReaderT Int (StateT (Set (ThunkId m)) m) Bool + seen t = + do + let tnkid = thunkId t + lift $ + do + thunkWasVisited <- gets $ member tnkid + when (not thunkWasVisited) $ modify $ insert tnkid + pure thunkWasVisited -- 2021-05-09: NOTE: This seems a bit excessive. If these functorial versions are not used for recursion schemes - just free from it. -- | Normalization HOF (functorial) version of @normalizeValue@. Accepts the special thunk operating/forcing/nirmalizing function & internalizes it. @@ -83,37 +83,42 @@ => (forall r . t -> (NValue t f m -> m r) -> m r) -> NValue t f m -> m (NValue t f m) -normalizeValueF f = run . iterNValueM run (flip go) (fmap Free . sequenceNValue' run) +normalizeValueF f = run . iterNValueM run go (fmap Free . sequenceNValue' run) where start = 0 :: Int + maxDepth = 2000 table = mempty run :: ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r run = (`evalStateT` table) . (`runReaderT` start) go - :: t - -> ( NValue t f m + :: ( NValue t f m -> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m) ) + -> t -> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m) - go t k = do - b <- seen t + go k tnk = bool (do i <- ask - when (i > 2000) $ fail "Exceeded maximum normalization depth of 2000 levels" - lifted (lifted $ f t) $ local succ . k + when (i > maxDepth) $ fail $ "Exceeded maximum normalization depth of " <> show maxDepth <> " levels." + (lifted . lifted) + (f tnk) + (local (+1) . k) ) - (pure $ pure t) - b - - seen t = do - let tid = thunkId t - lift $ do - res <- gets $ member tid - unless res $ modify $ insert tid - pure res + (pure $ pure tnk) + =<< seen tnk + where + seen :: t -> ReaderT Int (StateT (Set (ThunkId m)) m) Bool + seen t = + do + let tnkid = thunkId t + lift $ + do + thunkWasVisited <- gets $ member tnkid + when (not thunkWasVisited) $ modify $ insert tnkid + pure thunkWasVisited -- | Normalize value. -- Detect cycles. @@ -141,8 +146,8 @@ -> m () normalForm_ t = void $ normalizeValue t -opaqueVal :: Applicative f => NValue t f m -opaqueVal = nvStrWithoutContext "" +opaqueVal :: NVConstraint f => NValue t f m +opaqueVal = mkNVStrWithoutContext "" -- | Detect cycles & stub them. stubCycles @@ -158,23 +163,23 @@ (\_ t -> Free $ NValue' $ - foldr - (addProvenance1 @m @(NValue t f m)) + foldl' + (flip $ addProvenance1 @m @(NValue t f m)) cyc - (reverse $ citations @m @(NValue t f m) t) + (citations @m @(NValue t f m) t) ) Free where Free (NValue' cyc) = opaqueVal -thunkStubVal :: Applicative f => NValue t f m -thunkStubVal = nvStrWithoutContext thunkStubText +thunkStubVal :: NVConstraint f => NValue t f m +thunkStubVal = mkNVStrWithoutContext thunkStubText -- | Check if thunk @t@ is computed, -- then bind it into first arg. -- else bind the thunk stub val. bindComputedThunkOrStub - :: ( Applicative f + :: ( NVConstraint f , MonadThunk t m (NValue t f m) ) => (NValue t f m -> m a) diff --git a/src/Nix/Options.hs b/src/Nix/Options.hs --- a/src/Nix/Options.hs +++ b/src/Nix/Options.hs @@ -1,74 +1,81 @@ -{-# LANGUAGE StrictData #-} +{-# language StrictData #-} -- | Definitions & defaults for the CLI options module Nix.Options where +import Nix.Prelude import Data.Time -data Options = Options - { verbose :: Verbosity - , tracing :: Bool - , thunks :: Bool - , values :: Bool - , showScopes :: Bool - , reduce :: Maybe FilePath - , reduceSets :: Bool - , reduceLists :: Bool - , parse :: Bool - , parseOnly :: Bool - , finder :: Bool - , findFile :: Maybe FilePath - , strict :: Bool - , evaluate :: Bool - , json :: Bool - , xml :: Bool - , attr :: Maybe Text - , include :: [FilePath] - , check :: Bool - , readFrom :: Maybe FilePath - , cache :: Bool - , repl :: Bool - , ignoreErrors :: Bool - , expression :: Maybe Text - , arg :: [(Text, Text)] - , argstr :: [(Text, Text)] - , fromFile :: Maybe FilePath - , currentTime :: UTCTime - , filePaths :: [FilePath] +-- 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 + { 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 @@ -78,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 @@ -1,8 +1,9 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# language TemplateHaskell #-} -- | 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 ) @@ -212,7 +213,7 @@ debugVersionOpt :: Parser (a -> a) debugVersionOpt = infoOption - ( concat + ( fold [ "Version: ", showVersion version , "\nCommit: ", $(gitHash) , "\n date: ", $(gitCommitDate) @@ -227,4 +228,4 @@ nixOptionsInfo current = info (helper <*> versionOpt <*> nixOptions current) - (fullDesc <> progDesc "" <> header "hnix") + (fullDesc <> progDesc mempty <> header "hnix") diff --git a/src/Nix/Parser.hs b/src/Nix/Parser.hs --- a/src/Nix/Parser.hs +++ b/src/Nix/Parser.hs @@ -1,773 +1,1006 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveAnyClass #-} - -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} - --- | Main module for parsing Nix expressions. -module Nix.Parser - ( parseNixFile - , parseNixFileLoc - , parseNixText - , parseNixTextLoc - , parseFromFileEx - , Parser - , parseFromText - , Result - , reservedNames - , OperatorInfo(..) - , NSpecialOp(..) - , NAssoc(..) - , NOperatorDef - , getUnaryOperator - , getBinaryOperator - , getSpecialOperator - , nixToplevelForm - , nixExpr - , nixSet - , nixBinders - , nixSelector - , nixSym - , nixPath - , nixString - , nixUri - , nixSearchPath - , nixFloat - , nixInt - , nixBool - , nixNull - , symbol - , whiteSpace - ) -where - -import Prelude hiding ( some - , many - , readFile - ) -import Data.Foldable ( foldr1 ) - -import Control.Monad ( msum ) -import Control.Monad.Combinators.Expr ( makeExprParser - , Operator( Postfix - , InfixN - , InfixR - , Prefix - , InfixL - ) - ) -import Data.Char ( isAlpha - , isDigit - , isSpace - ) -import Data.Data ( Data(..) ) -import Data.Fix ( Fix(..) ) -import qualified Data.HashSet as HashSet -import qualified Data.Map as Map -import Data.Text ( cons ) -import Nix.Expr hiding ( ($>) ) -import Nix.Expr.Strings ( escapeCodes - , stripIndent - , mergePlain - , removePlainEmpty - ) -import Nix.Render ( MonadFile(readFile) ) -import Prettyprinter ( Doc - , pretty - ) --- `parser-combinators` ships performance enhanced & MonadPlus-aware combinators. --- For example `smome` and `many` impoted here. -import Text.Megaparsec hiding ( State ) -import Text.Megaparsec.Char ( space1 - , string - , letterChar - , char - ) -import qualified Text.Megaparsec.Char.Lexer as Lexer - --- | Different to @isAlphaNum@ -isAlphanumeric :: Char -> Bool -isAlphanumeric x = isAlpha x || isDigit x -{-# inline isAlphanumeric #-} - -infixl 3 <+> -(<+>) :: MonadPlus m => m a -> m a -> m a -(<+>) = mplus - ---------------------------------------------------------------------------------- - -nixExpr :: Parser NExprLoc -nixExpr = - makeExprParser - nixTerm $ - snd <<$>> - nixOperators nixSelector - -antiStart :: Parser Text -antiStart = symbol "${" "${" - -nixAntiquoted :: Parser a -> Parser (Antiquoted a NExprLoc) -nixAntiquoted p = - Antiquoted <$> - (antiStart *> nixToplevelForm <* symbol "}") - <+> Plain <$> - p - "anti-quotation" - -selDot :: Parser () -selDot = try (symbol "." *> notFollowedBy nixPath) "." - -nixSelect :: Parser NExprLoc -> Parser NExprLoc -nixSelect term = - do - res <- - liftA2 build - term - (optional $ - liftA2 (,) - (selDot *> nixSelector) - (optional $ reserved "or" *> nixTerm) - ) - continues <- optional $ lookAhead selDot - - maybe - id - (const nixSelect) - continues - (pure res) - where - build - :: NExprLoc - -> Maybe ( Ann SrcSpan (NAttrPath NExprLoc) - , Maybe NExprLoc - ) - -> NExprLoc - build t mexpr = - maybe - id - (\ expr t -> (uncurry $ nSelectLoc t) expr) - mexpr - t - -nixSelector :: Parser (Ann SrcSpan (NAttrPath NExprLoc)) -nixSelector = - annotateLocation $ - do - (x : xs) <- keyName `sepBy1` selDot - pure $ x :| xs - -nixTerm :: Parser NExprLoc -nixTerm = do - c <- try $ lookAhead $ satisfy $ \x -> - pathChar x || (`elem` ("({[ nixSelect nixParens - '{' -> nixSelect nixSet - '[' -> nixList - '<' -> nixSearchPath - '/' -> nixPath - '"' -> nixString - '\'' -> nixString - '^' -> nixSynHole - _ -> - msum - $ [ nixSelect nixSet | c == 'r' ] - <> [ nixPath | pathChar c ] - <> if isDigit c - then [ nixFloat, nixInt ] - else - [ nixUri | isAlpha c ] - <> [ nixBool | c == 't' || c == 'f' ] - <> [ nixNull | c == 'n' ] - <> [ nixSelect nixSym ] - -nixToplevelForm :: Parser NExprLoc -nixToplevelForm = keywords <+> nixLambda <+> nixExpr - where - keywords = nixLet <+> nixIf <+> nixAssert <+> nixWith - -nixSym :: Parser NExprLoc -nixSym = annotateLocation1 $ mkSymF <$> identifier - -nixSynHole :: Parser NExprLoc -nixSynHole = annotateLocation1 $ mkSynHoleF <$> (char '^' *> identifier) - -nixInt :: Parser NExprLoc -nixInt = annotateLocation1 (mkIntF <$> integer "integer") - -nixFloat :: Parser NExprLoc -nixFloat = - annotateLocation1 (try (mkFloatF . realToFrac <$> float) "float") - -nixBool :: Parser NExprLoc -nixBool = - annotateLocation1 (bool "true" True <+> bool "false" False) "bool" - where - bool str b = mkBoolF b <$ reserved str - -nixNull :: Parser NExprLoc -nixNull = annotateLocation1 (mkNullF <$ reserved "null" "null") - --- | 'nixTopLevelForm' returns an expression annotated with a source position, --- however this position doesn't include the parsed parentheses, so remove the --- "inner" location annotateion and annotate again, including the parentheses. -nixParens :: Parser NExprLoc -nixParens = annotateLocation1 (parens (stripAnn . unFix <$> nixToplevelForm) "parens") - -nixList :: Parser NExprLoc -nixList = annotateLocation1 (brackets (NList <$> many nixTerm) "list") - -pathChar :: Char -> Bool -pathChar x = - isAlphanumeric x || (`elem` ("._-+~" :: String)) x - -slash :: Parser Char -slash = - try - ( char '/' - <* notFollowedBy (satisfy (\x -> x == '/' || x == '*' || isSpace x)) - ) - "slash" - --- | A path surrounded by angle brackets, indicating that it should be --- looked up in the NIX_PATH environment variable at evaluation. -nixSearchPath :: Parser NExprLoc -nixSearchPath = - annotateLocation1 - (mkPathF True <$> - try (char '<' *> many (satisfy pathChar <+> slash) <* symbol ">") - "spath" - ) - -pathStr :: Parser FilePath -pathStr = - lexeme $ - liftA2 (<>) - (many $ satisfy pathChar) - (concat <$> - some - (liftA2 (:) - slash - (some $ satisfy pathChar) - ) - ) - -nixPath :: Parser NExprLoc -nixPath = annotateLocation1 (try (mkPathF False <$> pathStr) "path") - -nixLet :: Parser NExprLoc -nixLet = annotateLocation1 - (reserved "let" *> (letBody <+> letBinders) "let block") - where - letBinders = - liftA2 NLet - nixBinders - (reserved "in" *> nixToplevelForm) - -- Let expressions `let {..., body = ...}' are just desugared - -- into `(rec {..., body = ...}).body'. - letBody = (\x -> NSelect x (StaticKey "body" :| mempty) Nothing) <$> aset - aset = annotateLocation1 $ NSet NRecursive <$> braces nixBinders - -nixIf :: Parser NExprLoc -nixIf = annotateLocation1 - (liftA3 NIf - (reserved "if" *> nixExpr ) - (reserved "then" *> nixToplevelForm) - (reserved "else" *> nixToplevelForm) - "if" - ) - -nixAssert :: Parser NExprLoc -nixAssert = annotateLocation1 - (liftA2 NAssert - (reserved "assert" *> nixToplevelForm) - (semi *> nixToplevelForm) - "assert" - ) - -nixWith :: Parser NExprLoc -nixWith = annotateLocation1 - (liftA2 NWith - (reserved "with" *> nixToplevelForm) - (semi *> nixToplevelForm) - "with" - ) - -nixLambda :: Parser NExprLoc -nixLambda = - liftA2 nAbs - (annotateLocation $ try argExpr) - nixToplevelForm - -nixString :: Parser NExprLoc -nixString = nStr <$> annotateLocation nixString' - -nixUri :: Parser NExprLoc -nixUri = lexeme $ annotateLocation1 $ try $ do - start <- letterChar - protocol <- many $ - satisfy $ - \ x -> - isAlphanumeric x - || (`elem` ("+-." :: String)) x - _ <- string ":" - address <- - some $ - satisfy $ - \ x -> - isAlphanumeric x - || (`elem` ("%/?:@&=+$,-_.!~*'" :: String)) x - pure $ NStr $ DoubleQuoted - [Plain $ toText $ start : protocol ++ ':' : address] - -nixString' :: Parser (NString NExprLoc) -nixString' = lexeme (doubleQuoted <+> indented "string") - where - doubleQuoted :: Parser (NString NExprLoc) - doubleQuoted = - DoubleQuoted - . removePlainEmpty - . mergePlain <$> - ( doubleQ - *> many (stringChar doubleQ (void $ char '\\') doubleEscape) - <* doubleQ - ) - "double quoted string" - - doubleQ = void $ char '"' - doubleEscape = Plain . one <$> (char '\\' *> escapeCode) - - indented :: Parser (NString NExprLoc) - indented = - stripIndent <$> - (indentedQ - *> many (stringChar indentedQ indentedQ indentedEscape) - <* indentedQ - ) - "indented string" - - indentedQ = void (string "''" "\"''\"") - indentedEscape = - try $ - do - indentedQ - (Plain <$> ("''" <$ char '\'' <+> "$" <$ char '$')) <+> - do - _ <- char '\\' - c <- escapeCode - - pure $ - bool - EscapedNewline - (Plain $ one c) - (c /= '\n') - - stringChar end escStart esc = - Antiquoted <$> - (antiStart *> nixToplevelForm <* char '}') - <+> Plain . one <$> - char '$' <+> esc <+> Plain . toText <$> - some plainChar - where - plainChar = - notFollowedBy (end <+> void (char '$') <+> escStart) *> anySingle - - escapeCode = - msum - [ c <$ char e | (c, e) <- escapeCodes ] - <+> anySingle - --- | Gets all of the arguments for a function. -argExpr :: Parser (Params NExprLoc) -argExpr = - msum - [ atLeft - , onlyname - , atRight - ] - <* symbol ":" - where - -- An argument not in curly braces. There's some potential ambiguity - -- in the case of, for example `x:y`. Is it a lambda function `x: y`, or - -- a URI `x:y`? Nix syntax says it's the latter. So we need to fail if - -- there's a valid URI parse here. - onlyname = - msum - [ nixUri *> unexpected (Label ('v' :| "alid uri")) - , Param <$> identifier - ] - - -- Parameters named by an identifier on the left (`args @ {x, y}`) - atLeft = - try $ - do - name <- identifier <* symbol "@" - (params, variadic) <- params - pure $ ParamSet params variadic $ pure name - - -- Parameters named by an identifier on the right, or none (`{x, y} @ args`) - atRight = - do - (params, variadic) <- params - name <- optional $ symbol "@" *> identifier - pure $ ParamSet params variadic name - - -- Return the parameters set. - params = braces getParams - - -- Collects the parameters within curly braces. Returns the parameters and - -- a boolean indicating if the parameters are variadic. - getParams :: Parser ([(Text, Maybe NExprLoc)], Bool) - getParams = go mempty - where - -- Attempt to parse `...`. If this succeeds, stop and return True. - -- Otherwise, attempt to parse an argument, optionally with a - -- default. If this fails, then return what has been accumulated - -- so far. - go acc = ((acc, True) <$ symbol "...") <+> getMore - where - getMore = - -- Could be nothing, in which just return what we have so far. - option (acc, False) $ - do - -- Get an argument name and an optional default. - pair <- - liftA2 (,) - identifier - (optional $ question *> nixToplevelForm) - - let args = acc <> [pair] - - -- Either return this, or attempt to get a comma and restart. - option (args, False) $ comma *> go args - -nixBinders :: Parser [Binding NExprLoc] -nixBinders = (inherit <+> namedVar) `endBy` semi where - inherit = - do - -- We can't use 'reserved' here because it would consume the whitespace - -- after the keyword, which is not exactly the semantics of C++ Nix. - try $ string "inherit" *> lookAhead (void (satisfy reservedEnd)) - p <- getSourcePos - x <- whiteSpace *> optional scope - liftA2 (Inherit x) - (many keyName) - (pure p) - "inherited binding" - namedVar = - do - p <- getSourcePos - liftA3 NamedVar - (annotated <$> nixSelector) - (equals *> nixToplevelForm) - (pure p) - "variable binding" - scope = nixParens "inherit scope" - -keyName :: Parser (NKeyName NExprLoc) -keyName = dynamicKey <+> staticKey - where - staticKey = StaticKey <$> identifier - dynamicKey = DynamicKey <$> nixAntiquoted nixString' - -nixSet :: Parser NExprLoc -nixSet = annotateLocation1 ((isRec <*> braces nixBinders) "set") - where - isRec = (reserved "rec" $> NSet NRecursive "recursive set") <+> pure (NSet NNonRecursive) - -parseNixFile :: MonadFile m => FilePath -> m (Result NExpr) -parseNixFile = - parseFromFileEx $ stripAnnotation <$> (whiteSpace *> nixToplevelForm <* eof) - -parseNixFileLoc :: MonadFile m => FilePath -> m (Result NExprLoc) -parseNixFileLoc = parseFromFileEx (whiteSpace *> nixToplevelForm <* eof) - -parseNixText :: Text -> Result NExpr -parseNixText = - parseFromText $ stripAnnotation <$> (whiteSpace *> nixToplevelForm <* eof) - -parseNixTextLoc :: Text -> Result NExprLoc -parseNixTextLoc = parseFromText (whiteSpace *> nixToplevelForm <* eof) - -{- Parser.Library -} - -skipLineComment' :: Tokens Text -> Parser () -skipLineComment' prefix = - string prefix *> void (takeWhileP (pure "character") (\x -> x /= '\n' && x /= '\r')) - -whiteSpace :: Parser () -whiteSpace = do - put =<< getSourcePos - Lexer.space space1 lineCmnt blockCmnt - where - lineCmnt = skipLineComment' "#" - blockCmnt = Lexer.skipBlockComment "/*" "*/" - -lexeme :: Parser a -> Parser a -lexeme p = p <* whiteSpace - -symbol :: Text -> Parser Text -symbol = lexeme . string - -reservedEnd :: Char -> Bool -reservedEnd x = - isSpace x || (`elem` ("{([})];:.\"'," :: String)) x -{-# inline reservedEnd #-} - -reserved :: Text -> Parser () -reserved n = - lexeme $ try $ string n *> lookAhead (void (satisfy reservedEnd) <|> eof) - -identifier :: Parser Text -identifier = lexeme $ try $ do - ident <- - liftA2 cons - (satisfy (\x -> isAlpha x || x == '_')) - (takeWhileP mempty identLetter) - guard $ not $ ident `HashSet.member` reservedNames - pure ident - where - identLetter x = isAlphanumeric x || x == '_' || x == '\'' || x == '-' - --- We restrict the type of 'parens' and 'brackets' here because if they were to --- take a @Parser NExprLoc@ argument they would parse additional text which --- wouldn't be captured in the source location annotation. --- --- Braces and angles in hnix don't enclose a single expression so this type --- restriction would not be useful. -parens :: Parser (NExprF f) -> Parser (NExprF f) -parens = between (symbol "(") (symbol ")") -braces :: ParsecT Void Text (State SourcePos) a -> ParsecT Void Text (State SourcePos) a -braces = between (symbol "{") (symbol "}") --- angles = between (symbol "<") (symbol ">") -brackets :: Parser (NExprF f) -> Parser (NExprF f) -brackets = between (symbol "[") (symbol "]") -semi :: Parser Text -semi = symbol ";" -comma :: Parser Text -comma = symbol "," --- colon = symbol ":" --- dot = symbol "." -equals :: Parser Text -equals = symbol "=" -question :: Parser Text -question = symbol "?" - -integer :: Parser Integer -integer = lexeme Lexer.decimal - -float :: Parser Double -float = lexeme Lexer.float - -reservedNames :: HashSet Text -reservedNames = - HashSet.fromList - ["let", "in", "if", "then", "else", "assert", "with", "rec", "inherit"] - -type Parser = ParsecT Void Text (State SourcePos) - -type Result a = Either (Doc Void) a - -parseFromFileEx :: MonadFile m => Parser a -> FilePath -> m (Result a) -parseFromFileEx parser file = - do - input <- decodeUtf8 <$> readFile file - - pure $ - either - (Left . pretty . errorBundlePretty) - pure - $ (`evalState` initialPos file) $ runParserT parser file input - -parseFromText :: Parser a -> Text -> Result a -parseFromText parser input = - let stub = "" in - either - (Left . pretty . errorBundlePretty) - pure - $ (`evalState` initialPos stub) $ (`runParserT` stub) parser input - -{- Parser.Operators -} - -data NSpecialOp = NHasAttrOp | NSelectOp - deriving (Eq, Ord, Generic, Typeable, Data, Show, NFData) - -data NAssoc = NAssocNone | NAssocLeft | NAssocRight - deriving (Eq, Ord, Generic, Typeable, Data, Show, NFData) - -data NOperatorDef - = NUnaryDef Text NUnaryOp - | NBinaryDef Text NBinaryOp NAssoc - | NSpecialDef Text NSpecialOp NAssoc - deriving (Eq, Ord, Generic, Typeable, Data, Show, NFData) - -annotateLocation :: Parser a -> Parser (Ann SrcSpan a) -annotateLocation p = - do - begin <- getSourcePos - res <- p - end <- get -- The state set before the last whitespace - - pure $ Ann (SrcSpan begin end) res - -annotateLocation1 :: Parser (NExprF NExprLoc) -> Parser NExprLoc -annotateLocation1 = fmap annToAnnF . annotateLocation - -manyUnaryOp :: MonadPlus f => f (a -> a) -> f (a -> a) -manyUnaryOp f = foldr1 (.) <$> some f - -operator :: Text -> Parser Text -operator op = - case op of - "-" -> tuneLexer "-" '>' - "/" -> tuneLexer "/" '/' - "<" -> tuneLexer "<" '=' - ">" -> tuneLexer ">" '=' - n -> symbol n - where - tuneLexer opchar nonextchar = - lexeme . try $ string opchar <* notFollowedBy (char nonextchar) - -opWithLoc :: Text -> o -> (Ann SrcSpan o -> a) -> Parser a -opWithLoc name op f = - do - Ann ann _ <- - annotateLocation $ - {- dbg (toString name) $ -} - operator name - - pure $ f $ Ann ann op - -binaryN :: Text -> NBinaryOp -> (NOperatorDef, Operator (ParsecT Void Text (State SourcePos)) NExprLoc) -binaryN name op = - (NBinaryDef name op NAssocNone, InfixN $ opWithLoc name op nBinary) -binaryL :: Text -> NBinaryOp -> (NOperatorDef, Operator (ParsecT Void Text (State SourcePos)) NExprLoc) -binaryL name op = - (NBinaryDef name op NAssocLeft, InfixL $ opWithLoc name op nBinary) -binaryR :: Text -> NBinaryOp -> (NOperatorDef, Operator (ParsecT Void Text (State SourcePos)) NExprLoc) -binaryR name op = - (NBinaryDef name op NAssocRight, InfixR $ opWithLoc name op nBinary) -prefix :: Text -> NUnaryOp -> (NOperatorDef, Operator (ParsecT Void Text (State SourcePos)) NExprLoc) -prefix name op = - (NUnaryDef name op, Prefix $ manyUnaryOp $ opWithLoc name op nUnary) --- postfix name op = (NUnaryDef name op, --- Postfix (opWithLoc name op nUnary)) - -nixOperators - :: Parser (Ann SrcSpan (NAttrPath NExprLoc)) - -> [[(NOperatorDef, Operator Parser NExprLoc)]] -nixOperators selector = - [ -- This is not parsed here, even though technically it's part of the - -- expression table. The problem is that in some cases, such as list - -- membership, it's also a term. And since terms are effectively the - -- highest precedence entities parsed by the expression parser, it ends up - -- working out that we parse them as a kind of "meta-term". - - -- {- 1 -} [ (NSpecialDef "." NSelectOp NAssocLeft, - -- Postfix $ do - -- sel <- seldot *> selector - -- mor <- optional (reserved "or" *> term) - -- pure $ \x -> nSelectLoc x sel mor) ] - - {- 2 -} - [ ( NBinaryDef " " NApp NAssocLeft - , - -- Thanks to Brent Yorgey for showing me this trick! - InfixL $ nApp <$ symbol "" - ) - ] - , {- 3 -} - [ prefix "-" NNeg ] - , {- 4 -} - [ ( NSpecialDef "?" NHasAttrOp NAssocLeft - , Postfix $ symbol "?" *> (flip nHasAttr <$> selector) - ) - ] - , {- 5 -} - [ binaryR "++" NConcat ] - , {- 6 -} - [ binaryL "*" NMult - , binaryL "/" NDiv - ] - , {- 7 -} - [ binaryL "+" NPlus - , binaryL "-" NMinus - ] - , {- 8 -} - [ prefix "!" NNot ] - , {- 9 -} - [ binaryR "//" NUpdate ] - , {- 10 -} - [ binaryL "<" NLt - , binaryL ">" NGt - , binaryL "<=" NLte - , binaryL ">=" NGte - ] - , {- 11 -} - [ binaryN "==" NEq - , binaryN "!=" NNEq - ] - , {- 12 -} - [ binaryL "&&" NAnd ] - , {- 13 -} - [ binaryL "||" NOr ] - , {- 14 -} - [ binaryR "->" NImpl ] - ] - -data OperatorInfo = OperatorInfo - { precedence :: Int - , associativity :: NAssoc - , operatorName :: Text - } deriving (Eq, Ord, Generic, Typeable, Data, Show) - -getUnaryOperator :: NUnaryOp -> OperatorInfo -getUnaryOperator = (m Map.!) - where - m = - Map.fromList $ - concat $ - zipWith - buildEntry - [1 ..] - (nixOperators $ fail "unused") - - buildEntry i = - concatMap $ - \case - (NUnaryDef name op, _) -> [(op, OperatorInfo i NAssocNone name)] - _ -> mempty - -getBinaryOperator :: NBinaryOp -> OperatorInfo -getBinaryOperator = (m Map.!) - where - m = - Map.fromList $ - concat $ - zipWith - buildEntry - [1 ..] - (nixOperators $ fail "unused") - - buildEntry i = - concatMap $ - \case - (NBinaryDef name op assoc, _) -> [(op, OperatorInfo i assoc name)] - _ -> mempty - -getSpecialOperator :: NSpecialOp -> OperatorInfo -getSpecialOperator NSelectOp = OperatorInfo 1 NAssocLeft "." -getSpecialOperator o = m Map.! o - where - m = - Map.fromList $ - concat $ - zipWith - buildEntry - [1 ..] - (nixOperators $ fail "unused") - - buildEntry i = - concatMap $ - \case - (NSpecialDef name op assoc, _) -> [(op, OperatorInfo i assoc name)] - _ -> mempty +{-# language CPP #-} +{-# language DeriveAnyClass #-} + +{-# options_ghc -fno-warn-name-shadowing #-} + +-- | Main module for parsing Nix expressions. +module Nix.Parser + ( parseNixFile + , parseNixFileLoc + , parseNixText + , parseNixTextLoc + , parseExpr + , parseFromFileEx + , Parser + , parseFromText + , Result + , reservedNames + , NAssoc(..) + , NOpPrecedence(..) + , NOpName(..) + , NSpecialOp(..) + , NOperatorDef(..) + , nixExpr + , nixExprAlgebra + , nixSet + , nixBinders + , nixSelector + , nixSym + , nixPath + , nixString + , nixUri + , nixSearchPath + , nixFloat + , nixInt + , nixBool + , nixNull + , whiteSpace + + -- 2022-01-26: NOTE: Try to hide it after OperatorInfo is removed + , NOp(..) + , appOpDef + ) +where + +import Nix.Prelude hiding ( (<|>) + , some + , many + ) +import Data.Foldable ( foldr1 ) + +import Control.Monad ( msum ) +import Control.Monad.Combinators.Expr ( makeExprParser + , Operator( Postfix + , InfixN + , InfixR + , Prefix + , InfixL + ) + ) +import Data.Char ( isAlpha + , isDigit + , isSpace + ) +import Data.Data ( Data(..) ) +import Data.List.Extra ( groupSort ) +import Data.Fix ( Fix(..) ) +import qualified Data.HashSet as HashSet +import qualified Data.Text as Text +import Nix.Expr.Types +import Nix.Expr.Shorthands hiding ( ($>) ) +import Nix.Expr.Types.Annotated +import Nix.Expr.Strings ( escapeCodes + , stripIndent + , mergePlain + , removeEmptyPlains + ) +import Nix.Render ( MonadFile() ) +import Prettyprinter ( Doc + , pretty + ) +-- `parser-combinators` ships performance enhanced & MonadPlus-aware combinators. +-- For example `some` and `many` impoted here. +import Text.Megaparsec hiding ( (<|>) + , State + ) +import Text.Megaparsec.Char ( space1 + , letterChar + , char + ) +import qualified Text.Megaparsec.Char.Lexer as Lexer + + +type Parser = ParsecT Void Text (State SourcePos) + +-- * Utils + +-- | Different to @isAlphaNum@ +isAlphanumeric :: Char -> Bool +isAlphanumeric x = isAlpha x || isDigit x +{-# inline isAlphanumeric #-} + +-- | Alternative "<|>" with additional preservation of 'MonadPlus' constraint. +infixl 3 <|> +(<|>) :: MonadPlus m => m a -> m a -> m a +(<|>) = mplus + +-- ** Annotated + +annotateLocation1 :: Parser a -> Parser (AnnUnit SrcSpan a) +annotateLocation1 p = + do + begin <- getSourcePos + res <- p + end <- get -- The state set before the last whitespace + + pure $ AnnUnit (SrcSpan (toNSourcePos begin) (toNSourcePos end)) res + +annotateLocation :: Parser (NExprF NExprLoc) -> Parser NExprLoc +annotateLocation = (annUnitToAnn <$>) . annotateLocation1 + +annotateNamedLocation :: String -> Parser (NExprF NExprLoc) -> Parser NExprLoc +annotateNamedLocation name = annotateLocation . label name + + +-- ** Grammar + +reservedNames :: HashSet VarName +reservedNames = + HashSet.fromList + ["let", "in", "if", "then", "else", "assert", "with", "rec", "inherit"] + +reservedEnd :: Char -> Bool +reservedEnd x = + isSpace x || (`elem` ("{([})];:.\"'," :: String)) x +{-# inline reservedEnd #-} + +reserved :: Text -> Parser () +reserved n = + lexeme $ try $ chunk n *> lookAhead (void (satisfy reservedEnd) <|> eof) + +exprAfterSymbol :: Char -> Parser NExprLoc +exprAfterSymbol p = symbol p *> nixExpr + +exprAfterReservedWord :: Text -> Parser NExprLoc +exprAfterReservedWord word = reserved word *> nixExpr + +-- | A literal copy of @megaparsec@ one but with addition of the @\r@ for Windows EOL case (@\r\n@). +-- Overall, parser should simply @\r\n -> \n@. +skipLineComment' :: Tokens Text -> Parser () +skipLineComment' prefix = + chunk prefix *> void (takeWhileP (pure "character") $ \x -> x /= '\n' && x /= '\r') + +whiteSpace :: Parser () +whiteSpace = + do + put =<< getSourcePos + Lexer.space space1 lineCmnt blockCmnt + where + lineCmnt = skipLineComment' "#" + blockCmnt = Lexer.skipBlockComment "/*" "*/" + +-- | Lexeme is a unit of the language. +-- Convention is that after lexeme an arbitrary amount of empty entities (space, comments, line breaks) are allowed. +-- This lexeme definition just skips over superflous @megaparsec: lexeme@ abstraction. +lexeme :: Parser a -> Parser a +lexeme p = p <* whiteSpace + +symbol :: Char -> Parser Char +symbol = lexeme . char + +symbols :: Text -> Parser Text +symbols = lexeme . chunk + +-- We restrict the type of 'parens' and 'brackets' here because if they were to +-- take a 'Parser NExprLoc' argument they would parse additional text which +-- wouldn't be captured in the source location annotation. +-- +-- Braces and angles in hnix don't enclose a single expression so this type +-- restriction would not be useful. +parens :: Parser (NExprF f) -> Parser (NExprF f) +parens = on between symbol '(' ')' + +braces :: Parser a -> Parser a +braces = on between symbol '{' '}' + +brackets :: Parser (NExprF f) -> Parser (NExprF f) +brackets = on between symbol '[' ']' + +antiquotedIsHungryForTrailingSpaces :: Bool -> Parser (Antiquoted v NExprLoc) +antiquotedIsHungryForTrailingSpaces hungry = Antiquoted <$> (antiStart *> nixExpr <* antiEnd) + where + antiStart :: Parser Text + antiStart = label "${" $ symbols "${" + + antiEnd :: Parser Char + antiEnd = label "}" $ + bool + id + lexeme + hungry + (char '}') + +antiquotedLexeme :: Parser (Antiquoted v NExprLoc) +antiquotedLexeme = antiquotedIsHungryForTrailingSpaces True + +antiquoted :: Parser (Antiquoted v NExprLoc) +antiquoted = antiquotedIsHungryForTrailingSpaces False + +--------------------------------------------------------------------------------- + +-- * Parser parts + +-- ** Constrants + +nixNull :: Parser NExprLoc +nixNull = + annotateNamedLocation "null" $ + mkNullF <$ reserved "null" + +nixBool :: Parser NExprLoc +nixBool = + annotateNamedLocation "bool" $ + on (<|>) lmkBool (True, "true") (False, "false") + where + lmkBool (b, txt) = mkBoolF b <$ reserved txt + +integer :: Parser Integer +integer = lexeme Lexer.decimal + +nixInt :: Parser NExprLoc +nixInt = + annotateNamedLocation "integer" $ + mkIntF <$> integer + +float :: Parser Double +float = lexeme Lexer.float + +nixFloat :: Parser NExprLoc +nixFloat = + annotateNamedLocation "float" $ + try $ + mkFloatF . realToFrac <$> float + +nixUri :: Parser NExprLoc +nixUri = + lexeme $ + annotateLocation $ + try $ + do + start <- letterChar + protocol <- + takeWhileP mempty $ + \ x -> + isAlphanumeric x + || (`elem` ("+-." :: String)) x + _ <- single ':' + address <- + takeWhile1P mempty $ + \ x -> + isAlphanumeric x + || (`elem` ("%/?:@&=+$,-_.!~*'" :: String)) x + pure . NStr . DoubleQuoted . one . Plain $ start `Text.cons` protocol <> ":" <> address + + +-- ** Strings + +nixAntiquoted :: Parser a -> Parser (Antiquoted a NExprLoc) +nixAntiquoted p = + label "anti-quotation" $ + antiquotedLexeme + <|> Plain <$> p + +escapeCode :: Parser Char +escapeCode = + msum + [ c <$ char e | (c, e) <- escapeCodes ] + <|> anySingle + +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 + +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 + + quotationMark :: Parser () + quotationMark = void $ char '"' + + doubleEscape :: Parser (Antiquoted Text r) + doubleEscape = Plain . one <$> (char '\\' *> escapeCode) + + +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 + c <- char '\\' *> escapeCode + + pure $ + bool + EscapedNewline + (Plain $ one c) + ('\n' /= c) + + -- | 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' + + +-- ** Names (variables aka symbols) + +identifier :: Parser VarName +identifier = + lexeme $ + try $ + do + (coerce -> iD) <- + liftA2 Text.cons + (satisfy (\x -> isAlpha x || x == '_')) + (takeWhileP mempty identLetter) + guard $ not $ iD `HashSet.member` reservedNames + pure iD + where + identLetter x = isAlphanumeric x || x == '_' || x == '\'' || x == '-' + +nixSym :: Parser NExprLoc +nixSym = annotateLocation $ mkSymF <$> coerce identifier + + +-- ** ( ) parens + +-- | 'nixExpr' returns an expression annotated with a source position, +-- however this position doesn't include the parsed parentheses, so remove the +-- "inner" location annotateion and annotate again, including the parentheses. +nixParens :: Parser NExprLoc +nixParens = + annotateNamedLocation "parens" $ + parens $ stripAnnF . unFix <$> nixExpr + + +-- ** [ ] list + +nixList :: Parser NExprLoc +nixList = + annotateNamedLocation "list" $ + brackets $ NList <$> many nixTerm + + +-- ** { } set + +nixBinders :: Parser [Binding NExprLoc] +nixBinders = (inherit <|> namedVar) `endBy` symbol ';' where + inherit = + do + -- We can't use 'reserved' here because it would consume the whitespace + -- after the keyword, which is not exactly the semantics of C++ Nix. + try $ chunk "inherit" *> lookAhead (void $ satisfy reservedEnd) + p <- getSourcePos + x <- whiteSpace *> optional scope + label "inherited binding" $ + liftA2 (Inherit x) + (many identifier) + (pure (toNSourcePos p)) + namedVar = + do + p <- getSourcePos + label "variable binding" $ + liftA3 NamedVar + (annotated <$> nixSelector) + (exprAfterSymbol '=') + (pure (toNSourcePos p)) + scope = label "inherit scope" nixParens + +nixSet :: Parser NExprLoc +nixSet = + annotateNamedLocation "set" $ + isRec <*> braces nixBinders + where + isRec = + label "recursive set" (reserved "rec" $> NSet Recursive) + <|> pure (NSet mempty) + +-- ** /x/y/z literal Path + +pathChar :: Char -> Bool +pathChar x = + isAlphanumeric x || (`elem` ("._-+~" :: String)) x + +slash :: Parser Char +slash = + label "slash " $ + try $ + char '/' <* notFollowedBy (satisfy $ \x -> x == '/' || x == '*' || isSpace x) + +pathStr :: Parser Path +pathStr = + lexeme $ coerce . toString <$> + liftA2 (<>) + (takeWhileP mempty pathChar) + (Text.concat <$> + some + (liftA2 Text.cons + slash + (takeWhile1P mempty pathChar) + ) + ) + +nixPath :: Parser NExprLoc +nixPath = + annotateNamedLocation "path" $ + try $ mkPathF False <$> coerce pathStr + + +-- ** <> environment path + +-- | A path surrounded by angle brackets, indicating that it should be +-- looked up in the NIX_PATH environment variable at evaluation. +nixSearchPath :: Parser NExprLoc +nixSearchPath = + annotateNamedLocation "spath" $ + mkPathF True <$> try (lexeme $ char '<' *> many (satisfy pathChar <|> slash) <* char '>') + + +-- ** Operators + +-- 2022-01-26: NOTE: Rename to 'literal' +newtype NOpName = NOpName Text + deriving + (Eq, Ord, Generic, Typeable, Data, Show, NFData) + +instance IsString NOpName where + fromString = coerce . fromString @Text + +instance ToString NOpName where + toString = toString @Text . coerce + +operator :: NOpName -> Parser Text +operator (coerce -> op) = + case op of + c@"-" -> c `without` '>' + c@"/" -> c `without` '/' + c@"<" -> c `without` '=' + c@">" -> c `without` '=' + n -> symbols n + where + without :: Text -> Char -> Parser Text + without opChar noNextChar = + lexeme . try $ chunk opChar <* notFollowedBy (char noNextChar) + +opWithLoc :: (AnnUnit SrcSpan o -> a) -> o -> NOpName -> Parser a +opWithLoc f op name = f . (op <$) <$> annotateLocation1 (operator name) + +-- 2022-01-26: NOTE: Make presedence free and type safe by moving it into type level: +-- https://youtu.be/qaPdg0mZavM?t=1757 +-- https://wiki.haskell.org/The_Monad.Reader/Issue5/Number_Param_Types +newtype NOpPrecedence = NOpPrecedence Int + deriving (Eq, Ord, Generic, Bounded, Typeable, Data, Show, NFData) + +instance Enum NOpPrecedence where + toEnum = coerce + fromEnum = coerce + +instance Num NOpPrecedence where + (+) = coerce ((+) @Int) + (*) = coerce ((*) @Int) + abs = coerce (abs @Int) + signum = coerce (signum @Int) + fromInteger = coerce (fromInteger @Int) + negate = coerce (negate @Int) + +-- 2022-01-26: NOTE: This type belongs into 'Type.Expr' & be used in NExprF. +data NAppOp = NAppOp + deriving (Eq, Ord, Generic, Typeable, Data, Show, NFData) + +-- 2022-01-26: NOTE: This type belongs into 'Type.Expr' & be used in NExprF. +data NSpecialOp + = NHasAttrOp + | NSelectOp + | NTerm -- ^ For special handling of internal special cases. + deriving (Eq, Ord, Generic, Typeable, Data, Show, NFData) + +data NAssoc + = NAssocLeft + -- Nota bene: @parser-combinators@ named "associative property" as 'InfixN' stating it as "non-associative property". + -- Binary operators having some associativity is a basis property in mathematical algebras in use (for example, in Category theory). Having no associativity in operators makes theory mostly impossible in use and so non-associativity is not encountered in notations, therefore under 'InfixN' @parser-combinators@ meant "associative". + -- | Bidirectional associativity, or simply: associative property. + | NAssoc + | NAssocRight + deriving (Eq, Ord, Generic, Typeable, Data, Show, NFData) + +-- 2022-01-31: NOTE: This type and related typeclasses & their design, probably need a refinement. +-- +-- In the "Nix.Pretty", the code probably should be well-typed to the type of operations its processes. +-- Therefor splitting operation types into separate types there is probably needed. +-- +-- After that: +-- +-- > { NAssoc, NOpPrecedence, NOpName } +-- +-- Can be formed into a type. +-- +-- Also 'NAppDef' really has only 1 implementation, @{ NAssoc, NOpPrecedence, NOpName }@ +-- were added there only to make type uniformal. +-- All impossible cases ideally should be unrepresentable. +-- | Single operator grammar entries. +data NOperatorDef + = NAppDef NAppOp NAssoc NOpPrecedence NOpName + | NUnaryDef NUnaryOp NAssoc NOpPrecedence NOpName + | NBinaryDef NBinaryOp NAssoc NOpPrecedence NOpName + | NSpecialDef NSpecialOp NAssoc NOpPrecedence NOpName + -- 2022-01-26: NOTE: Ord can be the order of evaluation of precedence (which 'Pretty' printing also accounts for). + deriving (Eq, Ord, Generic, Typeable, Data, Show, NFData) + +-- Supplied since its definition gets called/used frequently. +-- | Functional application operator definition, left associative, high precedence. +appOpDef :: NOperatorDef +appOpDef = NAppDef NAppOp NAssocLeft 1 " " -- This defined as "2" in Nix lang spec. + +-- 2022-01-26: NOTE: When total - make sure to hide & inline all these instances to get free solution. +-- | Class to get a private free construction to abstract away the gap between the Nix operation types +-- 'NUnaryOp', 'NBinaryOp', 'NSpecialOp'. +-- And in doing remove 'OperatorInfo' from existance. +class NOp a where + {-# minimal getOpDef, getOpAssoc, getOpPrecedence, getOpName #-} + + getOpDef :: a -> NOperatorDef + getOpAssoc :: a -> NAssoc + getOpPrecedence :: a -> NOpPrecedence + getOpName :: a -> NOpName + +instance NOp NAppOp where + getOpDef NAppOp = appOpDef + getOpAssoc _op = fun appOpDef + where + fun (NAppDef _op assoc _prec _name) = assoc + fun _ = error "Impossible happened, funapp operation should been matched." + getOpPrecedence _op = fun appOpDef + where + fun (NAppDef _op _assoc prec _name) = prec + fun _ = error "Impossible happened, funapp operation should been matched." + getOpName _ = fun appOpDef + where + fun (NAppDef _op _assoc _prec name) = name + fun _ = error "Impossible happened, funapp operation should been matched." + +instance NOp NUnaryOp where + getOpDef = + \case + NNeg -> NUnaryDef NNeg NAssocRight 3 "-" + NNot -> NUnaryDef NNot NAssocRight 8 "!" + getOpAssoc = fun . getOpDef + where + fun (NUnaryDef _op assoc _prec _name) = assoc + fun _ = error "Impossible happened, unary operation should been matched." + getOpPrecedence = fun . getOpDef + where + fun (NUnaryDef _op _assoc prec _name) = prec + fun _ = error "Impossible happened, unary operation should been matched." + getOpName = fun . getOpDef + where + fun (NUnaryDef _op _assoc _prec name) = name + fun _ = error "Impossible happened, unary operation should been matched." + +instance NOp NBinaryOp where + getOpDef = + \case + NConcat -> NBinaryDef NConcat NAssocRight 5 "++" + NMult -> NBinaryDef NMult NAssocLeft 6 "*" + NDiv -> NBinaryDef NDiv NAssocLeft 6 "/" + NPlus -> NBinaryDef NPlus NAssocLeft 7 "+" + NMinus -> NBinaryDef NMinus NAssocLeft 7 "-" + NUpdate -> NBinaryDef NUpdate NAssocRight 9 "//" + NLt -> NBinaryDef NLt NAssocLeft 10 "<" + NLte -> NBinaryDef NLte NAssocLeft 10 "<=" + NGt -> NBinaryDef NGt NAssocLeft 10 ">" + NGte -> NBinaryDef NGte NAssocLeft 10 ">=" + NEq -> NBinaryDef NEq NAssoc 11 "==" + NNEq -> NBinaryDef NNEq NAssoc 11 "!=" + NAnd -> NBinaryDef NAnd NAssocLeft 12 "&&" + NOr -> NBinaryDef NOr NAssocLeft 13 "||" + NImpl -> NBinaryDef NImpl NAssocRight 14 "->" + getOpAssoc = fun . getOpDef + where + fun (NBinaryDef _op assoc _prec _name) = assoc + fun _ = error "Impossible happened, binary operation should been matched." + getOpPrecedence = fun . getOpDef + where + fun (NBinaryDef _op _assoc prec _name) = prec + fun _ = error "Impossible happened, binary operation should been matched." + getOpName = fun . getOpDef + where + fun (NBinaryDef _op _assoc _prec name) = name + fun _ = error "Impossible happened, binary operation should been matched." + +instance NOp NSpecialOp where + getOpDef = + \case + NSelectOp -> NSpecialDef NSelectOp NAssocLeft 1 "." + NHasAttrOp -> NSpecialDef NHasAttrOp NAssocLeft 4 "?" + NTerm -> NSpecialDef NTerm NAssocLeft 1 "???" + getOpAssoc = fun . getOpDef + where + fun (NSpecialDef _op assoc _prec _name) = assoc + fun _ = error "Impossible happened, special operation should been matched." + getOpPrecedence = fun . getOpDef + where + fun (NSpecialDef _op _assoc prec _name) = prec + fun _ = error "Impossible happened, special operation should been matched." + getOpName = fun . getOpDef + where + fun (NSpecialDef _op _assoc _prec name) = name + fun _ = error "Impossible happened, special operation should been matched." + +instance NOp NOperatorDef where + getOpDef op = op + getOpAssoc = \case + (NAppDef _op assoc _prec _name) -> assoc + (NUnaryDef _op assoc _prec _name) -> assoc + (NBinaryDef _op assoc _prec _name) -> assoc + (NSpecialDef _op assoc _prec _name) -> assoc + getOpPrecedence = fun . getOpDef + where + fun (NAppDef _op _assoc prec _name) = prec + fun (NUnaryDef _op _assoc prec _name) = prec + fun (NBinaryDef _op _assoc prec _name) = prec + fun (NSpecialDef _op _assoc prec _name) = prec + getOpName = fun . getOpDef + where + fun (NAppDef _op _assoc _prec name) = name + fun (NUnaryDef _op _assoc _prec name) = name + fun (NBinaryDef _op _assoc _prec name) = name + fun (NSpecialDef _op _assoc _prec name) = name + +prefix :: NUnaryOp -> Operator Parser NExprLoc +prefix op = + Prefix $ manyUnaryOp $ opWithLoc annNUnary op $ getOpName op +-- postfix name op = (NUnaryDef name op, +-- Postfix (opWithLoc annNUnary op name)) + +manyUnaryOp :: MonadPlus f => f (a -> a) -> f (a -> a) +manyUnaryOp f = foldr1 (.) <$> some f + +binary + :: NBinaryOp + -> Operator Parser NExprLoc +binary op = + mapAssocToInfix (getOpAssoc op) $ opWithLoc annNBinary op (getOpName op) + +mapAssocToInfix :: NAssoc -> m (a -> a -> a) -> Operator m a +mapAssocToInfix NAssocLeft = InfixL +mapAssocToInfix NAssoc = InfixN +mapAssocToInfix NAssocRight = InfixR + +-- ** x: y lambda function + +-- | Gets all of the arguments for a function. +argExpr :: Parser (Params NExprLoc) +argExpr = + msum + [ atLeft + , onlyname + , atRight + ] + <* symbol ':' + where + -- An argument not in curly braces. There's some potential ambiguity + -- in the case of, for example `x:y`. Is it a lambda function `x: y`, or + -- a URI `x:y`? Nix syntax says it's the latter. So we need to fail if + -- there's a valid URI parse here. + onlyname = + msum + [ nixUri *> unexpected (Label $ fromList "valid uri" ) + , Param <$> identifier + ] + + -- Parameters named by an identifier on the left (`args @ {x, y}`) + atLeft = + try $ + do + name <- identifier <* symbol '@' + (variadic, pset) <- params + pure $ ParamSet (pure name) variadic pset + + -- Parameters named by an identifier on the right, or none (`{x, y} @ args`) + atRight = + do + (variadic, pset) <- params + name <- optional $ symbol '@' *> identifier + pure $ ParamSet name variadic pset + + -- Return the parameters set. + params = braces getParams + + -- Collects the parameters within curly braces. Returns the parameters and + -- an flag indication if the parameters are variadic. + getParams :: Parser (Variadic, [(VarName, Maybe NExprLoc)]) + getParams = go mempty + where + -- Attempt to parse `...`. If this succeeds, stop and return True. + -- Otherwise, attempt to parse an argument, optionally with a + -- default. If this fails, then return what has been accumulated + -- so far. + go :: [(VarName, Maybe NExprLoc)] -> Parser (Variadic, [(VarName, Maybe NExprLoc)]) + go acc = ((Variadic, acc) <$ symbols "...") <|> getMore + where + getMore :: Parser (Variadic, [(VarName, Maybe NExprLoc)]) + getMore = + -- Could be nothing, in which just return what we have so far. + option (mempty, acc) $ + do + -- Get an argument name and an optional default. + pair <- + liftA2 (,) + identifier + (optional $ exprAfterSymbol '?') + + let args = acc <> one pair + + -- Either return this, or attempt to get a comma and restart. + option (mempty, args) $ symbol ',' *> go args + +nixLambda :: Parser NExprLoc +nixLambda = + liftA2 annNAbs + (annotateLocation1 $ try argExpr) + nixExpr + + +-- ** let expression + +nixLet :: Parser NExprLoc +nixLet = + annotateNamedLocation "let block" $ + reserved "let" *> (letBody <|> letBinders) + where + -- | Expressions `let {..., body = ...}' are just desugared + -- into `(rec {..., body = ...}).body'. + letBody = (\ expr -> NSelect Nothing expr (one $ StaticKey "body")) <$> attrset + where + attrset = annotateLocation $ NSet Recursive <$> braces nixBinders + -- | Regular `let` + letBinders = + liftA2 NLet + nixBinders + (exprAfterReservedWord "in") + +-- ** if then else + +nixIf :: Parser NExprLoc +nixIf = + annotateNamedLocation "if" $ + liftA3 NIf + (reserved "if" *> nixExpr) + (exprAfterReservedWord "then") + (exprAfterReservedWord "else") + +-- ** with + +nixWith :: Parser NExprLoc +nixWith = + annotateNamedLocation "with" $ + liftA2 NWith + (exprAfterReservedWord "with") + (exprAfterSymbol ';' ) + + +-- ** assert + +nixAssert :: Parser NExprLoc +nixAssert = + annotateNamedLocation "assert" $ + liftA2 NAssert + (exprAfterReservedWord "assert") + (exprAfterSymbol ';' ) + +-- ** . - reference (selector) into attr + +selectorDot :: Parser () +selectorDot = label "." $ try (symbol '.' *> notFollowedBy nixPath) + +keyName :: Parser (NKeyName NExprLoc) +keyName = dynamicKey <|> staticKey + where + staticKey = StaticKey <$> identifier + dynamicKey = DynamicKey <$> nixAntiquoted nixString' + +nixSelector :: Parser (AnnUnit SrcSpan (NAttrPath NExprLoc)) +nixSelector = + annotateLocation1 $ fromList <$> keyName `sepBy1` selectorDot + +nixSelect :: Parser NExprLoc -> Parser NExprLoc +nixSelect term = + do + res <- + liftA2 builder + term + (optional $ + liftA2 (flip (,)) + (selectorDot *> nixSelector) + (optional $ reserved "or" *> nixTerm) + ) + continues <- optional $ lookAhead selectorDot + + maybe + id + (const nixSelect) + continues + (pure res) + where + builder + :: NExprLoc + -> Maybe + ( Maybe NExprLoc + , AnnUnit SrcSpan (NAttrPath NExprLoc) + ) + -> NExprLoc + builder t = + maybe + t + (uncurry (`annNSelect` t)) + + +-- ** _ - syntax hole + +nixSynHole :: Parser NExprLoc +nixSynHole = + annotateLocation $ mkSynHoleF <$> coerce (char '^' *> identifier) + +-- List of Nix operation parsers with their precedence. +opParsers :: [(NOpPrecedence, Operator Parser NExprLoc)] +opParsers = + -- This is not parsed here, even though technically it's part of the + -- expression table. The problem is that in some cases, such as list + -- membership, it's also a term. And since terms are effectively the + -- highest precedence entities parsed by the expression parser, it ends up + -- working out that we parse them as a kind of "meta-term". + + -- {- 1 -} + -- [ ( NSpecialDef "." NSelectOp NAssocLeft + -- , Postfix $ + -- do + -- sel <- seldot *> selector + -- mor <- optional (reserved "or" *> term) + -- pure $ \x -> annNSelect x sel mor) + -- ] + + -- NApp is left associative + -- 2018-05-07: jwiegley: Thanks to Brent Yorgey for showing me this trick! + specialBuilder NAppOp (InfixL $ annNApp <$ symbols mempty) <> + specialBuilder NHasAttrOp (Postfix $ symbol '?' *> (flip annNHasAttr <$> nixSelector)) <> + builder prefix <> + builder binary + where + specialBuilder :: NOp t => t -> b -> [(NOpPrecedence, b)] + specialBuilder op parser = one (entry op (const parser)) + + builder :: (Enum t, Bounded t, NOp t) => (t -> b) -> [(NOpPrecedence, b)] + builder tp = fmap (`entry` tp) universe + + entry :: NOp t => t -> (t -> b) -> (NOpPrecedence, b) + entry op parser = (getOpPrecedence op, parser op) + + +-- ** Expr & its constituents (Language term, expr algebra) + +nixTerm :: Parser NExprLoc +nixTerm = + do + c <- try . lookAhead . satisfy $ + \x -> (`elem` ("({[ nixSelect nixParens + '{' -> nixSelect nixSet + '[' -> nixList + '<' -> nixSearchPath + '/' -> nixPath + '"' -> nixString + '\'' -> nixString + '^' -> nixSynHole + _ -> + msum + $ [ nixSelect nixSet | c == 'r' ] + <> [ nixPath | pathChar c ] + <> if isDigit c + then [ nixFloat, nixInt ] + else + [ nixUri | isAlpha c ] + <> [ nixBool | c == 't' || c == 'f' ] + <> [ nixNull | c == 'n' ] + <> one (nixSelect nixSym) + +-- | Bundles parsers into @[[]]@ based on precedence (form is required for `megaparsec`). +nixOperators :: [[ Operator Parser NExprLoc ]] +nixOperators = + snd <$> + groupSort opParsers + +-- | Nix expression algebra parser. +-- "Expression algebra" is to explain @megaparsec@ use of the term "Expression" (parser for language algebraic coperators without any statements (without @let@ etc.)), which is essentially an algebra inside the language. +nixExprAlgebra :: Parser NExprLoc +nixExprAlgebra = + makeExprParser + nixTerm + nixOperators + +nixExpr :: Parser NExprLoc +nixExpr = keywords <|> nixLambda <|> nixExprAlgebra + where + keywords = nixLet <|> nixIf <|> nixAssert <|> nixWith + + +-- * Parse + +type Result a = Either (Doc Void) a + + +parseWith + :: Parser a + -> Path + -> Text + -> Either (Doc Void) a +parseWith parser file input = + either + (Left . pretty . errorBundlePretty) + pure + $ (`evalState` initialPos (coerce file)) $ (`runParserT` coerce file) parser input + + +parseFromFileEx :: MonadFile m => Parser a -> Path -> m (Result a) +parseFromFileEx parser file = parseWith parser file <$> readFile file + +parseFromText :: Parser a -> Text -> Result a +parseFromText = (`parseWith` "") + +fullContent :: Parser NExprLoc +fullContent = whiteSpace *> nixExpr <* eof + +parseNixFile' :: MonadFile m => (Parser NExprLoc -> Parser a) -> Path -> m (Result a) +parseNixFile' f = + parseFromFileEx $ f fullContent + +parseNixFile :: MonadFile m => Path -> m (Result NExpr) +parseNixFile = + parseNixFile' (stripAnnotation <$>) + +parseNixFileLoc :: MonadFile m => Path -> m (Result NExprLoc) +parseNixFileLoc = + parseNixFile' id + +parseNixText' :: (Parser NExprLoc -> Parser a) -> Text -> Result a +parseNixText' f = + parseFromText $ f fullContent + +parseNixText :: Text -> Result NExpr +parseNixText = + parseNixText' (stripAnnotation <$>) + +parseNixTextLoc :: Text -> Result NExprLoc +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 @@ -1,14 +1,11 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# language CPP #-} +{-# language AllowAmbiguousTypes #-} +{-# options_ghc -fno-warn-name-shadowing #-} module Nix.Pretty where -import Prelude hiding ( toList, group ) -import Nix.Utils +import Nix.Prelude hiding ( toList, group ) import Control.Monad.Free ( Free(Free) ) import Data.Fix ( Fix(..) , foldFix ) @@ -23,7 +20,8 @@ import Prettyprinter hiding ( list ) import Nix.Atoms import Nix.Cited -import Nix.Expr +import Nix.Expr.Types +import Nix.Expr.Types.Annotated import Nix.Expr.Strings import Nix.Normal import Nix.Parser @@ -34,26 +32,35 @@ -- | 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 -- operator. It is needed to determine if we need to wrap the expression in -- parentheses. - , rootOp :: OperatorInfo + , rootOp :: NOperatorDef , wasPath :: Bool -- This is needed so that when a path is used in a selector path -- we can add brackets appropriately } -mkNixDoc :: OperatorInfo -> Doc ann -> NixDoc ann -mkNixDoc o d = NixDoc { withoutParens = d, rootOp = o, wasPath = False } +-- | Represent Nix antiquotes. +-- +-- > +-- > ${ expr } +-- > +antiquote :: NixDoc ann -> Doc ann +antiquote x = "${" <> getDoc x <> "}" +mkNixDoc :: NOperatorDef -> Doc ann -> NixDoc ann +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 -- other operators (including function application). simpleExpr :: Doc ann -> NixDoc ann -simpleExpr = mkNixDoc $ OperatorInfo minBound NAssocNone "simple expr" +simpleExpr = + mkNixDoc $ NSpecialDef NTerm NAssoc minBound "simple expr" pathExpr :: Doc ann -> NixDoc ann pathExpr d = (simpleExpr d) { wasPath = True } @@ -65,248 +72,284 @@ -- binding). leastPrecedence :: Doc ann -> NixDoc ann leastPrecedence = - mkNixDoc (OperatorInfo maxBound NAssocNone "least precedence") + mkNixDoc $ NSpecialDef NTerm NAssoc maxBound "least precedence" -appOp :: OperatorInfo -appOp = getBinaryOperator NApp -appOpNonAssoc :: OperatorInfo -appOpNonAssoc = (getBinaryOperator NApp) { associativity = NAssocNone } - -selectOp :: OperatorInfo -selectOp = getSpecialOperator NSelectOp +data WrapMode + = ProcessAllWrap + | PrecedenceWrap + deriving Eq -hasAttrOp :: OperatorInfo -hasAttrOp = getSpecialOperator NHasAttrOp +needsParens + :: WrapMode + -> NOperatorDef + -> NOperatorDef + -> Bool +needsParens mode host sub = + getOpPrecedence host > getOpPrecedence sub + || bool + False + ( NAssoc /= getOpAssoc host + && on (==) getOpAssoc host sub + && on (==) getOpPrecedence host sub + ) + (ProcessAllWrap == mode) -wrapParens :: OperatorInfo -> NixDoc ann -> Doc ann -wrapParens op sub = +maybeWrapDoc :: WrapMode -> NOperatorDef -> NixDoc ann -> Doc ann +maybeWrapDoc mode host sub = bool - (\ a -> "(" <> a <> ")") + parens id - ( precedence (rootOp sub) < precedence op - || (precedence (rootOp sub) == precedence op - && associativity (rootOp sub) == associativity op - && associativity op /= NAssocNone) - ) - (withoutParens sub) + (needsParens mode host (rootOp sub)) + (getDoc sub) +-- | Determine if to return doc wraped into parens, +-- according the given operator. +wrap :: NOperatorDef -> NixDoc ann -> Doc ann +wrap = maybeWrapDoc ProcessAllWrap + +precedenceWrap :: NOperatorDef -> NixDoc ann -> Doc ann +precedenceWrap = maybeWrapDoc PrecedenceWrap + -- Used in the selector case to print a path in a selector as -- "${./abc}" -wrapPath :: OperatorInfo -> NixDoc ann -> Doc ann +wrapPath :: NOperatorDef -> NixDoc ann -> Doc ann wrapPath op sub = bool - (wrapParens op sub) - ("\"${" <> withoutParens sub <> "}\"") + (wrap op sub) + (dquotes $ antiquote sub) (wasPath sub) +-- | Handle Output representation of the string escape codes. prettyString :: NString (NixDoc ann) -> Doc ann -prettyString (DoubleQuoted parts) = "\"" <> (mconcat . fmap 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 . concatMap escape . toString $ t + prettyPart (Plain t) = pretty $ escapeString t prettyPart EscapedNewline = "''\\n" - prettyPart (Antiquoted r) = "${" <> withoutParens r <> "}" - escape '"' = "\\\"" - escape x = - maybe - [x] - (('\\' :) . (: mempty)) - (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 = reverse . f . reverse where - f ([Plain t] : xs) | Text.null (strip t) = xs - f xs = xs - prettyLine = hcat . fmap prettyPart - prettyPart (Plain t) = - pretty . replace "${" "''${" . replace "''" "'''" $ t - prettyPart EscapedNewline = "\\n" - prettyPart (Antiquoted r) = "${" <> withoutParens r <> "}" + stripLastIfEmpty :: [[Antiquoted Text r]] -> [[Antiquoted Text r]] + stripLastIfEmpty = + filter flt + where + flt :: [Antiquoted Text r] -> Bool + flt [Plain t] | Text.null (strip t) = False + flt _ = True + 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 + prettyParams :: Params (NixDoc ann) -> Doc ann -prettyParams (Param n ) = pretty n -prettyParams (ParamSet s v mname) = prettyParamSet s v <> - maybe - mempty - (\ name -> - bool - mempty - ("@" <> pretty name) - (not (Text.null name)) - ) - mname +prettyParams (Param n ) = prettyVarName n +prettyParams (ParamSet mname variadic pset) = + prettyParamSet variadic pset <> + toDoc `whenJust` mname + where + toDoc :: VarName -> Doc ann + toDoc (coerce -> name) = + ("@" <> pretty name) `whenFalse` Text.null name -prettyParamSet :: ParamSet (NixDoc ann) -> Bool -> Doc ann -prettyParamSet args var = +prettyParamSet :: forall ann . Variadic -> ParamSet (NixDoc ann) -> Doc ann +prettyParamSet variadic args = encloseSep "{ " (align " }") - sep - (fmap prettySetArg args <> prettyVariadic) + (align ", ") + (fmap prettySetArg args <> one "..." `whenTrue` (variadic == Variadic)) where + prettySetArg :: (VarName, Maybe (NixDoc ann)) -> Doc ann prettySetArg (n, maybeDef) = - maybe - (pretty n) - (\x -> pretty n <> " ? " <> withoutParens x) - maybeDef - prettyVariadic = [ "..." | var ] - 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 $ prettyKeyName <$> ns) <> ";" - where - scope = - maybe - mempty - ((<> " ") . parens . withoutParens) - s + "inherit " <> scope <> align (fillSep $ prettyVarName <$> ns) <> ";" + where + scope = + ((<> " ") . parens . getDoc) `whenJust` s prettyKeyName :: NKeyName (NixDoc ann) -> Doc ann -prettyKeyName (StaticKey "") = "\"\"" -prettyKeyName (StaticKey key) | HashSet.member key reservedNames = "\"" <> pretty key <> "\"" -prettyKeyName (StaticKey key) = pretty key +prettyKeyName (StaticKey key) = + bool + "\"\"" + (bool + id + dquotes + (HashSet.member key reservedNames) + (prettyVarName key) + ) + (not $ Text.null $ coerce key) prettyKeyName (DynamicKey key) = runAntiquoted - (DoubleQuoted [Plain "\n"]) + (DoubleQuoted $ one $ Plain "\n") prettyString - (\ x -> "${" <> withoutParens x <> "}") + antiquote key prettySelector :: NAttrPath (NixDoc ann) -> Doc ann prettySelector = hcat . punctuate "." . fmap prettyKeyName . NE.toList prettyAtom :: NAtom -> NixDoc ann -prettyAtom atom = simpleExpr $ pretty $ atomText atom +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 = exprFNixDoc . stripAnn . fmap render + 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 (getOriginExpr p) + render _ = simpleExpr "?" + -- render (Just (NValue (citations -> ps))) = + -- simpleExpr $ foldr ((\x y -> vsep [x, y]) . parens . indent 2 . getDoc + -- . go . originExpr) + -- mempty (reverse ps) - render :: Maybe (NValue t f m) -> NixDoc ann - render Nothing = simpleExpr "_" - render (Just (Free (reverse . citations @m -> p:_))) = go (_originExpr p) - render _ = simpleExpr "?" - -- render (Just (NValue (citations -> ps))) = - -- simpleExpr $ foldr ((\x y -> vsep [x, y]) . parens . indent 2 . withoutParens - -- . go . originExpr) - -- mempty (reverse ps) +-- | 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 :: NExprF (NixDoc ann) -> NixDoc ann +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 - NSet NNonRecursive xs -> + prettyContainer "[" (precedenceWrap appOpDef) "]" xs + NSet NonRecursive xs -> prettyContainer "{" prettyBind "}" xs - NSet NRecursive xs -> + NSet Recursive xs -> prettyContainer "rec {" prettyBind "}" xs NAbs args body -> leastPrecedence $ nest 2 $ vsep [ prettyParams args <> ":" - , withoutParens body + , getDoc body ] - NBinary NApp fun arg -> - mkNixDoc appOp (wrapParens appOp fun <> " " <> wrapParens appOpNonAssoc arg) + NApp fun arg -> + mkNixDoc appOpDef (wrap appOpDef fun <> " " <> precedenceWrap appOpDef arg) NBinary op r1 r2 -> mkNixDoc - opInfo $ + opDef $ hsep - [ wrapParens (f NAssocLeft) r1 - , pretty $ operatorName opInfo - , wrapParens (f NAssocRight) r2 + [ pickWrapMode NAssocLeft r1 + , pretty @Text $ coerce @NOpName $ getOpName op + , pickWrapMode NAssocRight r2 ] where - opInfo = getBinaryOperator op - f x = + opDef = getOpDef op + + pickWrapMode :: NAssoc -> NixDoc ann -> Doc ann + pickWrapMode x = bool - opInfo - (opInfo { associativity = NAssocNone }) - (associativity opInfo /= x) + wrap + precedenceWrap + (getOpAssoc opDef /= x) + opDef NUnary op r1 -> mkNixDoc - opInfo - (pretty (operatorName opInfo) <> wrapParens opInfo r1) - where opInfo = getUnaryOperator op - NSelect r' attr o -> + opDef $ + pretty @Text (coerce $ getOpName op) <> wrap opDef r1 + where + opDef = getOpDef op + NSelect o r' attr -> maybe (mkNixDoc selectOp) (const leastPrecedence) o - $ wrapPath selectOp r <> "." <> prettySelector attr <> ordoc + $ wrapPath selectOp (mkNixDoc selectOp (wrap appOpDef r')) <> "." <> prettySelector attr <> + ((" or " <>) . precedenceWrap appOpDef) `whenJust` o where - r = mkNixDoc selectOp (wrapParens appOpNonAssoc r') - ordoc = - maybe - mempty - ((" or " <>) . wrapParens appOpNonAssoc) - o + selectOp :: NOperatorDef + selectOp = getOpDef NSelectOp + NHasAttr r attr -> - mkNixDoc hasAttrOp (wrapParens hasAttrOp r <> " ? " <> prettySelector attr) - NEnvPath p -> simpleExpr $ pretty ("<" <> p <> ">") + mkNixDoc hasAttrOp (wrap hasAttrOp r <> " ? " <> prettySelector attr) + where + hasAttrOp :: NOperatorDef + hasAttrOp = getOpDef NHasAttrOp + + NEnvPath p -> simpleExpr $ pretty @String $ "<" <> coerce p <> ">" NLiteralPath p -> pathExpr $ - pretty $ + pretty @FilePath $ coerce $ case p of "./" -> "./." "../" -> "../." ".." -> "../." - _txt -> + path -> bool - ("./" <> _txt) - _txt - (any (`isPrefixOf` _txt) ["/", "~/", "./", "../"]) - NSym name -> simpleExpr $ pretty name + ("./" <> 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) - ] + nest 2 ifThenElse + where + ifThenElse :: Doc ann + ifThenElse = + sep + [ "if " <> getDoc cond + , align $ "then " <> getDoc trueBody + , align $ "else " <> getDoc falseBody + ] NWith scope body -> prettyAddScope "with " scope body NAssert cond body -> prettyAddScope "assert " cond body - NSynHole name -> simpleExpr $ pretty ("^" <> name) + NSynHole name -> simpleExpr $ pretty @Text ("^" <> coerce name) where prettyContainer h f t c = - list + handlePresence (simpleExpr (h <> t)) - (const $ simpleExpr $ group $ nest 2 $ vsep $ [h] <> (f <$> c) <> [t]) + (const $ simpleExpr $ group $ nest 2 (h <> line <> vsep (f <$> c)) <> line <> t) c 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 @@ -316,43 +359,61 @@ phi :: NValue' t f m NExpr -> NExprF NExpr phi (NVConstant' a ) = NConstant a - phi (NVStr' ns ) = NStr $ DoubleQuoted [Plain (stringIgnoreContext ns)] + phi (NVStr' ns ) = NStr $ DoubleQuoted $ one $ Plain $ ignoreContext ns phi (NVList' l ) = NList l - phi (NVSet' s p) = NSet NNonRecursive - [ NamedVar (StaticKey k :| mempty) v (fromMaybe nullPos (M.lookup k p)) + phi (NVSet' p s) = NSet mempty + [ NamedVar (one $ StaticKey k) v (fromMaybe nullPos $ (`M.lookup` p) k) | (k, v) <- toList s ] phi (NVClosure' _ _) = NSym "" phi (NVPath' p ) = NLiteralPath p - phi (NVBuiltin' name _) = NSym $ "builtins." <> name + phi (NVBuiltin' name _) = NSym $ coerce ((mappend @Text) "builtins.") name prettyNValue :: 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 = - list - prettyNVal - (\ ps -> +prettyProv wasThunk v = + handlePresence + id + (\ ps pv -> fillSep - [ prettyNVal + [ pv , indent 2 $ - "(" <> mconcat ("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 @@ -363,41 +424,32 @@ => 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 $ - "(" <> mconcat ( "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 -> String -printNix = iterNValueByDiscardWith thk phi +printNix :: forall t f m . MonadDataContext f m => NValue t f m -> Text +printNix = + iterNValueByDiscardWith thunkStubText phi where - thk = toString thunkStubText - - phi :: NValue' t f m String -> String - phi (NVConstant' a ) = toString $ atomText a - phi (NVStr' ns) = show $ stringIgnoreContext ns - phi (NVList' l ) = toString $ "[ " <> unwords (fmap toText l) <> " ]" - phi (NVSet' s _) = + phi :: NValue' t f m Text -> Text + phi (NVConstant' a ) = atomText a + phi (NVStr' ns) = "\"" <> escapeString (ignoreContext ns) <> "\"" + phi (NVList' l ) = "[ " <> unwords l <> " ]" + phi (NVSet' _ s) = "{ " <> - concat - [ check (toString k) <> " = " <> v <> "; " - | (k, v) <- sort $ toList s + fold + [ check k <> " = " <> v <> "; " + | (coerce -> k, v) <- sort $ toList s ] <> "}" where - check :: [Char] -> [Char] + check :: Text -> Text check v = fromMaybe v - (fmap (surround . show) (readMaybe v :: Maybe Int) - <|> fmap (surround . show) (readMaybe v :: Maybe Float) - ) - where surround s = "\"" <> s <> "\"" + (tryRead @Int <|> tryRead @Float) + where + tryRead :: forall a . (Read a, Show a) => Maybe Text + tryRead = fmap ((\ s -> "\"" <> s <> "\"") . show) $ readMaybe @a $ toString v phi NVClosure'{} = "<>" - phi (NVPath' fp ) = fp - phi (NVBuiltin' name _) = toString $ "< name <> ">>" + 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 @@ -1,13 +1,11 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} +{-# language CPP #-} +{-# language AllowAmbiguousTypes #-} +{-# language ConstraintKinds #-} +{-# language GeneralizedNewtypeDeriving #-} +{-# language PartialTypeSignatures #-} +{-# language TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# options_ghc -fno-warn-name-shadowing #-} -- | This module provides a "reducing" expression evaluator, which reduces @@ -22,8 +20,9 @@ , reducingEvalExpr ) where +import Nix.Prelude import Control.Monad.Catch ( MonadCatch(catch) ) -#if !MIN_VERSION_base(4,13,0) +#if !MIN_VERSION_base(4,12,0) import Prelude hiding ( fail ) import Control.Monad.Fail #endif @@ -42,26 +41,26 @@ import qualified Text.Show import Nix.Atoms import Nix.Effects.Basic ( pathToDefaultNixFile ) -import Nix.Expr +import Nix.Expr.Types +import Nix.Expr.Types.Annotated import Nix.Frames import Nix.Options ( Options - , reduceSets - , reduceLists + , isReduceSets + , isReduceLists + , askOptions ) import Nix.Parser import Nix.Scope -import Nix.Utils import System.Directory -import System.FilePath newtype Reducer m a = Reducer { runReducer :: ReaderT - ( Maybe FilePath + ( Maybe Path , Scopes (Reducer m) NExprLoc ) ( StateT - ( HashMap FilePath NExprLoc + ( HashMap Path NExprLoc , HashMap Text Text ) m @@ -71,8 +70,8 @@ deriving ( Functor, Applicative, Alternative , Monad, MonadPlus, MonadFix, MonadIO, MonadFail - , MonadReader (Maybe FilePath, Scopes (Reducer m) NExprLoc) - , MonadState (HashMap FilePath NExprLoc, HashMap Text Text) + , MonadReader (Maybe Path, Scopes (Reducer m) NExprLoc) + , MonadState (HashMap Path NExprLoc, HashMap Text Text) ) staticImport @@ -80,59 +79,62 @@ . ( MonadIO m , Scoped NExprLoc m , MonadFail m - , MonadReader (Maybe FilePath, Scopes m NExprLoc) m - , MonadState (HashMap FilePath NExprLoc, HashMap Text Text) m + , MonadReader (Maybe Path, Scopes m NExprLoc) m + , MonadState (HashMap Path NExprLoc, HashMap Text Text) m ) => SrcSpan - -> FilePath + -> Path -> m NExprLoc -staticImport pann path = do - mfile <- asks fst - path <- liftIO $ pathToDefaultNixFile path - path' <- liftIO $ pathToDefaultNixFile =<< canonicalizePath - (maybe id (() . takeDirectory) mfile path) +staticImport pann path = + do + mfile <- asks fst + path' <- liftIO $ pathToDefaultNixFile path + path'' <- liftIO $ pathToDefaultNixFile =<< coerce canonicalizePath + (maybe id (() . takeDirectory) mfile path') - imports <- gets fst - maybe - (go path') - pure - (HM.lookup path' imports) - where - go path = do - liftIO $ putStrLn $ "Importing file " <> path + let + importIt :: m NExprLoc + importIt = do + liftIO $ putStrLn $ "Importing file " <> coerce path'' - eres <- liftIO $ parseNixFileLoc path - either - (\ err -> fail $ "Parse failed: " <> show err) - (\ x -> do - let - pos = SourcePos "Reduce.hs" (mkPos 1) (mkPos 1) - span = SrcSpan pos pos - cur = - NamedVar - (StaticKey "__cur_file" :| mempty) - (Fix (NLiteralPath_ pann path)) - pos - x' = Fix $ NLet_ span [cur] x - modify $ first $ HM.insert path x' - local - (const (pure path, mempty)) $ - do - x'' <- foldFix reduce x' - modify $ first $ HM.insert path x'' - pure x'' - ) - eres + eres <- liftIO $ parseNixFileLoc path'' + either + (\ err -> fail $ "Parse failed: " <> show err) + (\ x -> do + let + pos = join (NSourcePos "Reduce.hs") $ (coerce . mkPos) 1 + span = join SrcSpan pos + cur = + NamedVar + (one $ StaticKey "__cur_file") + (NLiteralPathAnn pann path'') + pos + x' = NLetAnn span (one cur) x + modify $ first $ HM.insert path'' x' + local + (const (pure path'', mempty)) $ + do + x'' <- foldFix reduce x' + modify $ first $ HM.insert path'' x'' + pure x'' + ) + eres + imports <- gets fst + maybe + importIt + pure + (HM.lookup path'' imports) + -- gatherNames :: NExprLoc -> HashSet VarName -- gatherNames = foldFix $ \case --- NSym_ _ var -> S.singleton var --- Compose (Ann _ x) -> fold x +-- NSymAnnF _ var -> S.singleton var +-- AnnF _ x -> fold x reduceExpr - :: (MonadIO m, MonadFail m) => Maybe FilePath -> NExprLoc -> m NExprLoc + :: (MonadIO m, MonadFail m) => Maybe Path -> NExprLoc -> m NExprLoc reduceExpr mpath expr = - (`evalStateT` (mempty, mempty)) + (`evalStateT` mempty) . (`runReaderT` (mpath, mempty)) . runReducer $ foldFix reduce expr @@ -142,26 +144,26 @@ . ( MonadIO m , Scoped NExprLoc m , MonadFail m - , MonadReader (Maybe FilePath, Scopes m NExprLoc) m - , MonadState (HashMap FilePath NExprLoc, HashMap Text Text) m + , MonadReader (Maybe Path, Scopes m NExprLoc) m + , MonadState (HashMap Path NExprLoc, HashMap Text Text) m ) => NExprLocF (m NExprLoc) -> m NExprLoc -- | Reduce the variable to its value if defined. -- Leave it as it is otherwise. -reduce (NSym_ ann var) = - fromMaybe (Fix (NSym_ ann var)) <$> lookupVar var +reduce (NSymAnnF ann var) = + fromMaybe (NSymAnn ann var) <$> lookupVar var -- | Reduce binary and integer negation. -reduce (NUnary_ uann op arg) = +reduce (NUnaryAnnF uann op arg) = do x <- arg - pure $ Fix $ + pure $ case (op, x) of - (NNeg, Fix (NConstant_ cann (NInt n))) -> NConstant_ cann $ NInt $ negate n - (NNot, Fix (NConstant_ cann (NBool b))) -> NConstant_ cann $ NBool $ not b - _ -> NUnary_ uann op x + (NNeg, NConstantAnn cann (NInt n)) -> NConstantAnn cann $ NInt $ negate n + (NNot, NConstantAnn cann (NBool b)) -> NConstantAnn cann $ NBool $ not b + _ -> NUnaryAnn uann op x -- | Reduce function applications. -- @@ -169,32 +171,34 @@ -- -- * Reduce a lambda function by adding its name to the local -- scope and recursively reducing its body. -reduce (NBinary_ bann NApp fun arg) = fun >>= \case - f@(Fix (NSym_ _ "import")) -> - (\case - -- Fix (NEnvPath_ pann origPath) -> staticImport pann origPath - Fix (NLiteralPath_ pann origPath) -> staticImport pann origPath - v -> pure $ Fix $ NBinary_ bann NApp f v - ) =<< arg +reduce (NAppAnnF bann fun arg) = + (\case + f@(NSymAnn _ "import") -> + (\case + -- NEnvPathAnn pann origPath -> staticImport pann origPath + NLiteralPathAnn pann origPath -> staticImport pann origPath + v -> pure $ NAppAnn bann f v + ) =<< arg - Fix (NAbs_ _ (Param name) body) -> - do - x <- arg - pushScope - (HM.singleton name x) - (foldFix reduce body) + NAbsAnn _ (Param name) body -> + do + x <- arg + pushScope + (coerce $ HM.singleton name x) + (foldFix reduce body) - f -> Fix . NBinary_ bann NApp f <$> arg + f -> NAppAnn bann f <$> arg + ) =<< fun -- | Reduce an integer addition to its result. -reduce (NBinary_ bann op larg rarg) = +reduce (NBinaryAnnF bann op larg rarg) = do lval <- larg rval <- rarg - pure $ Fix $ + pure $ case (op, lval, rval) of - (NPlus, Fix (NConstant_ ann (NInt x)), Fix (NConstant_ _ (NInt y))) -> NConstant_ ann $ NInt $ x + y - _ -> NBinary_ bann op lval rval + (NPlus, NConstantAnn ann (NInt x), NConstantAnn _ (NInt y)) -> NConstantAnn ann $ NInt $ x + y + _ -> NBinaryAnn bann op lval rval -- | Reduce a select on a Set by substituting the set to the selected value. -- @@ -203,13 +207,13 @@ -- 1. The selected expr is indeed a set. -- 2. The selection AttrPath is a list of StaticKeys. -- 3. The selected AttrPath exists in the set. -reduce base@(NSelect_ _ _ attrs _) +reduce base@(NSelectAnnF _ _ _ attrs) | sAttrPath $ NE.toList attrs = do - (NSelect_ _ aset attrs _) <- sequence base + (NSelectAnnF _ _ aset attrs) <- sequenceA base inspectSet (unFix aset) attrs | otherwise = sId where - sId = Fix <$> sequence base + sId = reduceLayer base -- The selection AttrPath is composed of StaticKeys. sAttrPath (StaticKey _ : xs) = sAttrPath xs sAttrPath [] = True @@ -220,7 +224,7 @@ n@(NamedVar (a' :| _) _ _) | a' == a -> pure n _ -> findBind xs attrs -- Follow the attrpath recursively in sets. - inspectSet (NSet_ _ NNonRecursive binds) attrs = case findBind binds attrs of + inspectSet (NSetAnnF _ NonRecursive binds) attrs = case findBind binds attrs of Just (NamedVar _ e _) -> case NE.uncons attrs of (_, Just attrs) -> inspectSet (unFix e) attrs _ -> pure e @@ -231,49 +235,52 @@ -- | Reduce a set by inlining its binds outside of the set -- if none of the binds inherit the super set. -reduce e@(NSet_ ann NNonRecursive binds) = - do - let - usesInherit = - any - (\case - Inherit{} -> True - _ -> False - ) - binds - - bool - (Fix <$> sequence e) - (clearScopes @NExprLoc $ Fix . NSet_ ann NNonRecursive <$> traverse sequence binds) +reduce e@(NSetAnnF ann r binds) = + bool + -- Encountering a 'rec set' construction eliminates any hope of inlining + -- definitions. + mExprLoc + (bool + (reduceLayer e) + mExprLoc usesInherit + ) + (r == NonRecursive) + where + mExprLoc :: m NExprLoc + mExprLoc = + clearScopes @NExprLoc $ NSetAnn ann r <$> traverse sequenceA binds --- Encountering a 'rec set' construction eliminates any hope of inlining --- definitions. -reduce (NSet_ ann NRecursive binds) = - clearScopes @NExprLoc $ Fix . NSet_ ann NRecursive <$> traverse sequence binds + usesInherit = + any + (\case + Inherit{} -> True + _ -> False + ) + binds -- Encountering a 'with' construction eliminates any hope of inlining -- definitions. -reduce (NWith_ ann scope body) = - clearScopes @NExprLoc $ Fix <$> liftA2 (NWith_ ann) scope body +reduce (NWithAnnF ann scope body) = + clearScopes @NExprLoc $ liftA2 (NWithAnn ann) scope body -- | Reduce a let binds section by pushing lambdas, -- constants and strings to the body scope. -reduce (NLet_ ann binds body) = +reduce (NLetAnnF ann binds body) = do - binds' <- traverse sequence binds + binds' <- traverse sequenceA binds body' <- - (`pushScope` body) . HM.fromList . catMaybes =<< + (`pushScope` body) . coerce . HM.fromList . catMaybes =<< traverse (\case NamedVar (StaticKey name :| []) def _pos -> let defcase = \case - d@(Fix NAbs_ {}) -> pure (name, d) - d@(Fix NConstant_{}) -> pure (name, d) - d@(Fix NStr_ {}) -> pure (name, d) - _ -> Nothing + d@NAbsAnn {} -> pure (name, d) + d@NConstantAnn{} -> pure (name, d) + d@NStrAnn {} -> pure (name, d) + _ -> Nothing in defcase <$> def @@ -282,11 +289,11 @@ binds -- let names = gatherNames body' - -- binds' <- traverse sequence binds <&> \b -> flip filter b $ \case + -- binds' <- traverse sequenceA binds <&> \b -> flip filter b $ \case -- NamedVar (StaticKey name _ :| []) _ -> -- name `S.member` names -- _ -> True - pure $ Fix $ NLet_ ann binds' body' + pure $ NLetAnn ann binds' body' -- where -- go m [] = pure m -- go m (x:xs) = case x of @@ -297,34 +304,37 @@ -- | Reduce an if to the relevant path if -- the condition is a boolean constant. -reduce e@(NIf_ _ b t f) = +reduce e@(NIfAnnF _ b t f) = (\case - Fix (NConstant_ _ (NBool b')) -> if b' then t else f - _ -> Fix <$> sequence e + NConstantAnn _ (NBool b') -> bool f t b' + _ -> reduceLayer e ) =<< b -- | Reduce an assert atom to its encapsulated -- symbol if the assertion is a boolean constant. -reduce e@(NAssert_ _ b body) = +reduce e@(NAssertAnnF _ b body) = (\case - Fix (NConstant_ _ (NBool b')) | b' -> body - _ -> Fix <$> sequence e + NConstantAnn _ (NBool True) -> body + _ -> reduceLayer e ) =<< b -reduce (NAbs_ ann params body) = do - params' <- sequence params +reduce (NAbsAnnF ann params body) = do + params' <- sequenceA params -- Make sure that variable definitions in scope do not override function -- arguments. let - args = + scope = coerce $ case params' of - Param name -> HM.singleton name $ Fix $ NSym_ ann name - ParamSet pset _ _ -> - HM.fromList $ (\(k, _) -> (k, Fix $ NSym_ ann k)) <$> pset - Fix . NAbs_ ann params' <$> pushScope args body + Param name -> one (name, NSymAnn ann name) + ParamSet _ _ pset -> + HM.fromList $ (\(k, _) -> (k, NSymAnn ann k)) <$> pset + NAbsAnn ann params' <$> pushScope scope body -reduce v = Fix <$> sequence v +reduce v = reduceLayer v +reduceLayer :: (Traversable f1, Applicative f2) => f1 (f2 (Fix f1)) -> f2 (Fix f1) +reduceLayer v = Fix <$> sequenceA v + -- newtype FlaggedF f r = FlaggedF { flagged :: (IORef Bool, f r) } newtype FlaggedF f r = FlaggedF (IORef Bool, f r) deriving (Functor, Foldable, Traversable) @@ -337,7 +347,7 @@ flagExprLoc :: (MonadIO n, Traversable f) => Fix f -> n (Flagged f) flagExprLoc = foldFixM $ \x -> do flag <- liftIO $ newIORef False - pure $ Fix $ FlaggedF (flag, x) + pure $ coerce (flag, x) -- stripFlags :: Functor f => Flagged f -> Fix f -- stripFlags = foldFix $ Fix . snd . flagged @@ -348,7 +358,7 @@ \(FlaggedF (b, Compose x)) -> bool Nothing - (Fix . Compose <$> traverse prune x) + (annUnitToAnn <$> traverse prune x) <$> liftIO (readIORef b) where prune :: NExprF (Maybe NExprLoc) -> Maybe (NExprF NExprLoc) @@ -360,55 +370,55 @@ NList l -> pure $ NList $ bool - (fromMaybe nNull <$>) + (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 nNull <<$>>) - (mapMaybe sequence) - (reduceSets opts) -- Reduce set members that aren't used; breaks if hasAttr is used + (fromMaybe annNNull <<$>>) + (mapMaybe sequenceA) + (isReduceSets opts) -- Reduce set members that aren't used; breaks if hasAttr is used binds - NLet binds (Just body@(AnnE _ x)) -> + NLet binds (Just body@(Ann _ x)) -> pure $ - list + handlePresence x (`NLet` body) (mapMaybe pruneBinding binds) - NSelect (Just aset) attr alt -> - pure $ NSelect aset (pruneKeyName <$> attr) $ join alt - - -- These are the only short-circuiting binary operators - NBinary NAnd (Just (AnnE _ larg)) _ -> pure larg - NBinary NOr (Just (AnnE _ larg)) _ -> pure larg + NSelect alt (Just aset) attr -> + pure $ NSelect (join alt) aset $ pruneKeyName <$> attr -- If the function was never called, it means its argument was in a -- thunk that was forced elsewhere. - NBinary NApp Nothing (Just _) -> Nothing + NApp Nothing (Just _) -> Nothing + -- These are the only short-circuiting binary operators + NBinary NAnd (Just (Ann _ larg)) _ -> pure larg + NBinary NOr (Just (Ann _ larg)) _ -> pure larg + -- The idea behind emitted a binary operator where one side may be -- invalid is that we're trying to emit what will reproduce whatever -- fail the user encountered, which means providing all aspects of -- the evaluation path they ultimately followed. - NBinary op Nothing (Just rarg) -> pure $ NBinary op nNull rarg - NBinary op (Just larg) Nothing -> pure $ NBinary op larg nNull + NBinary op Nothing (Just rarg) -> pure $ NBinary op annNNull rarg + NBinary op (Just larg) Nothing -> pure $ NBinary op larg annNNull -- If the scope of a with was never referenced, it's not needed - NWith Nothing (Just (AnnE _ body)) -> pure body + NWith Nothing (Just (Ann _ body)) -> pure body NAssert Nothing _ -> fail "How can an assert be used, but its condition not?" - NAssert _ (Just (AnnE _ body)) -> pure body - NAssert (Just cond) _ -> pure $ NAssert cond nNull + NAssert _ (Just (Ann _ body)) -> pure body + NAssert (Just cond) _ -> pure $ NAssert cond annNNull NIf Nothing _ _ -> fail "How can an if be used, but its condition not?" - NIf _ Nothing (Just (AnnE _ f)) -> pure f - NIf _ (Just (AnnE _ t)) Nothing -> pure t + NIf _ Nothing (Just (Ann _ f)) -> pure f + NIf _ (Just (Ann _ t)) Nothing -> pure t - x -> sequence x + x -> sequenceA x pruneString :: NString (Maybe NExprLoc) -> NString NExprLoc pruneString (DoubleQuoted xs) = DoubleQuoted $ mapMaybe pruneAntiquotedText xs @@ -436,28 +446,28 @@ pruneParams :: Params (Maybe NExprLoc) -> Params NExprLoc pruneParams (Param n) = Param n - pruneParams (ParamSet xs b n) = - ParamSet (reduceOrPassMode <$> xs) b n + pruneParams (ParamSet mname variadic pset) = + ParamSet mname variadic (reduceOrPassMode <$> pset) where reduceOrPassMode = second $ bool fmap - ((pure .) . maybe nNull) - (reduceSets opts) -- Reduce set members that aren't used; breaks if hasAttr is used - (fromMaybe nNull) + ((pure .) . maybe annNNull) + (isReduceSets opts) -- Reduce set members that aren't used; breaks if hasAttr is used + (fromMaybe annNNull) pruneBinding :: Binding (Maybe NExprLoc) -> Maybe (Binding NExprLoc) pruneBinding (NamedVar _ Nothing _ ) = Nothing pruneBinding (NamedVar xs (Just x) pos) = pure $ NamedVar (pruneKeyName <$> xs) x pos pruneBinding (Inherit _ [] _ ) = Nothing pruneBinding (Inherit (join -> Nothing) _ _ ) = Nothing - pruneBinding (Inherit (join -> m) xs pos) = pure $ Inherit m (pruneKeyName <$> xs) pos + pruneBinding (Inherit (join -> m) xs pos) = pure $ Inherit m xs pos reducingEvalExpr :: (Framed e m, Has e Options, Exception r, MonadCatch m, MonadIO m) => (NExprLocF (m a) -> m a) - -> Maybe FilePath + -> Maybe Path -> NExprLoc -> m (NExprLoc, Either r a) reducingEvalExpr eval mpath expr = @@ -465,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 nNull expr'', eres) + 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 @@ -1,103 +1,103 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE MultiWayIf #-} +{-# language UndecidableInstances #-} +{-# language CPP #-} +{-# language ConstraintKinds #-} +{-# language DefaultSignatures #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language MultiWayIf #-} module Nix.Render where -import Prelude hiding ( readFile ) - -import qualified Data.ByteString as BS +import Nix.Prelude import qualified Data.Set as Set import Nix.Utils.Fix1 ( Fix1T - , MonadFix1T ) + , MonadFix1T + ) +import Nix.Expr.Types ( NPos(..) + , NSourcePos(..) + ) import Nix.Expr.Types.Annotated import Prettyprinter import qualified System.Directory as S -import qualified System.Posix.Files as S +import qualified System.PosixCompat.Files as S import Text.Megaparsec.Error import Text.Megaparsec.Pos +import qualified Data.Text as Text -class MonadFail m => MonadFile m where - readFile :: FilePath -> m ByteString - default readFile :: (MonadTrans t, MonadFile m', m ~ t m') => FilePath -> m ByteString - readFile = lift . readFile - listDirectory :: FilePath -> m [FilePath] - default listDirectory :: (MonadTrans t, MonadFile m', m ~ t m') => FilePath -> m [FilePath] +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 . Nix.Prelude.readFile + listDirectory :: Path -> m [Path] + default listDirectory :: (MonadTrans t, MonadFile m', m ~ t m') => Path -> m [Path] listDirectory = lift . listDirectory - getCurrentDirectory :: m FilePath - default getCurrentDirectory :: (MonadTrans t, MonadFile m', m ~ t m') => m FilePath + getCurrentDirectory :: m Path + default getCurrentDirectory :: (MonadTrans t, MonadFile m', m ~ t m') => m Path getCurrentDirectory = lift getCurrentDirectory - canonicalizePath :: FilePath -> m FilePath - default canonicalizePath :: (MonadTrans t, MonadFile m', m ~ t m') => FilePath -> m FilePath + canonicalizePath :: Path -> m Path + default canonicalizePath :: (MonadTrans t, MonadFile m', m ~ t m') => Path -> m Path canonicalizePath = lift . canonicalizePath - getHomeDirectory :: m FilePath - default getHomeDirectory :: (MonadTrans t, MonadFile m', m ~ t m') => m FilePath + getHomeDirectory :: m Path + default getHomeDirectory :: (MonadTrans t, MonadFile m', m ~ t m') => m Path getHomeDirectory = lift getHomeDirectory - doesPathExist :: FilePath -> m Bool - default doesPathExist :: (MonadTrans t, MonadFile m', m ~ t m') => FilePath -> m Bool + doesPathExist :: Path -> m Bool + default doesPathExist :: (MonadTrans t, MonadFile m', m ~ t m') => Path -> m Bool doesPathExist = lift . doesPathExist - doesFileExist :: FilePath -> m Bool - default doesFileExist :: (MonadTrans t, MonadFile m', m ~ t m') => FilePath -> m Bool + doesFileExist :: Path -> m Bool + default doesFileExist :: (MonadTrans t, MonadFile m', m ~ t m') => Path -> m Bool doesFileExist = lift . doesFileExist - doesDirectoryExist :: FilePath -> m Bool - default doesDirectoryExist :: (MonadTrans t, MonadFile m', m ~ t m') => FilePath -> m Bool + doesDirectoryExist :: Path -> m Bool + default doesDirectoryExist :: (MonadTrans t, MonadFile m', m ~ t m') => Path -> m Bool doesDirectoryExist = lift . doesDirectoryExist - getSymbolicLinkStatus :: FilePath -> m S.FileStatus - default getSymbolicLinkStatus :: (MonadTrans t, MonadFile m', m ~ t m') => FilePath -> m S.FileStatus + getSymbolicLinkStatus :: Path -> m S.FileStatus + default getSymbolicLinkStatus :: (MonadTrans t, MonadFile m', m ~ t m') => Path -> m S.FileStatus getSymbolicLinkStatus = lift . getSymbolicLinkStatus instance MonadFile IO where - readFile = BS.readFile - listDirectory = S.listDirectory - getCurrentDirectory = S.getCurrentDirectory - canonicalizePath = S.canonicalizePath - getHomeDirectory = S.getHomeDirectory - doesPathExist = S.doesPathExist - doesFileExist = S.doesFileExist - doesDirectoryExist = S.doesDirectoryExist - getSymbolicLinkStatus = S.getSymbolicLinkStatus + readFile = Nix.Prelude.readFile + listDirectory = coerce S.listDirectory + getCurrentDirectory = coerce S.getCurrentDirectory + canonicalizePath = coerce S.canonicalizePath + getHomeDirectory = coerce S.getHomeDirectory + doesPathExist = coerce S.doesPathExist + doesFileExist = coerce S.doesFileExist + doesDirectoryExist = coerce S.doesDirectoryExist + getSymbolicLinkStatus = coerce S.getSymbolicLinkStatus -instance (MonadFix1T t m, MonadFail (Fix1T t m), MonadFile m) => MonadFile (Fix1T t m) +instance (MonadFix1T t m, MonadIO (Fix1T t m), MonadFail (Fix1T t m), MonadFile m) => MonadFile (Fix1T t m) -posAndMsg :: SourcePos -> Doc a -> ParseError s Void -posAndMsg (SourcePos _ lineNo _) msg = +posAndMsg :: NSourcePos -> Doc a -> ParseError s Void +posAndMsg (NSourcePos _ (coerce -> lineNo) _) msg = FancyError (unPos lineNo) - (Set.fromList [ErrorFail (show msg) :: ErrorFancy Void]) + (Set.fromList $ one (ErrorFail (show msg) :: ErrorFancy Void)) renderLocation :: MonadFile m => SrcSpan -> Doc a -> m (Doc a) -renderLocation (SrcSpan (SourcePos file begLine begCol) (SourcePos file' endLine endCol)) msg - | file == file' && file == "" && begLine == endLine - = pure $ "In raw input string at position " <> pretty (unPos begCol) +renderLocation (SrcSpan (NSourcePos file (coerce -> begLine) (coerce -> begCol)) (NSourcePos file' (coerce -> endLine) (coerce -> endCol))) msg + | file == file' && file == "" && begLine == endLine = + pure $ "In raw input string at position " <> pretty (unPos begCol) - | file /= "" && file == file' - = do - exist <- doesFileExist file - if exist - then do + | file /= "" && file == file' = + bool + (pure msg) + (do txt <- sourceContext file begLine begCol endLine endCol msg pure $ vsep [ "In file " <> errorContext file begLine begCol endLine endCol <> ":" , txt ] - else pure msg + ) + =<< doesFileExist file renderLocation (SrcSpan beg end) msg = fail $ "Don't know how to render range from " <> show beg <>" to " <> show end <>" for fail: " <> show msg -errorContext :: FilePath -> Pos -> Pos -> Pos -> Pos -> Doc a -errorContext path bl bc _el _ec = +errorContext :: Path -> Pos -> Pos -> Pos -> Pos -> Doc a +errorContext (coerce @Path @FilePath -> path) bl bc _el _ec = pretty path <> ":" <> pretty (unPos bl) <> ":" <> pretty (unPos bc) sourceContext - :: MonadFile m => FilePath -> Pos -> Pos -> Pos -> Pos -> Doc a -> m (Doc a) + :: MonadFile m => Path -> Pos -> Pos -> Pos -> Pos -> Doc a -> m (Doc a) sourceContext path (unPos -> begLine) (unPos -> _begCol) (unPos -> endLine) (unPos -> _endCol) msg = do let beg' = max 1 $ begLine - 3 @@ -107,31 +107,35 @@ . take (end' - beg') . drop (pred beg') . lines - . decodeUtf8 - <$> readFile path + <$> Nix.Render.readFile path let - longest = length $ show @String (beg' + (length ls) - 1) + longest = Text.length $ show $ beg' + length ls - 1 + pad :: Int -> Text pad n = let + ns :: Text ns = show n - nsp = replicate (longest - length ns) ' ' <> ns + nsp = Text.replicate (longest - Text.length ns) " " <> ns in if | n == begLine && n == endLine -> "==> " <> nsp <> " | " | n >= begLine && n <= endLine -> " > " <> nsp <> " | " | otherwise -> " " <> nsp <> " | " composeLine n l = - [pretty (pad n) <> l] - ++ [ pretty - $ replicate (length (pad n) - 3) ' ' - <> "| " - <> replicate (_begCol - 1) ' ' - <> replicate (_endCol - _begCol) '^' - | begLine == endLine && n == endLine ] + one (pretty (pad n) <> l) + <> whenTrue + (one $ + pretty $ + Text.replicate (Text.length (pad n) - 3) " " + <> "|" + <> Text.replicate (_begCol + 1) " " + <> Text.replicate (_endCol - _begCol) "^" + ) + (begLine == endLine && n == endLine) -- XXX: Consider inserting the message here when it is small enough. -- ATM some messages are so huge that they take prevalence over the source listing. -- ++ [ indent (length $ pad n) msg | n == endLine ] - ls' = concat $ zipWith composeLine [beg' ..] ls + ls' = fold $ zipWith composeLine [beg' ..] ls - pure $ vsep $ ls' ++ [ indent (length $ pad begLine) msg ] + pure $ vsep $ ls' <> one (indent (Text.length $ pad begLine) msg) 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 @@ -1,21 +1,20 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} +{-# language CPP #-} +{-# language AllowAmbiguousTypes #-} +{-# language ConstraintKinds #-} +{-# language MultiWayIf #-} +{-# language TypeFamilies #-} -- | Code for rendering/representation of the messages packaged with their context (Frames). module Nix.Render.Frame where -import Prelude hiding ( Comparison ) -import Nix.Utils +import Nix.Prelude hiding ( Comparison ) +import GHC.Exception ( ErrorCall ) import Data.Fix ( Fix(..) ) -import Nix.Eval +import Nix.Eval hiding ( addMetaInfo ) import Nix.Exec -import Nix.Expr +import Nix.Expr.Types +import Nix.Expr.Types.Annotated import Nix.Frames import Nix.Normal import Nix.Options @@ -39,37 +38,43 @@ => Frames -> m (Doc ann) renderFrames [] = stub -renderFrames (x : xs) = do - opts :: Options <- asks (view hasLens) - frames <- if - | verbose opts <= ErrorsOnly -> renderFrame @v @t @f x - | verbose opts <= Informational -> do - f <- renderFrame @v @t @f x - pure $ concatMap go (reverse xs) <> f - | otherwise -> concat <$> traverse (renderFrame @v @t @f) (reverse (x : xs)) - pure $ - list - mempty - vsep - frames +renderFrames xss@(x : xs) = + do + opts <- askOptions + let + verbosity :: Verbosity + 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 + | verbosity <= Informational -> (foldMap renderPosition (reverse xs) <>) <$> render1 x + | otherwise -> foldMapM render1 (reverse xss) + pure $ + handlePresence + mempty + vsep + renderedFrames where - go :: NixFrame -> [Doc ann] - go f = - maybe - mempty - (\ pos -> ["While evaluating at " <> pretty (sourcePosPretty pos) <> colon]) - (framePos @v @m f) + render1 :: NixFrame -> m [Doc ann1] + render1 = renderFrame @v @t @f + renderPosition :: NixFrame -> [Doc ann] + renderPosition = + whenJust + (\ pos -> one ("While evaluating at " <> pretty (sourcePosPretty $ toSourcePos pos) <> colon)) + . framePos @v @m + framePos :: forall v (m :: Type -> Type) . (Typeable m, Typeable v) => NixFrame - -> Maybe SourcePos -framePos (NixFrame _ f) - | Just (e :: EvalFrame m v) <- fromException f = case e of - EvaluatingExpr _ (AnnE (SrcSpan beg _) _) -> pure beg + -> Maybe NSourcePos +framePos (NixFrame _ f) = + (\case + EvaluatingExpr _ (Ann (SrcSpan beg _) _) -> pure beg _ -> Nothing - | otherwise = Nothing + ) + =<< fromException @(EvalFrame m v) f renderFrame :: forall v t f e m ann @@ -87,55 +92,57 @@ | Just (e :: ValueFrame t f m ) <- fromException f = renderValueFrame level e | Just (e :: NormalLoop t f m ) <- fromException f = renderNormalLoop level e | Just (e :: ExecFrame t f m ) <- fromException f = renderExecFrame level e - | Just (e :: ErrorCall ) <- fromException f = pure [pretty (Text.show e)] - | Just (e :: SynHoleInfo m v) <- fromException f = pure [pretty (Text.show e)] + | Just (e :: ErrorCall ) <- fromException f = pure $ one $ pretty (Text.show e) + | Just (e :: SynHoleInfo m v) <- fromException f = pure $ one $ pretty (Text.show e) | otherwise = fail $ "Unrecognized frame: " <> show f wrapExpr :: NExprF r -> NExpr wrapExpr x = Fix (Fix (NSym "") <$ x) renderEvalFrame - :: (MonadReader e m, Has e Options, MonadFile m) + :: forall e m v ann + . (MonadReader e m, Has e Options, MonadFile m) => NixLevel -> EvalFrame m v -> 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 + case f of - EvaluatingExpr scope e@(AnnE ann _) -> - do - let - scopeInfo = - bool - mempty - [pretty $ Text.show scope] - (showScopes opts) - fmap - (\x -> scopeInfo <> [x]) - $ renderLocation ann =<< - renderExpr level "While evaluating" "Expression" e + EvaluatingExpr scope e@(Ann loc _) -> + addMetaInfo + (scopeInfo <>) + loc + =<< renderExpr level "While evaluating" "Expression" e + where + scopeInfo :: [Doc ann] + scopeInfo = + one (pretty $ Text.show scope) `whenTrue` isShowScopes opts - ForcingExpr _scope e@(AnnE ann _) | thunks opts -> - fmap - (: mempty) - $ renderLocation ann =<< - renderExpr level "While forcing thunk from" "Forcing thunk" e + ForcingExpr _scope e@(Ann loc _) | isThunks opts -> + addMetaInfo + id + loc + =<< renderExpr level "While forcing thunk from" "Forcing thunk" e - Calling name ann -> - fmap - (: mempty) - $ renderLocation ann $ - "While calling builtins." <> pretty name + Calling name loc -> + addMetaInfo + id + loc + $ "While calling `builtins." <> prettyVarName name <> "`" SynHole synfo -> - sequence $ - let e@(AnnE ann _) = _synHoleInfo_expr synfo in - - [ renderLocation ann =<< + sequenceA + [ renderLocation loc =<< renderExpr level "While evaluating" "Syntactic Hole" e , pure $ pretty $ Text.show $ _synHoleInfo_scope synfo ] + where + e@(Ann loc _) = _synHoleInfo_expr synfo ForcingExpr _ _ -> stub @@ -147,26 +154,37 @@ -> Text -> NExprLoc -> m (Doc ann) -renderExpr _level longLabel shortLabel e@(AnnE _ x) = do - opts :: Options <- asks (view hasLens) - let rendered - | verbose opts >= DebugInfo = - pretty (PS.ppShow (stripAnnotation e)) - | verbose opts >= Chatty = prettyNix (stripAnnotation e) - | otherwise = prettyNix (Fix (Fix (NSym "") <$ x)) - pure $ - bool - (pretty shortLabel <> fillSep [": ", rendered]) - (vsep [pretty (longLabel <> ":\n>>>>>>>>"), indent 2 rendered, "<<<<<<<<"]) - (verbose opts >= Chatty) +renderExpr _level longLabel shortLabel e@(Ann _ x) = + do + opts <- askOptions + let + verbosity :: Verbosity + verbosity = getVerbosity opts + expr :: NExpr + expr = stripAnnotation e + + concise = prettyNix $ Fix $ Fix (NSym "") <$ x + + chatty = + bool + (pretty $ PS.ppShow expr) + (prettyNix expr) + (verbosity == Chatty) + + pure $ + bool + (pretty shortLabel <> fillSep [": ", concise]) + (vsep [pretty (longLabel <> ":\n>>>>>>>>"), indent 2 chatty, "<<<<<<<<"]) + (verbosity >= Chatty) + renderValueFrame :: forall e t f m ann . (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m) => NixLevel -> ValueFrame t f m -> m [Doc ann] -renderValueFrame level = fmap (: mempty) . \case +renderValueFrame level = fmap one . \case ForcingThunk _t -> pure "ForcingThunk" -- jww (2019-03-18): NYI ConcerningValue _v -> pure "ConcerningValue" Comparison _ _ -> pure "Comparing" @@ -175,22 +193,23 @@ Multiplication _ _ -> pure "Multiplying" Coercion x y -> pure - $ mconcat [desc, pretty (describeValue x), " to ", pretty (describeValue y)] + $ fold [desc, pretty (describeValue x), " to ", pretty (describeValue y)] where desc = bool - "While coercing " - "Cannot coerce " - (level <= Error) + "While coercing " + "Cannot coerce " + (level <= Error) CoercionToJson v -> - ("CoercionToJson " <>) <$> renderValue level "" "" v + ("CoercionToJson " <>) <$> dumbRenderValue v CoercionFromJson _j -> pure "CoercionFromJson" Expectation t v -> - (msg <>) <$> renderValue @_ @t @f @m level "" "" v + (msg <>) <$> dumbRenderValue v where msg = "Expected " <> pretty (describeValue t) <> ", but saw " +-- 2021-10-28: NOTE: notice it ignores `level`, `longlabel` & `shortlabel`, to underline that `dumbRenderValue` synonym was created renderValue :: forall e t f m ann . (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m) @@ -199,45 +218,43 @@ -> 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 + . (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m) + => (NValue t f m -> m (Doc ann)) +dumbRenderValue = renderValue Info mempty mempty + renderExecFrame :: (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m) => NixLevel -> ExecFrame t f m -> m [Doc ann] -renderExecFrame level = - \case - Assertion ann v -> - fmap - (: mempty) - (do - d <- renderValue level "" "" v - renderLocation ann $ fillSep ["Assertion failed:", d] - ) +renderExecFrame _level (Assertion ann v) = + fmap + one + $ renderLocation ann . fillSep . on (<>) one "Assertion failed:" =<< dumbRenderValue v renderThunkLoop :: (MonadReader e m, Has e Options, MonadFile m, Show (ThunkId m)) => NixLevel -> ThunkLoop -> m [Doc ann] -renderThunkLoop _level = pure . (: mempty) . \case - ThunkLoop n -> pretty $ "Infinite recursion in thunk " <> n +renderThunkLoop _level (ThunkLoop n) = + pure . one . pretty $ "Infinite recursion in thunk " <> n renderNormalLoop :: (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m) => NixLevel -> NormalLoop t f m -> m [Doc ann] -renderNormalLoop level = - fmap - (: mempty) - . \case - NormalLoop v -> - ("Infinite recursion during normalization forcing " <>) <$> renderValue level "" "" v +renderNormalLoop _level (NormalLoop v) = + one . ("Infinite recursion during normalization forcing " <>) <$> dumbRenderValue v diff --git a/src/Nix/Scope.hs b/src/Nix/Scope.hs --- a/src/Nix/Scope.hs +++ b/src/Nix/Scope.hs @@ -1,33 +1,39 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# language UndecidableInstances #-} +{-# language AllowAmbiguousTypes #-} +{-# language ConstraintKinds #-} +{-# language FunctionalDependencies #-} +{-# language GeneralizedNewtypeDeriving #-} module Nix.Scope where +import Nix.Prelude import qualified Data.HashMap.Lazy as M import qualified Text.Show import Lens.Family2 -import Nix.Utils +import Nix.Expr.Types -newtype Scope a = Scope { getScope :: AttrSet a } - deriving (Functor, Foldable, Traversable, Eq) +-- 2021-07-19: NOTE: Scopes can gain from sequentiality, HashMap (aka AttrSet) may not be proper to it. +newtype Scope a = Scope (AttrSet a) + deriving + ( Eq, Ord, Generic + , Typeable, NFData + , Read, Hashable + , Semigroup, Monoid + , Functor, Foldable, Traversable + , One + ) instance Show (Scope a) where show (Scope m) = show $ M.keys m -newScope :: AttrSet a -> Scope a -newScope = Scope - -scopeLookup :: Text -> [Scope a] -> Maybe a -scopeLookup key = foldr go Nothing +scopeLookup :: VarName -> [Scope a] -> Maybe a +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 @@ -45,22 +51,22 @@ instance Monoid (Scopes m a) where mempty = emptyScopes -emptyScopes :: forall m a . Scopes m a +emptyScopes :: Scopes m a 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 :: Text -> m (Maybe a) + 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 @@ -73,19 +79,19 @@ pushScope :: Scoped a m - => AttrSet a + => Scope a -> m r -> m r -pushScope s = pushScopes $ Scopes [Scope s] mempty +pushScope scope = pushScopes $ Scopes (one scope) mempty pushWeakScope :: ( Functor m , Scoped a m ) - => m (AttrSet a) + => m (Scope a) -> m r -> m r -pushWeakScope s = pushScopes $ Scopes mempty [Scope <$> s] +pushWeakScope scope = pushScopes $ Scopes mempty $ one scope pushScopesReader :: ( MonadReader e m @@ -101,7 +107,7 @@ . ( MonadReader e m , Has e (Scopes m a) ) - => Text + => VarName -> m (Maybe a) lookupVarReader k = do @@ -112,9 +118,9 @@ ws <- asks $ dynamicScopes . view hasLens foldr - (\ x rest -> + (\ weakscope rest -> do - mres' <- M.lookup k . getScope <$> x + mres' <- M.lookup k . coerce @(Scope a) <$> weakscope maybe rest @@ -132,4 +138,4 @@ => Scopes m a -> m r -> m r -withScopes scope = clearScopes . pushScopes scope +withScopes scopes = clearScopes . pushScopes scopes diff --git a/src/Nix/Standard.hs b/src/Nix/Standard.hs --- a/src/Nix/Standard.hs +++ b/src/Nix/Standard.hs @@ -1,15 +1,14 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE UndecidableInstances #-} +{-# language TypeFamilies #-} +{-# language CPP #-} +{-# language GeneralizedNewtypeDeriving #-} +{-# language UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} +{-# options_ghc -Wno-orphans #-} module Nix.Standard where -import Prelude hiding ( force ) +import Nix.Prelude import Control.Comonad ( Comonad ) import Control.Comonad.Env ( ComonadEnv ) import Control.Monad.Catch ( MonadThrow @@ -19,8 +18,8 @@ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) #endif -import Control.Monad.Free ( Free(Pure, Free) ) -import Control.Monad.Reader ( MonadFix ) +import Control.Monad.Free ( Free(Free) ) +import Control.Monad.Fix ( MonadFix ) import Control.Monad.Ref ( MonadRef(newRef) , MonadAtomicRef ) @@ -39,7 +38,6 @@ import Nix.Scope import Nix.Thunk import Nix.Thunk.Basic -import Nix.Utils ( free ) import Nix.Utils.Fix1 ( Fix1T(Fix1T) ) import Nix.Value import Nix.Value.Monad @@ -47,25 +45,28 @@ newtype StdCited m a = StdCited - { _stdCited :: Cited (StdThunk m) (StdCited m) m a } + (Cited (StdThunk m) (StdCited m) m a) deriving - ( Generic - , Typeable - , Functor - , Applicative - , Foldable - , Traversable - , Comonad - , ComonadEnv [Provenance m (StdValue m)] + ( Generic, Typeable + , Functor, Applicative, Comonad, ComonadEnv [Provenance m (StdValue m)] + , Foldable, Traversable ) -newtype StdThunk (m :: Type -> Type) = +newtype StdThunk m = StdThunk - { _stdThunk :: StdCited m (NThunkF m (StdValue m)) } - + (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: +-- +-- > Cited (StdThunk m) (StdCited m) m (NThunkF m (StdValue m)) +type CitedStdThunk m = Cited (StdThunk m) (StdCited m) m (NThunkF m (StdValue m)) + instance Show (StdThunk m) where show _ = toString thunkStubText @@ -78,10 +79,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 @@ -100,13 +101,13 @@ , Typeable m , Scoped (StdValue m) m , MonadReader (Context m (StdValue m)) m - , MonadState (HashMap FilePath NExprLoc, HashMap Text Text) m + , MonadState (HashMap Path NExprLoc, HashMap Text Text) m , MonadDataErrorContext (StdThunk m) (StdCited m) m , MonadThunk (StdThunk m) m (StdValue m) , MonadValue (StdValue m) m ) => MonadEffects (StdThunk m) (StdCited m) m where - makeAbsolutePath = defaultMakeAbsolutePath + toAbsolutePath = defaultToAbsolutePath findEnvPath = defaultFindEnvPath findPath = defaultFindPath importPath = defaultImportPath @@ -114,6 +115,10 @@ derivationStrict = defaultDerivationStrict traceEffect = defaultTraceEffect +-- 2021-07-24: +-- This instance currently is to satisfy @MonadThunk@ requirements for @normalForm@ function. +-- As it is seen from the instance - it does superficial type class jump. +-- It is just a type boundary for thunking. instance ( Typeable m , MonadThunkId m @@ -126,38 +131,45 @@ thunkId :: StdThunk m -> ThunkId m - thunkId = thunkId . _stdCited . _stdThunk + thunkId = thunkId @(CitedStdThunk m) . coerce {-# inline thunkId #-} thunk :: m (StdValue m) -> m (StdThunk m) - thunk = fmap (StdThunk . StdCited) . thunk + thunk = fmap coerce . thunk @(CitedStdThunk m) + {-# inline thunk #-} query :: m (StdValue m) -> StdThunk m -> m (StdValue m) - query b = query b . _stdCited . _stdThunk + query b = query @(CitedStdThunk m) b . coerce + {-# inline query #-} force :: StdThunk m -> m (StdValue m) - force = force . _stdCited . _stdThunk + force = force @(CitedStdThunk m) . coerce + {-# inline force #-} forceEff :: StdThunk m -> m (StdValue m) - forceEff = forceEff . _stdCited . _stdThunk + forceEff = forceEff @(CitedStdThunk m) . coerce + {-# inline forceEff #-} further :: StdThunk m -> m (StdThunk m) - further = fmap (StdThunk . StdCited) . further . _stdCited . _stdThunk + further = fmap coerce . further @(CitedStdThunk m) . coerce + {-# inline further #-} -- * @instance MonadThunkF@ (Kleisli functor HOFs) +-- | This is a functorized version in CPS. + -- Please do not use MonadThunkF instances to define MonadThunk. as MonadThunk uses specialized functions. instance ( Typeable m @@ -175,7 +187,7 @@ -> m r -> StdThunk m -> m r - queryF k b = queryF k b . _stdCited . _stdThunk + queryF k b = queryF @(CitedStdThunk m) k b . coerce forceF :: ( StdValue m @@ -183,7 +195,7 @@ ) -> StdThunk m -> m r - forceF k = forceF k . _stdCited . _stdThunk + forceF k = forceF @(CitedStdThunk m) k . coerce forceEffF :: ( StdValue m @@ -191,7 +203,7 @@ ) -> StdThunk m -> m r - forceEffF k = forceEffF k . _stdCited . _stdThunk + forceEffF k = forceEffF @(CitedStdThunk m) k . coerce furtherF :: ( m (StdValue m) @@ -199,7 +211,7 @@ ) -> StdThunk m -> m (StdThunk m) - furtherF k = fmap (StdThunk . StdCited) . furtherF k . _stdCited . _stdThunk + furtherF k = fmap coerce . furtherF @(CitedStdThunk m) k . coerce -- * @instance MonadValue (StdValue m) m@ @@ -216,22 +228,29 @@ defer :: m (StdValue m) -> m (StdValue m) - defer = fmap pure . thunk + defer = fmap (pure . coerce) . thunk @(CitedStdThunk m) demand :: StdValue m -> m (StdValue m) - demand v = - free - (demand <=< force) - (const $ pure v) - v + demand = go -- lock to ensure no type class jumps. + where + go :: StdValue m -> m (StdValue m) + go = + free + (go <=< force @(CitedStdThunk m) . coerce) + (pure . Free) inform :: StdValue m -> m (StdValue m) - inform (Pure t) = Pure <$> further t - inform (Free v) = Free <$> bindNValue' id inform v + inform = go -- lock to ensure no type class jumps. + where + go :: StdValue m -> m (StdValue m) + go = + free + ((pure . coerce <$>) . (further @(CitedStdThunk m) . coerce)) + ((Free <$>) . bindNValue' id go) -- * @instance MonadValueF (StdValue m) m@ @@ -271,8 +290,12 @@ -- withFrame Debug (ForcingThunk @t @f @m) . withFrame Debug frame newtype StandardTF r m a - = StandardTF (ReaderT (Context r (StdValue r)) - (StateT (HashMap FilePath NExprLoc, HashMap Text Text) m) a) + = StandardTF + (ReaderT + (Context r (StdValue r)) + (StateT (HashMap Path NExprLoc, HashMap Text Text) m) + a + ) deriving ( Functor , Applicative @@ -286,7 +309,7 @@ , MonadThrow , MonadMask , MonadReader (Context r (StdValue r)) - , MonadState (HashMap FilePath NExprLoc, HashMap Text Text) + , MonadState (HashMap Path NExprLoc, HashMap Text Text) ) instance MonadTrans (StandardTF r) where @@ -314,27 +337,28 @@ instance MonadTrans (Fix1T StandardTF) where lift = Fix1T . lift + {-# inline lift #-} instance MonadThunkId m - => MonadThunkId (Fix1T StandardTF m) where + => MonadThunkId (StandardT m) where - type ThunkId (Fix1T StandardTF m) = ThunkId m + type ThunkId (StandardT m) = ThunkId m mkStandardT :: ReaderT (Context (StandardT m) (StdValue (StandardT m))) - (StateT (HashMap FilePath NExprLoc, HashMap Text Text) m) + (StateT (HashMap Path NExprLoc, HashMap Text Text) m) a -> StandardT m a -mkStandardT = Fix1T . StandardTF +mkStandardT = coerce runStandardT :: StandardT m a -> ReaderT (Context (StandardT m) (StdValue (StandardT m))) - (StateT (HashMap FilePath NExprLoc, HashMap Text Text) m) + (StateT (HashMap Path NExprLoc, HashMap Text Text) m) a -runStandardT (Fix1T (StandardTF m)) = m +runStandardT = coerce runWithBasicEffects :: (MonadIO m, MonadAtomicRef m) @@ -342,11 +366,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 @@ -1,21 +1,21 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# language GeneralizedNewtypeDeriving #-} module Nix.String ( NixString - , getContext - , makeNixString + , getStringContext + , mkNixString , StringContext(..) , ContextFlavor(..) , NixLikeContext(..) , NixLikeContextValue(..) , toNixLikeContext , fromNixLikeContext - , stringHasContext + , hasContext , intercalateNixString , getStringNoContext - , stringIgnoreContext - , makeNixStringWithoutContext - , makeNixStringWithSingletonContext + , ignoreContext + , mkNixStringWithoutContext + , mkNixStringWithSingletonContext , modifyNixContents , WithStringContext , WithStringContextT(..) @@ -32,11 +32,14 @@ -import Nix.Utils +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 import qualified Data.Text as Text +import Nix.Expr.Types ( VarName(..) + , AttrSet + ) -- * Types @@ -46,8 +49,8 @@ -- | A Nix 'StringContext' ... data StringContext = StringContext - { scPath :: !Text - , scFlavor :: !ContextFlavor + { getStringContextFlavor :: !ContextFlavor + , getStringContextPath :: !VarName } deriving (Eq, Ord, Show, Generic) @@ -103,8 +106,8 @@ data NixString = NixString - { nsContents :: !Text - , nsContext :: !(S.HashSet StringContext) + { getStringContext :: !(S.HashSet StringContext) + , getStringContent :: !Text } deriving (Eq, Ord, Show, Generic) @@ -122,48 +125,46 @@ -- ** Makers -- | Constructs NixString without a context -makeNixStringWithoutContext :: Text -> NixString -makeNixStringWithoutContext = (`NixString` mempty) +mkNixStringWithoutContext :: Text -> NixString +mkNixStringWithoutContext = NixString mempty -- | Create NixString using a singleton context -makeNixStringWithSingletonContext - :: Text -> StringContext -> NixString -makeNixStringWithSingletonContext s c = NixString s $ one c +mkNixStringWithSingletonContext + :: StringContext -> VarName -> NixString +mkNixStringWithSingletonContext c s = NixString (one c) (coerce @VarName @Text s) -- | Create NixString from a Text and context -makeNixString :: Text -> S.HashSet StringContext -> NixString -makeNixString = 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 _) = isPresent 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 @@ -172,44 +173,46 @@ -- this really should be 2 args, then with @toStringContexts path@ laziness it would tail recurse. -- for now tuple dissected internaly with laziness preservation. -toStringContexts :: (Text, 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 _ _ -> mkLstCtxFor DirectPath cv { nlcvPath = False } NixLikeContextValue _ True _ -> mkLstCtxFor AllOutputs cv { nlcvAllOutputs = False } - NixLikeContextValue _ _ ls | not (null ls) -> + NixLikeContextValue _ _ ls | isPresent ls -> 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 -> (Text, 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 [t] + 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 = + uncurry (M.insertWith (<>)) (swap $ toNixLikeContextValue sc) -- | Add 'StringContext's into the resulting set. addStringContext @@ -223,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 @@ -234,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. @@ -251,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 @@ -1,10 +1,13 @@ -{-# LANGUAGE CPP #-} +{-# language CPP #-} 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 @@ -17,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) @@ -31,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 @@ -43,78 +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 $ - bool - "" - "1" - 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 "" - -- NVConstant: NAtom (NURI Text) is not matched + castToNixString mempty NVList l -> - nixStringUnwords <$> traverse (go <=< demand) l - v -> coerceStringy v - - coerceStringy x' = - case x' of - NVStr ns -> pure ns - NVPath p -> - bool - (castToNixString . toText) - (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) + nixStringUnwords <$> traverse go l + v@(NVSet _ 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 . makeNixStringWithoutContext + nixStringUnwords = intercalateNixString $ mkNixStringWithoutContext " " - nixStringUnwords = intercalateNixString $ makeNixStringWithoutContext " " + coerceStringlike :: NValue t f m -> m NixString + coerceStringlike = coerceStringlikeToNixString ctsm - storePathToNixString :: StorePath -> NixString - storePathToNixString sp = - makeNixStringWithSingletonContext - t - (StringContext t DirectPath) - where - t = toText $ unStorePath 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 @@ -1,139 +1,97 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} - {-# OPTIONS_GHC -Wno-missing-fields #-} +{-# OPTIONS_GHC -Wno-type-defaults #-} module Nix.TH where -import Data.Fix ( Fix(..) ) +import Data.Fix ( Fix(Fix) ) import Data.Generics.Aliases ( extQ ) import qualified Data.Set as Set import Language.Haskell.TH -import qualified Language.Haskell.TH.Syntax as TH import Language.Haskell.TH.Quote import Nix.Atoms -import Nix.Expr +import Nix.Expr.Types +import Nix.Expr.Types.Annotated import Nix.Parser +import Nix.Prelude +removeMissingNames :: Set VarName -> Q (Set VarName) +removeMissingNames = + fmap Set.fromAscList + . filterM (fmap isJust . lookupValueName . toString) + . Set.toAscList + quoteExprExp :: String -> ExpQ quoteExprExp s = do - expr <- - either - (fail . show) - pure - (parseNixText $ toText s) - dataToExpQ - (const Nothing `extQ` metaExp (freeVars expr) `extQ` (pure . (TH.lift :: Text -> Q Exp))) - expr + expr <- parseExpr $ fromString s + vars <- removeMissingNames $ getFreeVars expr + dataToExpQ (extQOnFreeVars metaExp vars) expr quoteExprPat :: String -> PatQ quoteExprPat s = do - expr <- - either - (fail . show) - pure - (parseNixText $ toText s) - dataToPatQ - (const Nothing `extQ` metaPat (freeVars expr)) - expr + expr <- parseExpr @Q $ fromString s + vars <- removeMissingNames $ getFreeVars expr + dataToPatQ (extQOnFreeVars @_ @NExprLoc @PatQ metaPat vars) expr -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 NNonRecursive bindings) -> bindFreeVars bindings - (NSet NRecursive bindings) -> Set.difference (bindFreeVars bindings) (bindDefs bindings) - (NLiteralPath _ ) -> mempty - (NEnvPath _ ) -> mempty - (NUnary _ expr ) -> freeVars expr - (NBinary _ left right ) -> ((<>) `on` freeVars) left right - (NSelect expr path orExpr) -> - Set.unions - [ freeVars expr - , pathFree path - , maybe mempty freeVars orExpr - ] - (NHasAttr expr path) -> freeVars expr <> pathFree path - (NAbs (Param varname) expr) -> Set.delete varname (freeVars expr) - (NAbs (ParamSet set _ varname) 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 set) - (Set.difference - (maybe mempty one varname) - (Set.fromList $ fst <$> set) - ) - (NLet bindings expr ) -> - freeVars expr <> - Set.difference - (bindFreeVars bindings) - (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 ) -> ((<>) `on` freeVars) set expr - (NAssert assertion expr ) -> ((<>) `on` freeVars) assertion expr - (NSynHole _ ) -> mempty +-- | Helper function. +extQOnFreeVars + :: (Typeable b, Typeable loc) + => (Set VarName -> loc -> Maybe q) + -> Set VarName + -> b + -> Maybe q +extQOnFreeVars f = extQ (const Nothing) . f - where +class ToExpr a where + toExpr :: a -> NExpr - 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 $ mapMaybe staticKey keys - bind1Def (NamedVar (StaticKey varname :| _) _ _) = one varname - bind1Def (NamedVar (DynamicKey _ :| _) _ _) = mempty +instance ToExpr NExpr where + toExpr = id - bindFreeVars :: Foldable t => t (Binding NExpr) -> Set VarName - bindFreeVars = foldMap bind1Free - where - bind1Free :: Binding NExpr -> Set VarName - bind1Free (Inherit Nothing keys _) = Set.fromList $ mapMaybe staticKey keys - bind1Free (Inherit (Just scope) _ _) = freeVars scope - bind1Free (NamedVar path expr _) = pathFree path <> freeVars expr +instance ToExpr VarName where + toExpr = Fix . NSym - staticKey :: NKeyName r -> Maybe VarName - staticKey (StaticKey varname) = pure varname - staticKey (DynamicKey _ ) = mempty +instance {-# OVERLAPPING #-} ToExpr String where + toExpr = Fix . NStr . fromString - pathFree :: NAttrPath NExpr -> Set VarName - pathFree = foldMap mapFreeVars +instance ToExpr Text where + toExpr = toExpr . toString - mapFreeVars :: Foldable t => t NExpr -> Set VarName - mapFreeVars = foldMap freeVars +instance ToExpr Int where + toExpr = Fix . NConstant . NInt . fromIntegral +instance ToExpr Bool where + toExpr = Fix . NConstant . NBool -class ToExpr a where - toExpr :: a -> NExprLoc +instance ToExpr Integer where + toExpr = Fix . NConstant . NInt -instance ToExpr NExprLoc where - toExpr = id +instance ToExpr Float where + toExpr = Fix . NConstant . NFloat -instance ToExpr VarName where - toExpr = Fix . NSym_ nullSpan +instance (ToExpr a) => ToExpr [a] where + toExpr = Fix . NList . fmap toExpr -instance ToExpr Int where - toExpr = Fix . NConstant_ nullSpan . NInt . fromIntegral +instance (ToExpr a) => ToExpr (NonEmpty a) where + toExpr = toExpr . toList -instance ToExpr Integer where - toExpr = Fix . NConstant_ nullSpan . NInt +instance ToExpr () where + toExpr () = Fix $ NConstant NNull -instance ToExpr Float where - toExpr = Fix . NConstant_ nullSpan . NFloat +instance (ToExpr a) => ToExpr (Maybe a) where + toExpr = maybe (toExpr ()) toExpr -metaExp :: Set VarName -> NExprLoc -> Maybe ExpQ -metaExp fvs (Fix (NSym_ _ x)) | x `Set.member` fvs = +instance (ToExpr a, ToExpr b) => ToExpr (Either a b) where + toExpr = either toExpr toExpr + +metaExp :: Set VarName -> NExpr -> Maybe ExpQ +metaExp fvs (Fix (NSym x)) | x `Set.member` fvs = pure [| toExpr $(varE (mkName $ toString x)) |] metaExp _ _ = Nothing metaPat :: Set VarName -> NExprLoc -> Maybe PatQ -metaPat fvs (Fix (NSym_ _ x)) | x `Set.member` fvs = +metaPat fvs (NSymAnn _ x) | x `Set.member` fvs = pure $ varP $ mkName $ toString x metaPat _ _ = Nothing diff --git a/src/Nix/Thunk.hs b/src/Nix/Thunk.hs --- a/src/Nix/Thunk.hs +++ b/src/Nix/Thunk.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE TypeFamilies #-} +{-# language DefaultSignatures #-} +{-# language FunctionalDependencies #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} 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 @@ -1,7 +1,6 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-unused-do-bind #-} +{-# language ConstraintKinds #-} +{-# language UndecidableInstances #-} +{-# options_ghc -Wno-unused-do-bind #-} module Nix.Thunk.Basic @@ -11,8 +10,7 @@ , MonadBasicThunk ) where -import Prelude hiding ( force ) -import Relude.Extra ( dup ) +import Nix.Prelude import Control.Monad.Ref ( MonadRef(Ref, newRef, readRef, writeRef) , MonadAtomicRef(atomicModifyRef) ) @@ -111,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 @@ -123,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*` @@ -138,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 @@ -159,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 @@ -9,18 +10,18 @@ , extend , keys , merge - , mergeAssumptions , singleton ) where -import Prelude hiding ( Type +import Nix.Prelude hiding ( Type , empty ) +import Nix.Expr.Types import Nix.Type.Type -newtype Assumption = Assumption { assumptions :: [(Name, Type)] } +newtype Assumption = Assumption [(VarName, Type)] deriving (Eq, Show) -- We pretend that Assumptions can be inconsistent (nonunique keys), @@ -33,40 +34,41 @@ mempty = empty instance One Assumption where - type OneItem Assumption = (Name, Type) - one (x, y) = Assumption [(x, y)] + 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 -extend :: Assumption -> (Name, Type) -> Assumption -extend (Assumption a) (x, s) = - Assumption $ - (x, s) : a +extend :: Assumption -> (VarName, Type) -> Assumption +extend a vt = + one (coerce vt) <> a -remove :: Assumption -> Name -> Assumption -remove (Assumption a) var = - Assumption $ +remove :: Assumption -> VarName -> Assumption +remove a var = + coerce + rmVar + a + where + rmVar :: [(VarName, Type)] -> [(VarName, Type)] + rmVar = filter - (\(n, _) -> n /= var) - a + ((/=) var . fst) -lookup :: Name -> Assumption -> [Type] -lookup key (Assumption a) = +lookup :: VarName -> Assumption -> [Type] +lookup key a = snd <$> filter - (\(n, _) -> n == key) - a + ((==) key . fst) + (coerce a) merge :: Assumption -> Assumption -> Assumption -merge (Assumption a) (Assumption b) = - Assumption $ a <> b - -mergeAssumptions :: [Assumption] -> Assumption -mergeAssumptions = foldl' (<>) mempty +merge = + coerce ((<>) @[(VarName, Type)]) -singleton :: Name -> Type -> Assumption -singleton x y = Assumption [(x, y)] +singleton :: VarName -> Type -> Assumption +singleton = curry one -keys :: Assumption -> [Name] +keys :: Assumption -> [VarName] keys (Assumption a) = fst <$> a 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 #-} +{-# language TypeFamilies #-} + module Nix.Type.Env ( Env(..) , empty @@ -15,11 +16,12 @@ ) where -import Prelude hiding ( empty +import Nix.Prelude hiding ( empty , toList , fromList ) +import Nix.Expr.Types import Nix.Type.Type import qualified Data.Map as Map @@ -27,7 +29,7 @@ -- * Typing Environment -newtype Env = TypeEnv (Map.Map Name [Scheme]) +newtype Env = TypeEnv (Map VarName [Scheme]) deriving (Eq, Show) instance Semigroup Env where @@ -39,42 +41,42 @@ mempty = empty instance One Env where - type OneItem Env = (Name, Scheme) - one = uncurry singleton + type OneItem Env = (VarName, Scheme) + one (x, y) = TypeEnv $ one (x, one y) empty :: Env empty = TypeEnv mempty -extend :: Env -> (Name, [Scheme]) -> Env -extend env (x, s) = TypeEnv $ Map.insert x s $ coerce env +extend :: Env -> (VarName, [Scheme]) -> Env +extend env (x, s) = coerce (Map.insert x s) env -remove :: Env -> Name -> Env -remove (TypeEnv env) var = TypeEnv $ Map.delete var env +remove :: Env -> VarName -> Env +remove env var = TypeEnv $ Map.delete var $ coerce env -extends :: Env -> [(Name, [Scheme])] -> Env -extends env xs = TypeEnv $ Map.fromList xs <> coerce env +extends :: Env -> [(VarName, [Scheme])] -> Env +extends env xs = fromList xs <> coerce env -lookup :: Name -> Env -> Maybe [Scheme] -lookup key (TypeEnv tys) = Map.lookup key tys +lookup :: VarName -> Env -> Maybe [Scheme] +lookup key tys = Map.lookup key $ coerce tys merge :: Env -> Env -> Env -merge (TypeEnv a) (TypeEnv b) = TypeEnv $ a <> b +merge a b = TypeEnv $ coerce a <> coerce b mergeRight :: Env -> Env -> Env -mergeRight (TypeEnv a) (TypeEnv b) = TypeEnv $ b <> a +mergeRight = flip merge mergeEnvs :: [Env] -> Env mergeEnvs = foldl' (<>) mempty -singleton :: Name -> Scheme -> Env -singleton x y = TypeEnv $ one (x, [y]) +singleton :: VarName -> Scheme -> Env +singleton = curry one -keys :: Env -> [Name] +keys :: Env -> [VarName] keys (TypeEnv env) = Map.keys env -fromList :: [(Name, [Scheme])] -> Env -fromList xs = TypeEnv $ Map.fromList xs +fromList :: [(VarName, [Scheme])] -> Env +fromList xs = coerce $ Map.fromList xs -toList :: Env -> [(Name, [Scheme])] +toList :: Env -> [(VarName, [Scheme])] toList (TypeEnv env) = Map.toList env 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 @@ -1,14 +1,13 @@ -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} +{-# language MultiWayIf #-} +{-# language CPP #-} +{-# language AllowAmbiguousTypes #-} +{-# language ConstraintKinds #-} +{-# language ExistentialQuantification #-} +{-# language GeneralizedNewtypeDeriving #-} +{-# language RankNTypes #-} +{-# language TypeFamilies #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# options_ghc -Wno-name-shadowing #-} module Nix.Type.Infer ( Constraint(..) @@ -19,17 +18,16 @@ ) where +import Nix.Prelude hiding ( Constraint + , Type + , TVar + ) import Control.Monad.Catch ( MonadThrow(..) , MonadCatch(..) ) -import Control.Monad.Except ( MonadError(..) ) -import Prelude hiding ( Type - , TVar - , Constraint - ) -import Nix.Utils -import Control.Monad.Logic hiding ( fail ) -import Control.Monad.Reader ( MonadFix ) +import Control.Monad.Except ( MonadError(throwError,catchError) ) +import Control.Monad.Logic +import Control.Monad.Fix ( MonadFix ) import Control.Monad.Ref ( MonadAtomicRef(..) , MonadRef(..) ) @@ -37,7 +35,6 @@ , runST ) import Data.Fix ( foldFix ) -import Data.Foldable ( foldrM ) import qualified Data.HashMap.Lazy as M import Data.List ( delete , intersect @@ -56,18 +53,11 @@ , evalWithAttrSet ) import Nix.Expr.Types -import Nix.Expr.Types.Annotated import Nix.Fresh import Nix.String import Nix.Scope -import Nix.Type.Assumption hiding ( assumptions - , extend - ) +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 @@ -80,14 +70,14 @@ ord = zip (ordNub $ fv body) - (TV . toText <$> letters) + (TV . fromString <$> letters) - fv (TVar a ) = [a] - fv (a :~> b ) = fv a <> fv b + fv (TVar a ) = one a + fv (a :~> b ) = on (<>) fv a b fv (TCon _ ) = mempty - fv (TSet _ a) = concatMap fv $ M.elems a - fv (TList a ) = concatMap fv a - fv (TMany ts) = concatMap fv ts + fv (TSet _ a) = foldMap fv $ M.elems a + fv (TList a ) = foldMap fv a + fv (TMany ts) = foldMap fv ts normtype (a :~> b ) = normtype a :~> normtype b normtype (TCon a ) = TCon a @@ -109,6 +99,7 @@ closeOver :: Type -> Scheme closeOver = normalizeScheme . generalize mempty +-- When `[]` becomes `NonEmpty` - function becomes just `all` -- | Check if all elements are of the same type. allSameType :: [Type] -> Bool allSameType = allSame @@ -122,7 +113,7 @@ data TypeError = UnificationFail Type Type | InfiniteType TVar Type - | UnboundVariables [Text] + | UnboundVariables [VarName] | Ambigious [Constraint] | UnificationMismatch [Type] [Type] deriving (Eq, Show, Ord) @@ -135,7 +126,7 @@ | forall s. Exception s => EvaluationError s typeError :: MonadError InferError m => TypeError -> m () -typeError err = throwError $ TypeInferenceErrors [err] +typeError err = throwError $ TypeInferenceErrors $ one err -- ** Instances @@ -143,20 +134,27 @@ instance Exception InferError instance Semigroup InferError where - x <> _ = x + (<>) = const instance Monoid InferError where mempty = TypeInferenceAborted - mappend = (<>) -- * @InferState@: inference state --- | Inference state -newtype InferState = InferState { count :: Int } +-- | Inference state (stage). +newtype InferState = InferState Int + deriving + (Eq, Num, Enum, Ord) +instance Semigroup InferState where + (<>) = (+) + +instance Monoid InferState where + mempty = 0 + -- | Initial inference state initInfer :: InferState -initInfer = InferState { count = 0 } +initInfer = InferState 0 letters :: [String] letters = @@ -170,18 +168,19 @@ freshTVar = do s <- get - put s { count = count s + 1 } - pure $ TV $ toText $ letters !! count s + put $ succ s + pure $ TV $ fromString $ letters !! coerce s fresh :: MonadState InferState m => m Type fresh = TVar <$> freshTVar +intoFresh :: (Traversable t, MonadState InferState f) => t a -> f (t Type) +intoFresh = + traverse (const fresh) + instantiate :: MonadState InferState m => Scheme -> m Type instantiate (Forall as t) = - do - as' <- traverse (const fresh) as - let s = Subst $ Map.fromList $ zip as as' - pure $ apply s t + fmap ((`apply` t) . coerce . Map.fromList . zip as) (intoFresh as) -- * @Constraint@ data type @@ -199,9 +198,9 @@ -- | Compose substitutions compose :: Subst -> Subst -> Subst -Subst s1 `compose` Subst s2 = - Subst $ - apply (Subst s1) <$> +compose a@(Subst s2) (Subst s1) = + coerce $ -- + apply a <$> (s2 <> s1) -- * class @Substitutable@ @@ -214,15 +213,14 @@ instance Substitutable TVar where apply (Subst s) a = tv where - t = TVar a - (TVar tv) = Map.findWithDefault t a s + (TVar tv) = Map.findWithDefault (TVar a) a s instance Substitutable Type where apply _ ( TCon a ) = TCon a apply s ( TSet b a ) = TSet b $ apply s <$> a apply s ( TList a ) = TList $ apply s <$> a apply (Subst s) t@(TVar a ) = Map.findWithDefault t a s - apply s ( t1 :~> t2) = apply s t1 :~> apply s t2 + apply s ( t1 :~> t2) = ((:~>) `on` apply s) t1 t2 apply s ( TMany ts ) = TMany $ apply s <$> ts instance Substitutable Scheme where @@ -231,10 +229,7 @@ s' = Subst $ foldr Map.delete s as instance Substitutable Constraint where - apply s (EqConst t1 t2) = - EqConst - (apply s t1) - (apply s t2) + apply s (EqConst t1 t2) = on EqConst (apply s) t1 t2 apply s (ExpInstConst t sc) = ExpInstConst (apply s t) @@ -252,7 +247,7 @@ apply = Set.map . apply --- * data type @Judgement@ +-- * data type @Judgment@ data Judgment s = Judgment @@ -262,16 +257,22 @@ } deriving Show +inferred :: Type -> Judgment s +inferred = Judgment mempty mempty + -- * @InferT@: inference monad +type InferTInternals s m a = + ReaderT + (Set.Set TVar, Scopes (InferT s m) (Judgment s)) + (StateT InferState (ExceptT InferError m)) + a + -- | Inference monad newtype InferT s m a = InferT { getInfer :: - ReaderT - (Set.Set TVar, Scopes (InferT s m) (Judgment s)) - (StateT InferState (ExceptT InferError m)) - a + InferTInternals s m a } deriving ( Functor @@ -286,8 +287,11 @@ , MonadError InferError ) -extendMSet :: Monad m => TVar -> InferT s m a -> InferT s m a -extendMSet x = InferT . local (first $ Set.insert x) . getInfer +extendMSet :: forall s m a . Monad m => TVar -> InferT s m a -> InferT s m a +extendMSet x = coerce putSetElementM + where + putSetElementM :: InferTInternals s m a -> InferTInternals s m a + putSetElementM = local (first . Set.insert $ x) -- ** Instances @@ -335,66 +339,53 @@ instance MonadInfer m => FromValue ( AttrSet (Judgment s) - , AttrSet SourcePos + , PositionSet ) (InferT s m) (Judgment s) where fromValueMay (Judgment _ _ (TSet _ xs)) = do - let sing _ = Judgment mempty mempty + let sing = const inferred pure $ pure (M.mapWithKey sing xs, mempty) fromValueMay _ = stub fromValue = pure . - fromMaybe - (mempty, mempty) + maybeToMonoid <=< fromValueMay -instance MonadInfer m - => ToValue (AttrSet (Judgment s), AttrSet SourcePos) - (InferT s m) (Judgment s) where - toValue (xs, _) = - liftA3 - Judgment - (foldrM go mempty xs) - (fun concat typeConstraints) - (fun (TSet True) inferredType ) +foldInitializedWith :: (Traversable t, Applicative f) => (t c -> c) -> (b -> c) -> (a -> f b) -> t a -> f c +foldInitializedWith fld getter init = + -- maybe here is some law? + fmap fld . traverse (fmap getter . init) + +toJudgment :: forall t m s . (Traversable t, Monad m) => (t Type -> Type) -> t (Judgment s) -> InferT s m (Judgment s) +toJudgment c xs = + liftA3 Judgment + (foldWith fold assumptions ) + (foldWith fold typeConstraints) + (foldWith c inferredType ) where - go x rest = - do - x' <- demand x - pure $ assumptions x' <> rest + foldWith :: (t a -> a) -> (Judgment s -> a) -> InferT s m a + foldWith g f = foldInitializedWith g f demand xs - fun :: (AttrSet b -> b1) -> (Judgment s -> b) -> InferT s m b1 - fun g f = - g <$> traverse ((f <$>) . demand) xs +instance MonadInfer m + => ToValue (AttrSet (Judgment s), PositionSet) + (InferT s m) (Judgment s) where + toValue :: (AttrSet (Judgment s), PositionSet) -> InferT s m (Judgment s) + toValue (xs, _) = toJudgment (TSet Variadic) xs -- why variadic? Probably `Closed` (`mempty`)? instance MonadInfer m => ToValue [Judgment s] (InferT s m) (Judgment s) where - toValue xs = - liftA3 - Judgment - (foldrM go mempty xs) - (fun concat typeConstraints) - (fun TList inferredType ) - where - go x rest = - do - x' <- demand x - pure $ assumptions x' <> rest - - fun :: ([b] -> b1) -> (Judgment s -> b) -> InferT s m b1 - fun g f = - g <$> traverse ((f <$>) . demand) xs + toValue = toJudgment TList instance MonadInfer m => ToValue Bool (InferT s m) (Judgment s) where - toValue _ = pure $ Judgment mempty mempty typeBool + toValue _ = pure $ inferred typeBool 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)) @@ -424,7 +415,7 @@ -> InferT s m r) -> Judgment s -> InferT s m r - demandF f a = f a + demandF f = f informF :: ( InferT s m (Judgment s) @@ -455,84 +446,73 @@ f =<< Judgment mempty mempty <$> fresh -} +polymorphicVar :: MonadInfer m => VarName -> InferT s m (Judgment s) +polymorphicVar var = + fmap + (join $ (`Judgment` mempty) . curry one var) + fresh + +constInfer :: Applicative f => Type -> b -> f (Judgment s) +constInfer x = const $ pure $ inferred x + instance MonadInfer m => MonadEval (Judgment s) (InferT s m) where - freeVariable var = do - tv <- fresh - pure $ Judgment (one (var, tv)) mempty tv + freeVariable = polymorphicVar - synHole var = do - tv <- fresh - pure $ Judgment (one (var, tv)) mempty tv + synHole = polymorphicVar -- If we fail to look up an attribute, we just don't know the type. - attrMissing _ _ = Judgment mempty mempty <$> fresh + attrMissing _ _ = inferred <$> fresh evaledSym _ = pure evalCurPos = pure $ - Judgment - mempty - mempty - (TSet False $ + inferred $ + TSet mempty $ M.fromList [ ("file", typePath) , ("line", typeInt ) , ("col" , typeInt ) ] - ) - evalConstant c = pure $ Judgment mempty mempty $ go c + evalConstant c = pure $ inferred $ fun c where - go = \case + fun = \case NURI _ -> typeString NInt _ -> typeInt NFloat _ -> typeFloat NBool _ -> typeBool NNull -> typeNull - evalString = const $ pure $ Judgment mempty mempty typeString - evalLiteralPath = const $ pure $ Judgment mempty mempty typePath - evalEnvPath = const $ pure $ Judgment mempty mempty typePath + evalString = constInfer typeString + evalLiteralPath = constInfer typePath + evalEnvPath = constInfer typePath - evalUnary op (Judgment as1 cs1 t1) = do - tv <- fresh - pure $ - Judgment - as1 - (cs1 <> unops (t1 :~> tv) op) - tv + evalUnary op (Judgment as1 cs1 t1) = + (Judgment as1 =<< (cs1 <>) . (`unops` op) . (t1 :~>)) <$> fresh - evalBinary op (Judgment as1 cs1 t1) e2 = do - Judgment as2 cs2 t2 <- e2 - tv <- fresh - pure $ - Judgment - (as1 <> as2) - ( cs1 <> - cs2 <> - binops - (t1 :~> t2 :~> tv) - op - ) - tv + 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 evalIf (Judgment as1 cs1 t1) t f = do Judgment as2 cs2 t2 <- t Judgment as3 cs3 t3 <- f - pure $ Judgment - (as1 <> as2 <> as3) - (cs1 <> cs2 <> cs3 <> [EqConst t1 typeBool, EqConst t2 t3]) - t2 + pure $ + Judgment + (as1 <> as2 <> as3) + (cs1 <> cs2 <> cs3 <> [EqConst t1 typeBool, EqConst t2 t3]) + t2 evalAssert (Judgment as1 cs1 t1) body = do Judgment as2 cs2 t2 <- body pure $ Judgment (as1 <> as2) - (cs1 <> cs2 <> [EqConst t1 typeBool]) + (cs1 <> cs2 <> one (EqConst t1 typeBool)) t2 evalApp (Judgment as1 cs1 t1) e2 = do @@ -541,7 +521,7 @@ pure $ Judgment (as1 <> as2) - (cs1 <> cs2 <> [EqConst t1 (t2 :~> tv)]) + (cs1 <> cs2 <> one (EqConst t1 (t2 :~> tv))) tv evalAbs (Param x) k = do @@ -550,42 +530,28 @@ ((), 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) (cs <> [ EqConst t' tv | t' <- Assumption.lookup x as ]) (tv :~> t) - evalAbs (ParamSet ps variadic _mname) k = do - js <- - concat <$> - traverse - (\(name, _) -> - do - tv <- fresh - pure [(name, tv)] - ) - ps + evalAbs (ParamSet _mname variadic pset) k = do + js <- foldInitializedWith fold one intoFresh pset let f (as1, t1) (k, t) = (as1 <> one (k, t), M.insert k t t1) - (env, tys) = foldl' f (mempty, mempty) js - arg = pure $ Judgment env mempty $ TSet True tys + (env, tys) = foldl' f mempty js + arg = pure $ Judgment env mempty $ TSet Variadic tys 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 <- TSet variadic <$> traverse (inferredType <$>) args + ty <- foldInitializedWith (TSet variadic) inferredType id args pure $ Judgment @@ -651,15 +617,12 @@ runInfer' = runExceptT . (`evalStateT` initInfer) - . (`runReaderT` (mempty, mempty)) + . (`runReaderT` mempty) . getInfer 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)] @@ -667,12 +630,13 @@ do Judgment as cs t <- infer ex let + unbounds :: Set VarName unbounds = (Set.difference `on` Set.fromList) (Assumption.keys as ) ( Env.keys env) - unless - (Set.null unbounds) + when + (isPresent unbounds) $ typeError $ UnboundVariables $ ordNub $ Set.toList unbounds inferState <- get @@ -683,37 +647,38 @@ , s <- ss , t <- Assumption.lookup x as ] - eres = (`evalState` inferState) $ runSolver $ - do - subst <- solve $ cs <> cs' - pure (subst, subst `apply` t) + evalResult = + (`evalState` inferState) . runSolver $ second (`apply` t) . join (,) <$> solve (cs <> cs') either (throwError . TypeInferenceErrors) pure - eres + evalResult -- | Solve for the toplevel type of an expression in a given environment inferExpr :: Env -> NExpr -> Either InferError [Scheme] inferExpr env ex = - (\ (subst, ty) -> closeOver $ subst `apply` ty) <<$>> - runInfer (inferType env ex) + closeOver . uncurry apply <<$>> runInfer (inferType env ex) unops :: Type -> NUnaryOp -> [Constraint] unops u1 op = - [ EqConst u1 - (case op of - NNot -> typeFun [typeBool , typeBool ] - NNeg -> TMany [typeFun [typeInt, typeInt], typeFun [typeFloat, typeFloat]] - ) - ] + one $ + EqConst u1 $ + case op of + NNot -> mkUnaryConstr typeBool + NNeg -> TMany $ mkUnaryConstr <$> [typeInt, typeFloat] + where + mkUnaryConstr :: Type -> Type + mkUnaryConstr = typeFun . mk2same + where + mk2same :: a -> NonEmpty a + mk2same a = a :| one a binops :: Type -> NBinaryOp -> [Constraint] binops u1 op = if - -- NApp in fact is handled separately -- Equality tells nothing about the types, because any two types are allowed. - | op `elem` [ NApp , NEq , NNEq ] -> mempty + | op `elem` [ NEq , NNEq ] -> mempty | op `elem` [ NGt , NGte , NLt , NLte ] -> inequality | op `elem` [ NAnd , NOr , NImpl ] -> gate | op == NConcat -> concatenation @@ -724,47 +689,55 @@ where - gate = eqCnst [typeBool, typeBool, typeBool] - concatenation = eqCnst [typeList, typeList, typeList] + mk3 :: a -> a -> a -> NonEmpty a + mk3 a b c = a :| [b, c] - eqCnst l = [EqConst u1 $ typeFun l] + mk3same :: a -> NonEmpty a + mk3same a = a :| [a, a] + allConst :: Type -> [Constraint] + allConst = one . EqConst u1 . typeFun . mk3same + + gate = allConst typeBool + concatenation = allConst typeList + + eqConstrMtx :: [NonEmpty Type] -> [Constraint] + eqConstrMtx = one . EqConst u1 . TMany . fmap typeFun + inequality = - eqCnstMtx - [ [typeInt , typeInt , typeBool] - , [typeFloat, typeFloat, typeBool] - , [typeInt , typeFloat, typeBool] - , [typeFloat, typeInt , typeBool] + eqConstrMtx + [ mk3 typeInt typeInt typeBool + , mk3 typeFloat typeFloat typeBool + , mk3 typeInt typeFloat typeBool + , mk3 typeFloat typeInt typeBool ] arithmetic = - eqCnstMtx - [ [typeInt , typeInt , typeInt ] - , [typeFloat, typeFloat, typeFloat] - , [typeInt , typeFloat, typeFloat] - , [typeFloat, typeInt , typeFloat] + eqConstrMtx + [ mk3same typeInt + , mk3same typeFloat + , mk3 typeInt typeFloat typeFloat + , mk3 typeFloat typeInt typeFloat ] rUnion = - eqCnstMtx - [ [typeSet , typeSet , typeSet] - , [typeSet , typeNull, typeSet] - , [typeNull, typeSet , typeSet] + eqConstrMtx + [ mk3same typeSet + , mk3 typeSet typeNull typeSet + , mk3 typeNull typeSet typeSet ] addition = - eqCnstMtx - [ [typeInt , typeInt , typeInt ] - , [typeFloat , typeFloat , typeFloat ] - , [typeInt , typeFloat , typeFloat ] - , [typeFloat , typeInt , typeFloat ] - , [typeString, typeString, typeString] - , [typePath , typePath , typePath ] - , [typeString, typeString, typePath ] + eqConstrMtx + [ mk3same typeInt + , mk3same typeFloat + , mk3 typeInt typeFloat typeFloat + , mk3 typeFloat typeInt typeFloat + , mk3same typeString + , mk3same typePath + , mk3 typeString typeString typePath ] - eqCnstMtx mtx = [EqConst u1 $ TMany $ typeFun <$> mtx] - liftInfer :: Monad m => m a -> InferT s m a liftInfer = InferT . lift . lift . lift @@ -773,13 +746,11 @@ infer :: MonadInfer m => NExpr -> InferT s m (Judgment s) infer = foldFix Eval.eval -inferTop :: Env -> [(Text, NExpr)] -> Either InferError Env +inferTop :: Env -> [(VarName, NExpr)] -> Either InferError Env inferTop env [] = pure env inferTop env ((name, ex) : xs) = - either - Left - (\ ty -> inferTop (extend env (name, ty)) xs) - (inferExpr env ex) + (\ ty -> inferTop (extend env (name, ty)) xs) + =<< inferExpr env ex -- * Other @@ -787,13 +758,16 @@ deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadLogic, MonadState [TypeError]) -runSolver :: Monad m => Solver m a -> m (Either [TypeError] [a]) -runSolver (Solver s) = do - res <- runStateT (observeAllT s) mempty - pure $ - case res of - (x : xs, _ ) -> pure (x : xs) - (_ , es) -> Left (ordNub es) +runSolver :: forall m a . Monad m => Solver m a -> m (Either [TypeError] [a]) +runSolver (Solver s) = + uncurry report <$> runStateT (observeAllT s) mempty + where + report :: [a] -> [TypeError] -> Either [TypeError] [a] + report xs e = + handlePresence + (Left $ ordNub e) + pure + xs -- ** Instances @@ -827,13 +801,9 @@ -- Putting a statement that lists of different lengths containing various types would not -- be unified. unifies t1@(TList _ ) t2@(TList _ ) = throwError $ UnificationFail t1 t2 -unifies ( TSet True _) ( TSet True _) = stub -unifies (TSet False b) (TSet True s) - | M.keys b `intersect` M.keys s == M.keys s = stub -unifies (TSet True s) (TSet False b) - | M.keys b `intersect` M.keys s == M.keys b = stub -unifies (TSet False s) (TSet False b) - | null (M.keys b \\ M.keys s) = stub +unifies (TSet Variadic _) (TSet Variadic _) = stub +unifies (TSet Closed s) (TSet Closed b) | null (M.keys b \\ M.keys s) = stub +unifies (TSet _ a) (TSet _ b) | (M.keys a `intersect` M.keys b) == M.keys b = stub unifies (t1 :~> t2) (t3 :~> t4) = unifyMany [t1, t2] [t3, t4] unifies (TMany t1s) t2 = considering t1s >>- (`unifies` t2) unifies t1 (TMany t2s) = considering t2s >>- unifies t1 @@ -841,39 +811,43 @@ unifyMany :: Monad m => [Type] -> [Type] -> Solver m Subst unifyMany [] [] = stub -unifyMany (t1 : ts1) (t2 : ts2) = do - su1 <- unifies t1 t2 - su2 <- - unifyMany - (apply su1 ts1) - (apply su1 ts2) - pure $ su2 `compose` su1 +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]) -nextSolvable xs = fromJust $ find solvable $ takeFirstOnes xs +nextSolvable = fromJust . find solvable . pickFirstOne where - takeFirstOnes :: Eq a => [a] -> [(a, [a])] - takeFirstOnes xs = [ (x, ys) | x <- xs, let ys = delete x xs ] + pickFirstOne :: Eq a => [a] -> [(a, [a])] + pickFirstOne xs = [ (x, ys) | x <- xs, let ys = delete x xs ] solvable :: (Constraint, [Constraint]) -> Bool solvable (EqConst{} , _) = True solvable (ExpInstConst{}, _) = True solvable (ImpInstConst _t1 ms t2, cs) = - Set.null $ (ms `Set.difference` ftv t2) `Set.intersection` atv cs + null $ (ms `Set.difference` ftv t2) `Set.intersection` atv cs -solve :: MonadState InferState m => [Constraint] -> Solver m Subst +solve :: forall m . MonadState InferState m => [Constraint] -> Solver m Subst solve [] = stub solve cs = solve' $ nextSolvable cs where - solve' (EqConst t1 t2, cs) = - unifies t1 t2 >>- - \su1 -> solve (apply su1 cs) >>- - \su2 -> pure $ su2 `compose` su1 - solve' (ImpInstConst t1 ms t2, cs) = solve (ExpInstConst t1 (generalize ms t2) : cs) + solve' (ExpInstConst t s, cs) = + do + s' <- lift $ instantiate s + solve (EqConst t s' : cs) + solve' (EqConst t1 t2, cs) = + (\ su1 -> + (pure . compose su1) -<< solve ((`apply` cs) su1) + ) -<< + unifies t1 t2 - solve' (ExpInstConst t s, cs) = do - s' <- lift $ instantiate s - solve (EqConst t s' : cs) +infixr 1 -<< +-- | @LogicT@ fair conjunction, since library has only @>>-@ +(-<<) :: Monad m => (a -> Solver m b) -> Solver m a -> Solver m b +(-<<) = flip (>>-) 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,11 +3,8 @@ -- Therefore -> from this the type inference follows. module Nix.Type.Type where -import Prelude hiding ( Type, TVar ) -import Data.Foldable ( foldr1 ) -import Nix.Utils ( AttrSet ) - -type Name = Text +import Nix.Prelude hiding ( Type, TVar ) +import Nix.Expr.Types -- | Hindrey-Milner type interface @@ -19,7 +16,7 @@ data Type = TVar TVar -- ^ Type variable in the Nix type system. | TCon Text -- ^ Concrete (non-polymorphic, constant) type in the Nix type system. - | TSet Bool (AttrSet Type) -- ^ Heterogeneous map in the Nix type system. @True@ -> variadic. + | TSet Variadic (AttrSet Type) -- ^ Heterogeneous map in the Nix type system. @True@ -> variadic. | TList [Type] -- ^ Heterogeneous list in the Nix type system. | (:~>) Type Type -- ^ Type arrow (@Type -> Type@) in the Nix type system. | TMany [Type] -- ^ Variant type (term). Since relating to Nix type system, more precicely - @@ -34,22 +31,21 @@ data Scheme = Forall [TVar] Type -- ^ @Forall [TVar] Type@: the Nix type system @forall vars. type@. deriving (Show, Eq, Ord) +-- | Concrete types in the Nix type system. +typeNull, typeBool, typeInt, typeFloat, typeString, typePath :: Type +typeNull = TCon "null" +typeBool = TCon "boolean" +typeInt = TCon "integer" +typeFloat = TCon "float" +typeString = TCon "string" +typePath = TCon "path" + -- This models a set that unifies with any other set. typeSet :: Type -typeSet = TSet True mempty +typeSet = TSet mempty mempty typeList :: Type typeList = TList mempty -typeFun :: [Type] -> Type --- Please, replace with safe analog to `foldr1` -typeFun = foldr1 (:~>) - --- | Concrete types in the Nix type system. -typeInt, typeFloat, typeBool, typeString, typePath, typeNull :: Type -typeInt = TCon "integer" -typeFloat = TCon "float" -typeBool = TCon "boolean" -typeString = TCon "string" -typePath = TCon "path" -typeNull = TCon "null" +typeFun :: NonEmpty Type -> Type +typeFun (head_ :| tail_) = foldr (:~>) head_ tail_ diff --git a/src/Nix/Unused.hs b/src/Nix/Unused.hs new file mode 100644 --- /dev/null +++ b/src/Nix/Unused.hs @@ -0,0 +1,83 @@ +{-# language FunctionalDependencies #-} +{-# language TemplateHaskell #-} + +{-# options_ghc -Wno-missing-signatures #-} + +-- | This module holds unused code. +-- So, if someone wants something - look here, use it & move to appropriate place. +module Nix.Unused + where + +import Nix.Prelude +import Control.Monad.Free ( Free(..) ) +import Data.Fix ( Fix(..) ) +import Lens.Family2.TH ( makeLensesBy ) + +-- * From "Nix.Utils" + +-- | > type AlgM f m a = f a -> m a +type AlgM f m a = f a -> m a + +whenFree :: (Monoid b) + => (f (Free f a) -> b) -> Free f a -> b +whenFree = + free + mempty +{-# inline whenFree #-} + +whenPure :: (Monoid b) + => (a -> b) -> Free f a -> b +whenPure f = + free + f + mempty +{-# inline whenPure #-} + +-- | Replace: +-- @Pure a -> a@ +-- @Free -> Fix@ +freeToFix :: Functor f => (a -> Fix f) -> Free f a -> Fix f +freeToFix f = go + where + go = + free + f + $ Fix . (go <$>) + +-- | Replace: +-- @a -> Pure a@ +-- @Fix -> Free@ +fixToFree :: Functor f => Fix f -> Free f a +fixToFree = Free . go + where + go (Fix f) = Free . go <$> f + + +loeb :: Functor f => f (f a -> a) -> f a +loeb x = go + where + go = ($ go) <$> x + +adiM + :: ( Traversable t + , Monad m + ) + => Transform t (m a) + -> AlgM t m a + -> Fix t + -> m a +adiM g f = g $ f <=< traverse (adiM g f) . unFix + +para :: Functor f => (f (Fix f, a) -> a) -> Fix f -> a +para f = f . fmap (id &&& para f) . unFix + +paraM :: (Traversable f, Monad m) => (f (Fix f, a) -> m a) -> Fix f -> m a +paraM f = f <=< traverse (\x -> (x, ) <$> paraM f x) . unFix + +cataP :: Functor f => (Fix f -> f a -> a) -> Fix f -> a +cataP f x = f x . fmap (cataP f) . unFix $ x + +cataPM :: (Traversable f, Monad m) => (Fix f -> f a -> m a) -> Fix f -> m a +cataPM f x = f x <=< traverse (cataPM f) . unFix $ x + +$(makeLensesBy (\n -> pure $ "_" <> n) ''Fix) diff --git a/src/Nix/Utils.hs b/src/Nix/Utils.hs --- a/src/Nix/Utils.hs +++ b/src/Nix/Utils.hs @@ -1,123 +1,344 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} +{-# language CPP #-} +{-# language GeneralizedNewtypeDeriving #-} -{-# OPTIONS_GHC -Wno-missing-signatures #-} +-- | This is a module of custom "Prelude" code. +-- 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 + ( stub + , pass + , dup + , both + , mapPair + , iterateN + , nestM + , applyAll + , traverse2 + , lifted -module Nix.Utils (module Nix.Utils, module X) where + , whenTrue + , whenFalse + , whenJust + , isPresent + , handlePresence + , whenText + , free + , Path(..) + , isAbsolute + , () + , joinPath + , splitDirectories + , takeDirectory + , takeFileName + , takeBaseName + , takeExtension + , takeExtensions + , addExtension + , dropExtensions + , replaceExtension + , readFile + + , Alg + , Transform + , TransformF + , loebM + , adi + + , Has(..) + , askLocal + + , KeyMap + + , trace + , traceM + , module X + ) + where + +import Relude hiding ( pass + , force + , readFile + , whenJust + , whenNothing + , trace + , traceM + ) + +import Data.Binary ( Binary ) +import Data.Data ( Data ) +import Codec.Serialise ( Serialise ) +import Control.Monad ( foldM ) import Control.Monad.Fix ( MonadFix(..) ) import Control.Monad.Free ( Free(..) ) import Control.Monad.Trans.Control ( MonadTransControl(..) ) import qualified Data.Aeson as A -import qualified Data.Aeson.Encoding as A -#if MIN_VERSION_aeson(2,0,0) -import qualified Data.Aeson.KeyMap as AKM -#else -import qualified Data.HashMap.Strict as HM -#endif import Data.Fix ( Fix(..) ) -import qualified Data.HashMap.Lazy as M import qualified Data.Text as Text -import qualified Data.Vector as V -import Lens.Family2 as X hiding ((&)) +import Lens.Family2 as X + ( view + , over + , LensLike' + , Lens' + ) import Lens.Family2.Stock ( _1 , _2 ) -import Lens.Family2.TH ( makeLensesBy ) +import qualified System.FilePath as FilePath #if ENABLE_TRACING -import Debug.Trace as X +import qualified Relude.Debug as X #else -- Well, since it is currently CPP intermingled with Debug.Trace, required to use String here. trace :: String -> a -> a trace = const id {-# inline trace #-} traceM :: Monad m => String -> m () -traceM = const pass +traceM = const stub {-# inline traceM #-} #endif -$(makeLensesBy (\n -> pure $ "_" <> n) ''Fix) +-- * Helpers --- | > Hashmap Text -- type synonym -type AttrSet = HashMap Text +-- 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 #-} --- | 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 +-- | Alias for 'stub', since "Relude" has more specialized @pure ()@. +pass :: (Applicative f) => f () +pass = stub +{-# inline pass #-} --- | > type AlgM f m a = f a -> m a -type AlgM f m a = f a -> m a +-- | Duplicates object into a tuple. +dup :: a -> (a, a) +dup x = (x, x) +{-# inline dup #-} --- | Do according transformation. +-- | Apply a single function to both components of a pair. -- --- It is a transformation of a recursion scheme. --- See @TransformF@. -type Transform f a = TransformF (Fix f) a --- | Do according transformation. +-- > both succ (1,2) == (2,3) -- --- It is a transformation between functors. --- ... --- You got me, it is a natural transformation. -type TransformF f a = (f -> a) -> f -> a - -loeb :: Functor f => f (f a -> a) -> f a -loeb x = go - where - go = ($ go) <$> x +-- Taken From package @extra@ +both :: (a -> b) -> (a, a) -> (b, b) +both f (x,y) = (f x, f y) +{-# inline both #-} -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 #-} +-- | 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 #-} -para :: Functor f => (f (Fix f, a) -> a) -> Fix f -> a -para f = f . fmap (id &&& para f) . unFix +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 -paraM :: (Traversable f, Monad m) => (f (Fix f, a) -> m a) -> Fix f -> m a -paraM f = f <=< traverse (\x -> (x, ) <$> paraM f x) . unFix +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 #-} -cataP :: Functor f => (Fix f -> f a -> a) -> Fix f -> a -cataP f x = f x . fmap (cataP f) . unFix $ x +-- | In `foldr` order apply functions. +applyAll :: Foldable t => t (a -> a) -> a -> a +applyAll = flip (foldr id) -cataPM :: (Traversable f, Monad m) => (Fix f -> f a -> m a) -> Fix f -> m a -cataPM f x = f x <=< traverse (cataPM f) . unFix $ x +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 = - do - lftd <- liftWith (\run -> f (run . k)) - restoreT $ pure lftd + restoreT . pure =<< liftWith (\run -> f (run . k)) --- | Replace: --- @Pure a -> a@ --- @Free -> Fix@ -freeToFix :: Functor f => (a -> Fix f) -> Free f a -> Fix f -freeToFix f = go - where - go = - free - f - $ Fix . (go <$>) --- | Replace: --- @a -> Pure a@ --- @Fix -> Free@ -fixToFree :: Functor f => Fix f -> Free f a -fixToFree = Free . go - where - go (Fix f) = Free . go <$> f +-- * 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 #-} + +isPresent :: Foldable t => t a -> Bool +isPresent = not . null +{-# inline isPresent #-} + + +-- | 'maybe'-like eliminator, for foldable empty/inhabited structures. +handlePresence :: Foldable t => b -> (t a -> b) -> t a -> b +handlePresence d f t = + bool + d + (f t) + (isPresent t) +{-# inline handlePresence #-} + +whenText + :: a -> (Text -> a) -> Text -> a +whenText e f t = + bool + e + (f t) + (not $ 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 + , Typeable, Data, NFData, Serialise, Binary, A.ToJSON, A.FromJSON + , Show, Read, Hashable + , Semigroup, Monoid + ) + +instance ToText Path where + toText = toText @String . coerce + +instance IsString Path where + fromString = coerce + +-- ** Path functions + +-- | 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 + +-- | 'Path's 'FilePath.()'. +() :: Path -> Path -> Path +() = coerce (FilePath.) +infixr 5 + +-- | 'Path's 'FilePath.joinPath'. +joinPath :: [Path] -> Path +joinPath = coerce FilePath.joinPath + +-- | 'Path's 'FilePath.splitDirectories'. +splitDirectories :: Path -> [Path] +splitDirectories = coerce FilePath.splitDirectories + +-- | 'Path's 'FilePath.takeDirectory'. +takeDirectory :: Path -> Path +takeDirectory = coerce FilePath.takeDirectory + +-- | 'Path's 'FilePath.takeFileName'. +takeFileName :: Path -> Path +takeFileName = coerce FilePath.takeFileName + +-- | 'Path's 'FilePath.takeBaseName'. +takeBaseName :: Path -> String +takeBaseName = coerce FilePath.takeBaseName + +-- | 'Path's 'FilePath.takeExtension'. +takeExtension :: Path -> String +takeExtension = coerce FilePath.takeExtensions + +-- | 'Path's 'FilePath.takeExtensions'. +takeExtensions :: Path -> String +takeExtensions = coerce FilePath.takeExtensions + +-- | 'Path's 'FilePath.addExtensions'. +addExtension :: Path -> String -> Path +addExtension = coerce FilePath.addExtension + +-- | 'Path's 'FilePath.dropExtensions'. +dropExtensions :: Path -> Path +dropExtensions = coerce FilePath.dropExtensions + +-- | 'Path's 'FilePath.replaceExtension'. +replaceExtension :: Path -> String -> Path +replaceExtension = coerce FilePath.replaceExtension + +-- | 'Path's 'FilePath.readFile'. +readFile :: MonadIO m => Path -> m Text +readFile = fmap decodeUtf8 . readFileBS . coerce + + +-- * 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 + +-- | Do according transformation. +-- +-- It is a transformation of a recursion scheme. +-- See @TransformF@. +type Transform f a = TransformF (Fix f) a +-- | Do according transformation. +-- +-- It is a transformation between functors. +type TransformF f a = (f -> a) -> f -> a + +loebM :: (MonadFix m, Traversable t) => t (t a -> m a) -> m (t a) +loebM f = mfix $ \a -> (`traverse` f) ($ a) +{-# inline loebM #-} + -- | adi is Abstracting Definitional Interpreters: -- -- https://arxiv.org/abs/1707.04755 -- +-- All ADI does is interleaves every layer of evaluation by inserting intermitten layers between them, in that way the evaluation can be extended/embelished in any way wanted. Look at its use to see great examples. +-- -- Essentially, it does for evaluation what recursion schemes do for -- representation: allows threading layers through existing structure, only -- in this case through behavior. @@ -129,16 +350,8 @@ -> a adi g f = g $ f . (adi g f <$>) . unFix -adiM - :: ( Traversable t - , Monad m - ) - => Transform t (m a) - -> AlgM t m a - -> Fix t - -> m a -adiM g f = g $ f <=< traverse (adiM g f) . unFix +-- * Has lens class Has a b where hasLens :: Lens' a b @@ -152,122 +365,11 @@ instance Has (a, b) b where hasLens = _2 -toEncodingSorted :: A.Value -> A.Encoding -toEncodingSorted = \case - A.Object m -> - A.pairs - . mconcat - . ((\(k, v) -> A.pair k $ toEncodingSorted v) <$>) - . sortWith fst $ -#if MIN_VERSION_aeson(2,0,0) - AKM.toList -#else - HM.toList -#endif - m - A.Array l -> A.list toEncodingSorted $ V.toList l - v -> A.toEncoding v - -data NixPathEntryType = PathEntryPath | PathEntryURI deriving (Show, Eq) - --- | @NIX_PATH@ is colon-separated, but can also contain URLs, which have a colon --- (i.e. @https://...@) -uriAwareSplit :: Text -> [(Text, NixPathEntryType)] -uriAwareSplit txt = - case Text.break (== ':') txt of - (e1, e2) - | Text.null e2 -> [(e1, PathEntryPath)] - | "://" `Text.isPrefixOf` e2 -> - let ((suffix, _) : path) = uriAwareSplit (Text.drop 3 e2) in - (e1 <> "://" <> suffix, PathEntryURI) : path - | otherwise -> (e1, PathEntryPath) : uriAwareSplit (Text.drop 1 e2) - -alterF - :: (Eq k, Hashable k, Functor f) - => (Maybe v -> f (Maybe v)) - -> k - -> HashMap k v - -> f (HashMap k v) -alterF f k m = - maybe - (M.delete k m) - (\ v -> M.insert k v m) - <$> f (M.lookup k m) - - --- | 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 #-} - --- | 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 #-} - -whenFree :: (Monoid b) - => (f (Free f a) -> b) -> Free f a -> b -whenFree = - free - mempty -{-# inline whenFree #-} - -whenPure :: (Monoid b) - => (a -> b) -> Free f a -> b -whenPure f = - free - f - mempty -{-# inline whenPure #-} - - --- | 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 #-} - - --- | Duplicates object into a tuple. -dup :: a -> (a, a) -dup x = (x, x) -{-# inline dup #-} +-- | Retrive monad state by 'Lens''. +askLocal :: (MonadReader t m, Has t a) => m a +askLocal = asks $ view hasLens --- | 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 #-} +-- * Other --- 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 #-} +-- | > 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 @@ -1,25 +1,33 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE UndecidableInstances #-} +{-# language TypeFamilies #-} +{-# language ConstraintKinds #-} +{-# language CPP #-} +{-# language GeneralizedNewtypeDeriving #-} +{-# language PolyKinds #-} +{-# language UndecidableInstances #-} -module Nix.Utils.Fix1 where +module Nix.Utils.Fix1 + ( Fix1(..) + , Fix1T(..) + , MonadFix1T + ) +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. -- https://gist.github.com/gmalecha/ceb3778b9fdaa4374976e325ac8feced newtype Fix1 (t :: (k -> Type) -> k -> Type) (a :: k) = Fix1 { unFix1 :: t (Fix1 t) a } +deriving instance Generic (Fix1 t a) deriving instance Functor (t (Fix1 t)) => Functor (Fix1 t) deriving instance Applicative (t (Fix1 t)) @@ -47,6 +55,7 @@ newtype Fix1T (t :: (k -> Type) -> (Type -> Type) -> k -> Type) (m :: Type -> Type) (a :: k) = Fix1T { unFix1T :: t (Fix1T t m) m a } +deriving instance Generic (Fix1T t m m) deriving instance Functor (t (Fix1T t m) m) => Functor (Fix1T t m) deriving instance Applicative (t (Fix1T t m) m) @@ -87,9 +96,11 @@ type Ref (Fix1T t m) = Ref m newRef = lift . newRef + {-# inline newRef #-} readRef = lift . readRef + {-# inline readRef #-} writeRef r = lift . writeRef r - + {-# inline writeRef #-} instance ( MonadFix1T t m @@ -98,13 +109,16 @@ => MonadAtomicRef (Fix1T t m) where atomicModifyRef r = lift . atomicModifyRef r + {-# inline atomicModifyRef #-} {- newtype Flip (f :: i -> j -> *) (a :: j) (b :: i) = Flip { unFlip :: f b a } --- | Natural Transformations (Included from --- [compdata](https://hackage.haskell.org/package/compdata)) +-- | Natural Transformations +-- ( Included from +-- [compdata](https://hackage.haskell.org/package/compdata) +-- ) type (:->) f g = forall a. f a -> g a class HFunctor f where diff --git a/src/Nix/Value.hs b/src/Nix/Value.hs --- a/src/Nix/Value.hs +++ b/src/Nix/Value.hs @@ -1,22 +1,19 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} +{-# language CPP #-} +{-# language DeriveAnyClass #-} +{-# language KindSignatures #-} +{-# language ConstraintKinds #-} +{-# language PatternSynonyms #-} +{-# language RankNTypes #-} +{-# language TemplateHaskell #-} -{-# OPTIONS_GHC -Wno-missing-signatures #-} -{-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-} +{-# options_ghc -Wno-missing-signatures #-} +{-# options_ghc -Wno-missing-pattern-synonym-signatures #-} -- | The core of the type system, Nix language values module Nix.Value where -import Prelude hiding ( force ) -import Nix.Utils +import Nix.Prelude import Control.Comonad ( Comonad , extract ) @@ -30,19 +27,17 @@ , liftShowsPrec , showsUnaryWith , Eq1(liftEq) ) -import Data.Eq.Deriving import qualified Text.Show import Text.Show ( showsPrec , showString , showParen ) -import Lens.Family2.Stock ( _1 ) +import Lens.Family2.Stock ( _2 ) import Lens.Family2.TH ( makeTraversals , makeLenses ) import Nix.Atoms import Nix.Expr.Types -import Nix.Expr.Types.Annotated import Nix.String import Nix.Thunk @@ -118,14 +113,13 @@ -- | A string has a value and a context, which can be used to record what a -- string has been build from | NVStrF NixString - | NVPathF FilePath + | NVPathF Path | NVListF [r] - -- 2021-05-22: NOTE: Please flip this and dependent functions. - -- Quite frequently actions/processing happens with values - -- (for example - forcing of values & recreation of the monad), - -- but SourcePos does not change then - -- That would be good to flip all 'AttrSet.* AttrSet SourcePos' - | NVSetF (AttrSet r) (AttrSet SourcePos) + | NVSetF PositionSet (AttrSet r) + -- ^ + -- Quite frequently actions/processing happens with values + -- (for example - forcing of values & recreation of the monad), + -- but @SourcePos@ does not change then. | NVClosureF (Params ()) (p -> m r) -- ^ A function is a closed set of parameters representing the "call -- signature", used at application time to check the type of arguments @@ -138,39 +132,47 @@ -- Note that 'm r' is being used here because effectively a function -- and its set of default arguments is "never fully evaluated". This -- enforces in the type that it must be re-evaluated for each call. - | NVBuiltinF Text (p -> m r) + | NVBuiltinF VarName (p -> m r) -- ^ A builtin function is itself already in normal form. Also, it may -- or may not choose to evaluate its argument in the production of a -- result. deriving (Generic, Typeable, Functor) +-- ** Eq + +instance Eq r => Eq (NValueF p m r) where + (==) (NVConstantF x) (NVConstantF y) = x == y + (==) (NVStrF x) (NVStrF y) = x == y + (==) (NVPathF x) (NVPathF y) = x == y + (==) (NVListF x) (NVListF y) = x == y + (==) (NVSetF _ x) (NVSetF _ y) = x == y + (==) _ _ = False + -- ** Eq1 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 eq (NVSetF _ x) (NVSetF _ y) = liftEq eq 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 + (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 @@ -184,10 +186,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 @@ -203,11 +205,7 @@ NVStrF s -> pure $ NVStrF s NVPathF p -> pure $ NVPathF p NVListF l -> NVListF <$> sequenceA l - NVSetF s p -> - liftA2 - NVSetF - (sequenceA s) - (pure p) + NVSetF p s -> NVSetF p <$> sequenceA s NVClosureF p g -> pure $ NVClosureF p (transform <=< g) NVBuiltinF s g -> pure $ NVBuiltinF s (transform <=< g) @@ -217,20 +215,16 @@ -- | @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 NVPathF p -> pure $ NVPathF p NVListF l -> NVListF <$> traverse f l - NVSetF s p -> - liftA2 - NVSetF - (traverse f s) - (pure p) + NVSetF p s -> NVSetF p <$> traverse f s NVClosureF p g -> pure $ NVClosureF p (transform . f <=< g) NVBuiltinF s g -> pure $ NVBuiltinF s (transform . f <=< g) @@ -268,19 +262,25 @@ -- , NVStrF s -- , NVPathF p -- , NVListF l - -- , NVSetF s p + -- , NVSetF p s -- ] NVConstantF a -> NVConstantF a NVStrF s -> NVStrF s NVPathF p -> NVPathF p NVListF l -> NVListF l - NVSetF s p -> NVSetF s p + NVSetF p s -> NVSetF p s NVBuiltinF s g -> NVBuiltinF s (lft . g) NVClosureF p g -> NVClosureF p (lft . g) {-# inline hoistNValueF #-} -- * @__NValue'__@: forming the (F(A)) +-- | NVConstraint constraint the f layer in @NValue'@. +-- It makes bijection between sub category of Hask and Nix Value possible. +-- 'Comonad' enable Nix Value to Hask part. +-- 'Applicative' enable Hask to Nix Value part. +type NVConstraint f = (Comonad f, Applicative f) + -- | At the time of constructor, the expected arguments to closures are values -- that may contain thunks. The type of such thunks are fixed at that time. newtype NValue' t f m a = @@ -291,22 +291,21 @@ } deriving (Generic, Typeable, Functor, Foldable) -instance (Comonad f, Show a) => Show (NValue' t f m a) where +instance (NVConstraint f, Show a) => Show (NValue' t f m a) where show (NValue' (extract -> v)) = show v -- ** Show1 -instance Comonad f => Show1 (NValue' t f m) where +instance NVConstraint 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 @@ -330,7 +329,7 @@ NVStrF s -> NVStrF s NVPathF p -> NVPathF p NVListF l -> NVListF l - NVSetF s p -> NVSetF s p + NVSetF p s -> NVSetF p s NVClosureF p g -> NVClosureF p (g . f) NVBuiltinF s g -> NVBuiltinF s (g . f) @@ -341,11 +340,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 @@ -357,7 +356,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 @@ -394,10 +393,9 @@ -- ** Bijective Hask subcategory <-> @NValue'@ --- *** @F: Hask subcategory → NValue'@ --- +-- *** @F: Hask subcategory <-> NValue'@ -- #mantra# --- $Methods @F: Hask → NValue'@ +-- $Patterns @F: Hask <-> NValue'@ -- -- Since Haskell and Nix are both recursive purely functional lazy languages. -- And since recursion-schemes. @@ -412,83 +410,57 @@ -- Since it is a proper way of scientific implementation, we would eventually form a -- lawful functor. -- --- Facts of which are seen below: +-- Module pattens use @language PatternSynonyms@: bidirectional synonyms (@<-@), +-- and @ViewPatterns@: (@->@) at the same time. +-- @ViewPatterns Control.Comonad.extract@ extracts +-- from the @NValue (Free (NValueF a))@ +-- the @NValueF a@. Which is @NValueF p m r@. Since it extracted from the +-- @NValue@, which is formed by \( (F a -> a) F a \) in the first place. +-- So @NValueF p m r@ which is extracted here, internally holds the next NValue. +-- +-- Facts of bijection between Hask subcategory objects and Nix objects, +-- and between Hask subcategory morphisms and Nix morphisms are seen blow: --- | Haskell constant to the Nix constant, -nvConstant' :: Applicative f - => NAtom - -> NValue' t f m r -nvConstant' = NValue' . pure . NVConstantF +-- | Using of Nulls is generally discouraged (in programming language design et al.), but, if you need it. +pattern NVNull' :: NVConstraint w => NValue' t w m a +pattern NVNull' = NVConstant' NNull +-- | Haskell constant to the Nix constant, +pattern NVConstant' :: NVConstraint w => NAtom -> NValue' t w m a +pattern NVConstant' x <- NValue' (extract -> NVConstantF x) + where NVConstant' = NValue' . pure . NVConstantF -- | Haskell text & context to the Nix text & context, -nvStr' :: Applicative f - => NixString - -> NValue' t f m r -nvStr' = NValue' . pure . NVStrF - - --- | Haskell @FilePath@ to the Nix path, -nvPath' :: Applicative f - => FilePath - -> NValue' t f m r -nvPath' = NValue' . pure . NVPathF +pattern NVStr' :: NVConstraint w => NixString -> NValue' t w m a +pattern NVStr' ns <- NValue' (extract -> NVStrF ns) + where NVStr' = NValue' . pure . NVStrF +-- | Haskell @Path@ to the Nix path, +pattern NVPath' :: NVConstraint w => Path -> NValue' t w m a +pattern NVPath' x <- NValue' (extract -> NVPathF x) + where NVPath' = NValue' . pure . NVPathF . coerce -- | Haskell @[]@ to the Nix @[]@, -nvList' :: Applicative f - => [r] - -> NValue' t f m r -nvList' = NValue' . pure . NVListF - +pattern NVList' :: NVConstraint w => [a] -> NValue' t w m a +pattern NVList' l <- NValue' (extract -> NVListF l) + where NVList' = NValue' . pure . NVListF -- | Haskell key-value to the Nix key-value, -nvSet' :: Applicative f - => AttrSet SourcePos - -> AttrSet r - -> NValue' t f m r -nvSet' x s = NValue' $ pure $ NVSetF s x - +pattern NVSet' :: NVConstraint w => PositionSet -> AttrSet a -> NValue' t w m a +pattern NVSet' p s <- NValue' (extract -> NVSetF p s) + where NVSet' p s = NValue' $ pure $ NVSetF p s -- | Haskell closure to the Nix closure, -nvClosure' :: (Applicative f, Functor m) - => Params () - -> (NValue t f m - -> m r - ) - -> NValue' t f m r -nvClosure' x f = NValue' $ pure $ NVClosureF x f - +pattern NVClosure' :: NVConstraint w => Params () -> (NValue t w m -> m a) -> NValue' t w m a +pattern NVClosure' x f <- NValue' (extract -> NVClosureF x f) + where NVClosure' x f = NValue' $ pure $ NVClosureF x f -- | Haskell functions to the Nix functions! -nvBuiltin' :: (Applicative f, Functor m) - => Text - -> (NValue t f m -> m r) - -> NValue' t f m r -nvBuiltin' name f = NValue' $ pure $ NVBuiltinF name f - - --- So above we have maps of Hask subcategory objects to Nix objects, --- and Hask subcategory morphisms to Nix morphisms. - --- *** @F: NValue -> NValue'@ - --- | Module pattens use @language PatternSynonyms@: unidirectional synonyms (@<-@), --- and @ViewPatterns@: (@->@) at the same time. --- @ViewPatterns Control.Comonad.extract@ extracts --- from the @NValue (Free (NValueF a))@ --- the @NValueF a@. Which is @NValueF p m r@. Since it extracted from the --- @NValue@, which is formed by \( (F a -> a) F a \) in the first place. --- So @NValueF p m r@ which is extracted here, internally holds the next NValue. -pattern NVConstant' x <- NValue' (extract -> NVConstantF x) -pattern NVStr' ns <- NValue' (extract -> NVStrF ns) -pattern NVPath' x <- NValue' (extract -> NVPathF x) -pattern NVList' l <- NValue' (extract -> NVListF l) -pattern NVSet' s x <- NValue' (extract -> NVSetF s x) -pattern NVClosure' x f <- NValue' (extract -> NVClosureF x f) +pattern NVBuiltin' :: NVConstraint w => VarName -> (NValue t w m -> m a) -> NValue' t w m a pattern NVBuiltin' name f <- NValue' (extract -> NVBuiltinF name f) -{-# COMPLETE NVConstant', NVStr', NVPath', NVList', NVSet', NVClosure', NVBuiltin' #-} + where NVBuiltin' name f = NValue' $ pure $ NVBuiltinF name f +{-# complete NVConstant', NVStr', NVPath', NVList', NVSet', NVClosure', NVBuiltin' #-} -- * @__NValue__@: Nix language values @@ -517,19 +489,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@ @@ -540,10 +512,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 @@ -566,7 +537,7 @@ => (forall x . u m x -> m x) -> NValue t f m -> NValue t f (u m) -liftNValue run = hoistNValue run lift +liftNValue f = hoistNValue f lift -- *** MonadTransUnlift @@ -586,140 +557,95 @@ -- The morphisms of the functor @Hask → NValue@. -- Continuation of the mantra: "Nix.Value#mantra" - --- | Life of a Haskell thunk to the life of a Nix thunk, -nvThunk :: Applicative f - => t - -> NValue t f m -nvThunk = Pure - - --- | Life of a Haskell constant to the life of a Nix constant, -nvConstant :: Applicative f - => NAtom - -> NValue t f m -nvConstant = Free . nvConstant' - - --- | Life of a Haskell sting & context to the life of a Nix string & context, -nvStr :: Applicative f - => NixString - -> NValue t f m -nvStr = Free . nvStr' +-- | Using of Nulls is generally discouraged (in programming language design et al.), but, if you need it. -nvStrWithoutContext :: Applicative f +mkNVStrWithoutContext :: NVConstraint f => Text -> NValue t f m -nvStrWithoutContext = nvStr . makeNixStringWithoutContext - - --- | Life of a Haskell FilePath to the life of a Nix path -nvPath :: Applicative f - => FilePath - -> NValue t f m -nvPath = Free . nvPath' - - -nvList :: Applicative f - => [NValue t f m] - -> NValue t f m -nvList = Free . nvList' - - -nvSet :: Applicative f - => AttrSet SourcePos - -> AttrSet (NValue t f m) - -> NValue t f m -nvSet x s = Free $ nvSet' x s - - -nvClosure :: (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 - - -nvBuiltin :: (Applicative f, Functor m) - => Text - -> (NValue t f m - -> m (NValue t f m) - ) - -> NValue t f m -nvBuiltin name f = Free $ nvBuiltin' name f +mkNVStrWithoutContext = NVStr . mkNixStringWithoutContext builtin :: forall m f t . (MonadThunk t m (NValue t f m), MonadDataContext f m) - => Text + => 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 .) . NVBuiltin builtin2 :: (MonadThunk t m (NValue t f m), MonadDataContext f m) - => Text + => 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) - => Text + => 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@ -pattern NVThunk t <- Pure t -pattern NVValue v <- Free v -{-# COMPLETE NVThunk, NVValue #-} -pattern NVConstant x <- Free (NVConstant' x) -pattern NVStr ns <- Free (NVStr' ns) -pattern NVPath x <- Free (NVPath' x) -pattern NVList l <- Free (NVList' l) -pattern NVSet s x <- Free (NVSet' s x) -pattern NVClosure x f <- Free (NVClosure' x f) -pattern NVBuiltin name f <- Free (NVBuiltin' name f) -{-# COMPLETE NVThunk, NVConstant, NVStr, NVPath, NVList, NVSet, NVClosure, NVBuiltin #-} +pattern NVNull = Free NVNull' +pattern NVThunk t = Pure t +pattern NVValue v = Free v +{-# complete NVThunk, NVValue, NVNull #-} +pattern NVConstant x = Free (NVConstant' x) +pattern NVStr ns = Free (NVStr' ns) +pattern NVPath x = Free (NVPath' x) +pattern NVList l = Free (NVList' l) +pattern NVSet s x = Free (NVSet' s x) +pattern NVBuiltin name f = Free (NVBuiltin' name f) +pattern NVClosure x f = Free (NVClosure' x f) +{-# complete NVThunk, NVConstant, NVStr, NVPath, NVList, NVSet, NVClosure, NVBuiltin #-} + -- * @TStringContext@ data TStringContext = NoContext | HasContext - deriving Show + deriving Show +instance Semigroup TStringContext where + (<>) NoContext NoContext = NoContext + (<>) _ _ = HasContext + + +instance Monoid TStringContext where + mempty = NoContext + -- * @ValueType@ data ValueType - = TInt - | TFloat - | TBool - | TNull - | TString TStringContext - | TList - | TSet - | TClosure - | TPath - | TBuiltin - deriving Show + = TInt + | TFloat + | TBool + | TNull + | TString TStringContext + | TList + | TSet + | TClosure + | TPath + | TBuiltin + deriving Show -- | Determine type of a value @@ -728,17 +654,14 @@ \case NVConstantF a -> case a of - NURI _ -> TString NoContext + NURI _ -> TString mempty NInt _ -> TInt NFloat _ -> TFloat NBool _ -> TBool NNull -> TNull NVStrF ns -> TString $ - bool - NoContext - HasContext - (stringHasContext ns) + HasContext `whenTrue` hasContext ns NVListF{} -> TList NVSetF{} -> TSet NVClosureF{} -> TClosure @@ -754,8 +677,8 @@ TFloat -> "a float" TBool -> "a boolean" TNull -> "a null" - TString NoContext -> "a string" - TString HasContext -> "a string with context" + TString NoContext -> "a string with no context" + TString HasContext -> "a string" TList -> "a list" TSet -> "an attr set" TClosure -> "a function" @@ -774,19 +697,19 @@ -- * @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) +deriving instance (NVConstraint f, Show t) => Show (ValueFrame t f m) -- * @MonadDataContext@ @@ -801,13 +724,20 @@ instance MonadDataErrorContext t f m => Exception (ValueFrame t f m) + +-- * @instance Eq NValue'@ + +instance (Eq a, Comonad f) => Eq (NValue' t f m a) where + (==) (NValue' (extract -> x)) (NValue' (extract -> y)) = x == y + -- * @instance Eq1 NValue'@ -- TH derivable works only after MonadDataContext -$(deriveEq1 ''NValue') +instance Comonad f => Eq1 (NValue' t f m) where + liftEq eq (NValue' (extract -> x)) (NValue' (extract -> y)) = liftEq eq x y --- * @NValue'@ traversals, getter & setters +-- * @NValueF@ traversals, getter & setters -- | Make traversals for Nix traversable structures. $(makeTraversals ''NValueF) @@ -822,4 +752,4 @@ :: (Traversable f, Applicative g) => VarName -> LensLike' g (NValue' t f m a) (Maybe a) -key k = nValue . traverse . _NVSetF . _1 . hashAt k +key k = nValue . traverse . _NVSetF . _2 . hashAt k 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 @@ -1,17 +1,12 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} +{-# language AllowAmbiguousTypes #-} +{-# language ConstraintKinds #-} +{-# language TypeFamilies #-} -{-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-} +{-# options_ghc -Wno-missing-pattern-synonym-signatures #-} module Nix.Value.Equal where -import Prelude hiding ( Comparison - , force - ) -import Nix.Utils +import Nix.Prelude hiding ( Comparison ) import Control.Comonad ( Comonad(extract)) import Control.Monad.Free ( Free(Pure,Free) ) import Control.Monad.Trans.Except ( throwE ) @@ -25,6 +20,7 @@ import Nix.String import Nix.Thunk import Nix.Value +import Nix.Expr.Types ( AttrSet ) checkComparable :: ( Framed e m @@ -35,12 +31,12 @@ -> m () checkComparable x y = case (x, y) of - (NVConstant (NFloat _), NVConstant (NInt _)) -> pass - (NVConstant (NInt _), NVConstant (NFloat _)) -> pass - (NVConstant (NInt _), NVConstant (NInt _)) -> pass - (NVConstant (NFloat _), NVConstant (NFloat _)) -> pass - (NVStr _ , NVStr _ ) -> pass - (NVPath _ , NVPath _ ) -> pass + (NVConstant (NInt _), NVConstant (NInt _)) -> stub + (NVConstant (NInt _), NVConstant (NFloat _)) -> stub + (NVConstant (NFloat _), NVConstant (NInt _)) -> stub + (NVConstant (NFloat _), NVConstant (NFloat _)) -> stub + (NVStr _ , NVStr _ ) -> stub + (NVPath _ , NVPath _ ) -> stub _ -> throwError $ Comparison x y -- | Checks whether two containers are equal, using the given item equality @@ -54,20 +50,20 @@ -> 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 @@ -78,17 +74,14 @@ -> m Bool isDerivationM f m = maybe - (pure False) - (\ t -> - maybe - -- We should probably really make sure the context is empty here - -- but the C++ implementation ignores it. - False - ((==) "derivation" . stringIgnoreContext) - <$> f t - ) - (HashMap.Lazy.lookup "type" m) + False + -- (2019-03-18): + -- We should probably really make sure the context is empty here + -- but the C++ implementation ignores it. + ((==) "derivation" . ignoreContext) + . join <$> traverse f (HashMap.Lazy.lookup "type" m) + isDerivation :: Monad m => ( t @@ -117,9 +110,9 @@ (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 + (NVSetF _ lm , NVSetF _ rm ) -> attrsEq lm rm (NVPathF lp , NVPathF rp ) -> pure $ lp == rp _ -> pure False @@ -132,8 +125,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 @@ -145,21 +138,14 @@ -> AttrSet t -> m Bool compareAttrSetsM f eq lm rm = - do - l <- isDerivationM f lm - bool - compareAttrs - (do - r <- isDerivationM f rm - case r of - True - | Just lp <- HashMap.Lazy.lookup "outPath" lm, - Just rp <- HashMap.Lazy.lookup "outPath" rm -> eq lp rp - _ -> compareAttrs - ) - l + bool + compareAttrs + (fromMaybe compareAttrs equalOutPaths) + =<< areDerivations where - compareAttrs = alignEqM eq lm rm + areDerivations = on (liftA2 (&&)) (isDerivationM f ) lm rm + equalOutPaths = on (liftA2 eq) (HashMap.Lazy.lookup "outPath") lm rm + compareAttrs = alignEqM eq lm rm compareAttrSets :: (t -> Maybe NixString) @@ -167,11 +153,12 @@ -> AttrSet t -> AttrSet t -> Bool -compareAttrSets f eq lm rm = runIdentity - $ compareAttrSetsM (Identity . f) (\x y -> Identity $ eq x y) lm rm +compareAttrSets f eq lm rm = + runIdentity $ compareAttrSetsM (Identity . f) ((Identity .) . eq) lm rm valueEqM - :: (MonadThunk t m (NValue t f m), Comonad f) + :: forall t f m + . (MonadThunk t m (NValue t f m), NVConstraint f) => NValue t f m -> NValue t f m -> m Bool @@ -180,12 +167,13 @@ valueEqM x@(Free _) ( Pure y) = (`thunkEqM` y) =<< thunk (pure x) valueEqM (Free (NValue' (extract -> x))) (Free (NValue' (extract -> y))) = valueFEqM - (compareAttrSetsM f valueEqM) + (compareAttrSetsM findNVStr valueEqM) valueEqM x y where - f = + findNVStr :: NValue t f m -> m (Maybe NixString) + findNVStr = free (pure . (\case @@ -199,7 +187,9 @@ _ -> mempty ) -thunkEqM :: (MonadThunk t m (NValue t f m), Comonad f) => t -> t -> m Bool +-- This function has mutual recursion with `valueEqM`, and this function so far is not used across the project, +-- but that one is. +thunkEqM :: (MonadThunk t m (NValue t f m), NVConstraint f) => t -> t -> m Bool thunkEqM lt rt = do lv <- force lt @@ -207,9 +197,10 @@ let unsafePtrEq = - case (lt, rt) of - (thunkId -> lid, thunkId -> rid) | lid == rid -> pure True - _ -> valueEqM lv rv + bool + (valueEqM lv rv) + (pure True) + $ on (==) thunkId lt rt case (lv, rv) of (NVClosure _ _, NVClosure _ _) -> unsafePtrEq 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 @@ -1,13 +1,13 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# language AllowAmbiguousTypes #-} +{-# language ConstraintKinds #-} -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -Wno-unused-top-binds #-} +{-# options_ghc -Wno-orphans #-} +{-# options_ghc -Wno-unused-top-binds #-} 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,9 +1,8 @@ -{-# LANGUAGE ScopedTypeVariables #-} - module Nix.XML ( toXML ) where +import Nix.Prelude import qualified Data.HashMap.Lazy as M import Nix.Atoms import Nix.Expr.Types @@ -21,13 +20,14 @@ where cyc = pure $ mkEVal "string" "" + pp :: Element -> Text pp e = heading - <> toText + <> fromString (ppElement $ mkE "expr" - [Elem e] + (one $ Elem e) ) <> "\n" where @@ -38,80 +38,73 @@ NVConstant' a -> pure $ case a of - NURI t -> mkEVal "string" $ toString t + NURI t -> mkEVal "string" t NInt n -> mkEVal "int" $ show n NFloat f -> mkEVal "float" $ show f NBool b -> mkEVal "bool" $ if b then "true" else "false" NNull -> mkE "null" mempty NVStr' str -> - mkEVal "string" . toString <$> extractNixString str + mkEVal "string" <$> extractNixString str NVList' l -> - do - els <- sequence l - pure $ - mkE - "list" - (Elem <$> els) + mkE "list" . fmap Elem <$> sequenceA l - NVSet' s _ -> - do - kvs <- sequence s - pure $ - mkE - "attrs" - ((\ (k, v) -> - Elem $ - Element - (unqual "attr") - [Attr (unqual "name") (toString k)] - [Elem v] - Nothing - ) <$> - sortWith fst (M.toList kvs) - ) + NVSet' _ s -> + mkE + "attrs" + . fmap + mkElem' + . sortWith fst . M.toList + <$> sequenceA s + where + mkElem' :: (VarName, Element) -> Content + mkElem' (k, v) = + Elem $ + Element + (unqual "attr") + (one $ Attr (unqual "name") $ toString k) + (one $ Elem v) + Nothing NVClosure' p _ -> pure $ mkE "function" (paramsXML p) - NVPath' fp -> pure $ mkEVal "path" fp - NVBuiltin' name _ -> pure $ mkEName "function" $ toString name + NVPath' fp -> pure $ mkEVal "path" $ fromString $ coerce fp + NVBuiltin' name _ -> pure $ mkEName "function" name -mkE :: String -> [Content] -> Element -mkE n c = +mkE :: Text -> [Content] -> Element +mkE (toString -> n) c = Element (unqual n) mempty c Nothing -mkElem :: String -> String -> String -> Element -mkElem n a v = +mkElem :: Text -> Text -> Text -> Element +mkElem (toString -> n) (toString -> a) (toString -> v) = Element (unqual n) - [Attr (unqual a) v] + (one $ Attr (unqual a) v) mempty Nothing -mkEVal :: String -> String -> Element +mkEVal :: Text -> Text -> Element mkEVal = (`mkElem` "value") -mkEName :: String -> String -> Element -mkEName = (`mkElem` "name") +mkEName :: Text -> VarName -> Element +mkEName x (coerce -> y) = (`mkElem` "name") x y paramsXML :: Params r -> [Content] -paramsXML (Param name) = [Elem $ mkEName "varpat" (toString name)] -paramsXML (ParamSet s b mname) = - [Elem $ Element (unqual "attrspat") (battr <> nattr) (paramSetXML s) Nothing] +paramsXML (Param name) = one $ Elem $ mkEName "varpat" name +paramsXML (ParamSet mname variadic pset) = + one $ Elem $ Element (unqual "attrspat") (battr <> nattr) (paramSetXML pset) Nothing where - battr = [ Attr (unqual "ellipsis") "1" | b ] + battr = + one (Attr (unqual "ellipsis") "1") `whenTrue` (variadic == Variadic) nattr = - maybe - mempty - ((: mempty) . Attr (unqual "name") . toString) - mname + (one . Attr (unqual "name") . toString) `whenJust` mname paramSetXML :: ParamSet r -> [Content] -paramSetXML = fmap (\(k, _) -> Elem $ mkEName "attr" (toString k)) +paramSetXML = fmap (Elem . mkEName "attr" . fst) diff --git a/tests/EvalTests.hs b/tests/EvalTests.hs --- a/tests/EvalTests.hs +++ b/tests/EvalTests.hs @@ -1,13 +1,15 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} +{-# language QuasiQuotes #-} +{-# language TemplateHaskell #-} -{-# OPTIONS_GHC -Wno-missing-signatures #-} +{-# options_ghc -Wno-missing-signatures #-} -module EvalTests (tests, genEvalCompareTests) where +module EvalTests + ( tests + , genEvalCompareTests + ) where -import Prelude hiding (lookupEnv) +import Nix.Prelude import Control.Monad.Catch import Data.List ((\\)) import qualified Data.Set as S @@ -15,138 +17,190 @@ import NeatInterpolation (text) import Nix import Nix.Standard -import Nix.TH import Nix.Value.Equal -import Nix.Utils import qualified System.Directory as D -import System.Environment (lookupEnv) -import System.FilePath import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.TH import TestCommon case_basic_sum = - constantEqualText "2" "1 + 1" + constantEqualText + "2" + "1 + 1" case_basic_div = - constantEqualText "3" "builtins.div 6 2" + constantEqualText + "3" + "builtins.div 6 2" -case_zero_div = do - assertNixEvalThrows "builtins.div 1 0" - assertNixEvalThrows "builtins.div 1.0 0" - assertNixEvalThrows "builtins.div 1 0.0" - assertNixEvalThrows "builtins.div 1.0 0.0" +case_zero_div = + traverse_ assertNixEvalThrows + [ "builtins.div 1 0" + , "builtins.div 1.0 0" + , "builtins.div 1 0.0" + , "builtins.div 1.0 0.0" + ] -case_bit_ops = do - -- mic92 (2018-08-20): change to constantEqualText, - -- when hnix's nix fork supports bitAnd/bitOr/bitXor - constantEqualText' "0" "builtins.bitAnd 1 0" - constantEqualText' "1" "builtins.bitOr 1 1" - constantEqualText' "3" "builtins.bitXor 1 2" +case_bit_ops = + traverse_ (uncurry constantEqualText) + [ ("0", "builtins.bitAnd 1 0") + , ("1", "builtins.bitOr 1 1") + , ("3", "builtins.bitXor 1 2") + ] case_basic_function = - constantEqualText "2" "(a: a) 2" + constantEqualText + "2" + "(a: a) 2" case_set_attr = - constantEqualText "2" "{ a = 2; }.a" + constantEqualText + "2" + "{ a = 2; }.a" case_function_set_arg = - constantEqualText "2" "({ a }: 2) { a = 1; }" + constantEqualText + "2" + "({ a }: 2) { a = 1; }" case_function_set_two_arg = - constantEqualText "2" "({ a, b ? 3 }: b - a) { a = 1; }" + constantEqualText + "2" + "({ a, b ? 3 }: b - a) { a = 1; }" case_function_set_two_arg_default_scope = - constantEqualText "2" "({ x ? 1, y ? x * 3 }: y - x) {}" + constantEqualText + "2" + "({ x ? 1, y ? x * 3 }: y - x) {}" case_function_default_env = - constantEqualText "2" "let default = 2; in ({ a ? default }: a) {}" + constantEqualText + "2" + "let default = 2; in ({ a ? default }: a) {}" case_function_definition_uses_environment = - constantEqualText "3" "let f = (let a=1; in x: x+a); in f 2" + constantEqualText + "3" + "let f = (let a=1; in x: x+a); in f 2" case_function_atpattern = - -- jww (2018-05-09): This should be constantEqualText - constantEqualText' "2" "(({a}@attrs:attrs) {a=2;}).a" + -- jww (2018-05-09): This should be constantEqualText + constantEqualText' + "2" + "(({a}@attrs:attrs) {a=2;}).a" case_function_ellipsis = - -- jww (2018-05-09): This should be constantEqualText - constantEqualText' "2" "(({a, ...}@attrs:attrs) {a=0; b=2;}).b" + -- jww (2018-05-09): This should be constantEqualText + constantEqualText' + "2" + "(({a, ...}@attrs:attrs) {a=0; b=2;}).b" case_function_default_value_not_in_atpattern = - constantEqualText "false" "({a ? 2}@attrs: attrs ? a) {}" + constantEqualText + "false" + "({a ? 2}@attrs: attrs ? a) {}" case_function_arg_shadowing = - constantEqualText "6" "(y: y: x: x: x + y) 1 2 3 4" + constantEqualText + "6" + "(y: y: x: x: x + y) 1 2 3 4" case_function_recursive_args = - constantEqualText "2" "({ x ? 1, y ? x * 3}: y - x) {}" + constantEqualText + "2" + "({ x ? 1, y ? x * 3}: y - x) {}" case_function_recursive_sets = - constantEqualText "[ [ 6 4 100 ] 4 ]" [text| - let x = rec { + constantEqualText + "[ [ 6 4 100 ] 4 ]" + [text| + let x = rec { - y = 2; - z = { w = 4; }; - v = rec { - u = 6; - t = [ u z.w s ]; - }; + y = 2; + z = { w = 4; }; + v = rec { + u = 6; + t = [ u z.w s ]; + }; - }; s = 100; in [ x.v.t x.z.w ] + }; s = 100; in [ x.v.t x.z.w ] |] case_nested_with = - constantEqualText "2" "with { x = 1; }; with { x = 2; }; x" + constantEqualText + "2" + "with { x = 1; }; with { x = 2; }; x" case_with_strictness = - constantEqualText "5" "let x = with x; with { a = 5; }; a; in x" + constantEqualText + "5" + "let x = with x; with { a = 5; }; a; in x" case_match_failure_null = - constantEqualText "null" "builtins.match \"ab\" \"abc\"" + constantEqualText + "null" + "builtins.match \"ab\" \"abc\"" case_find_file_success_no_prefix = - constantEqualText "./tests/files/findFile.nix" - "builtins.findFile [{ path=\"./tests/files\"; prefix=\"\"; }] \"findFile.nix\"" + constantEqualText + "./tests/files/findFile.nix" + "builtins.findFile [{ path=\"./tests/files\"; prefix=\"\"; }] \"findFile.nix\"" case_find_file_success_with_prefix = - constantEqualText "./tests/files/findFile.nix" - "builtins.findFile [{ path=\"./tests/files\"; prefix=\"nix\"; }] \"nix/findFile.nix\"" + constantEqualText + "./tests/files/findFile.nix" + "builtins.findFile [{ path=\"./tests/files\"; prefix=\"nix\"; }] \"nix/findFile.nix\"" case_find_file_success_folder = - constantEqualText "./tests/files" - "builtins.findFile [{ path=\"./tests\"; prefix=\"\"; }] \"files\"" + constantEqualText + "./tests/files" + "builtins.findFile [{ path=\"./tests\"; prefix=\"\"; }] \"files\"" case_find_file_failure_not_found = - assertNixEvalThrows "builtins.findFile [{ path=\"./tests/files\"; prefix=\"\"; }] \"not_found.nix\"" + assertNixEvalThrows + "builtins.findFile [{ path=\"./tests/files\"; prefix=\"\"; }] \"not_found.nix\"" case_find_file_failure_invalid_arg_1 = - assertNixEvalThrows "builtins.findFile 1 \"files\"" + assertNixEvalThrows + "builtins.findFile 1 \"files\"" case_find_file_failure_invalid_arg_2 = - assertNixEvalThrows "builtins.findFile [{ path=\"./tests/files\"; prefix=\"\"; }] 2" + assertNixEvalThrows + "builtins.findFile [{ path=\"./tests/files\"; prefix=\"\"; }] 2" case_find_file_failure_invalid_arg_no_path = - assertNixEvalThrows "builtins.findFile [{ prefix=\"\"; }] \"files\"" + assertNixEvalThrows + "builtins.findFile [{ prefix=\"\"; }] \"files\"" case_infinite_recursion = - assertNixEvalThrows "let foo = a: bar a; bar = a: foo a; in foo 3" + assertNixEvalThrows + "let foo = a: bar a; bar = a: foo a; in foo 3" case_nested_let = - constantEqualText "3" "let a = 3; x.x = 2; in a" + constantEqualText + "3" + "let a = 3; x.x = 2; in a" case_nested_nested_let = - constantEqualText "3" "let a = 3; x.x = let b = a; in b; c = x.x; in c" + constantEqualText + "3" + "let a = 3; x.x = let b = a; in b; c = x.x; in c" case_inherit_in_rec_set = - constantEqualText "1" "let x = 1; in (rec { inherit x; }).x" + constantEqualText + "1" + "let x = 1; in (rec { inherit x; }).x" case_lang_version = - constantEqualText "5" "builtins.langVersion" + constantEqualText + "5" + "builtins.langVersion" case_rec_set_attr_path_simpl = - constantEqualText "123" [text| + constantEqualText + "123" + [text| let x = rec { foo.number = 123; foo.function = y: foo.number; @@ -154,7 +208,9 @@ |] case_inherit_from_set_has_no_scope = - constantEqualText' "false" [text| + constantEqualText' + "false" + [text| (builtins.tryEval ( let x = 1; y = { z = 2; }; @@ -163,7 +219,7 @@ |] -- github/orblivion (2018-08-05): Adding these failing tests so we fix this feature - +-- -- case_overrides = -- constantEqualText' "2" [text| -- let @@ -190,171 +246,198 @@ -- }.__overrides.a) -- |] -case_unsafegetattrpos1 = - constantEqualText "[ 5 14 ]" [text| - let e = 1; - f = 1; - t = {}; - s = { - inherit t e f; - a = 1; - "b" = 2; - c.d = 3; - }; - p = builtins.unsafeGetAttrPos "e" s; in - [ p.line p.column ] - |] +case_unsafegetattrpos = + traverse_ (uncurry constantEqualText) + [ ( "[ 5 14 ]" + , [text| + let e = 1; + f = 1; + t = {}; + s = { + inherit t e f; + a = 1; + "b" = 2; + c.d = 3; + }; + p = builtins.unsafeGetAttrPos "e" s; in + [ p.line p.column ] + |] + ) + , ( "[ 5 14 ]" + , [text| + let e = 1; + f = 1; + t = {}; + s = { + inherit t e f; + a = 1; + "b" = 2; + c.d = 3; + }; + p = builtins.unsafeGetAttrPos "f" s; in + [ p.line p.column ] + |] + ) + , ( "[ 6 7 ]" + , [text| + let e = 1; + f = 1; + t = {}; + s = { + inherit t e f; + a = 1; + "b" = 2; + c.d = 3; + }; + p = builtins.unsafeGetAttrPos "a" s; in + [ p.line p.column ] + |] + ) + , ( "[ 7 7 ]" + , [text| + let e = 1; + f = 1; + t = {}; + s = { + inherit t e f; + a = 1; + "b" = 2; + c.d = 3; + }; + p = builtins.unsafeGetAttrPos "b" s; in + [ p.line p.column ] + |] + ) + -- jww (2018-05-09): These two are failing but they shouldn't be + -- + -- , ( "[ 7 13 ]" + -- , [text| + -- let e = 1; + -- f = 1; + -- t = {}; + -- s = { + -- inherit t e f; + -- a = 1; + -- "b" = 2; + -- c.d = 3; + -- }; + -- p = builtins.unsafeGetAttrPos "c.d" s; in + -- [ p.line p.column ] + -- |] + -- ) -case_unsafegetattrpos2 = - constantEqualText "[ 5 14 ]" [text| - let e = 1; - f = 1; - t = {}; - s = { - inherit t e f; - a = 1; - "b" = 2; - c.d = 3; - }; - p = builtins.unsafeGetAttrPos "f" s; in - [ p.line p.column ] - |] + -- , ( "[ 7 13 ]" + -- , [text| + -- let e = 1; + -- f = 1; + -- t = {}; + -- s = { + -- inherit t e f; + -- a = 1; + -- "b" = 2; + -- c.d = 3; + -- }; + -- p = builtins.unsafeGetAttrPos "d" s; in + -- [ p.line p.column ] + -- |] + -- ) + ] -case_unsafegetattrpos3 = - constantEqualText "[ 6 7 ]" [text| - let e = 1; - f = 1; - t = {}; - s = { - inherit t e f; - a = 1; - "b" = 2; - c.d = 3; - }; - p = builtins.unsafeGetAttrPos "a" s; in - [ p.line p.column ] +case_fixed_points = + constantEqualText + [text| + [ + { + foobar = "foobar"; + foo = "foo"; + bar = "bar"; + } + { + foobar = "foo + bar"; + foo = "foo + "; + bar = "bar"; + } + ] |] - -case_unsafegetattrpos4 = - constantEqualText "[ 7 7 ]" [text| - let e = 1; - f = 1; - t = {}; - s = { - inherit t e f; - a = 1; - "b" = 2; - c.d = 3; - }; - p = builtins.unsafeGetAttrPos "b" s; in - [ p.line p.column ] + [text| + let + fix = f: let x = f x; in x; + extends = f: rattrs: self: + let super = rattrs self; in super // f self super; + f = self: { foo = "foo"; + bar = "bar"; + foobar = self.foo + self.bar; }; + g = self: super: { foo = super.foo + " + "; }; + in [ (fix f) (fix (extends g f)) ] |] --- jww (2018-05-09): These two are failing but they shouldn't be - --- case_unsafegetattrpos5 = --- constantEqualText "[ 7 13 ]" [text| --- let e = 1; --- f = 1; --- t = {}; --- s = { --- inherit t e f; --- a = 1; --- "b" = 2; --- c.d = 3; --- }; --- p = builtins.unsafeGetAttrPos "c.d" s; in --- [ p.line p.column ] --- |] - --- case_unsafegetattrpos6 = --- constantEqualText "[ 7 13 ]" [text| --- let e = 1; --- f = 1; --- t = {}; --- s = { --- inherit t e f; --- a = 1; --- "b" = 2; --- c.d = 3; --- }; --- p = builtins.unsafeGetAttrPos "d" s; in --- [ p.line p.column ] --- |] - -case_fixed_points = - constantEqualText [text|[ - { - foobar = "foobar"; - foo = "foo"; - bar = "bar"; - } - { - foobar = "foo + bar"; - foo = "foo + "; - bar = "bar"; - } -]|] [text| - let - fix = f: let x = f x; in x; - extends = f: rattrs: self: - let super = rattrs self; in super // f self super; - f = self: { foo = "foo"; - bar = "bar"; - foobar = self.foo + self.bar; }; - g = self: super: { foo = super.foo + " + "; }; - in [ (fix f) (fix (extends g f)) ] -|] - case_fixed_points_and_fold = - constantEqualText [text|[ {} {} ]|] [text| -let - extends = f: rattrs: self: - let super = rattrs self; in super // f self super; - flip = f: a: b: f b a; - toFixFold = builtins.foldl' (flip extends) (self: {}) ([(self: super: {})]); - toFix = extends (self: super: {}) (self: {}); - fix = f: let x = f x; in x; -in [ (fix toFixFold) (fix toFix) ] -|] + constantEqualText + [text| + [ {} {} ] + |] + [text| + let + extends = f: rattrs: self: + let super = rattrs self; in super // f self super; + flip = f: a: b: f b a; + toFixFold = builtins.foldl' (flip extends) (self: {}) ([(self: super: {})]); + toFix = extends (self: super: {}) (self: {}); + fix = f: let x = f x; in x; + in [ (fix toFixFold) (fix toFix) ] + |] case_fixed_points_attrsets = - constantEqualText "{ x = { y = { z = 100; }; z = { y = 100; }; }; }" [text| + constantEqualText + "{ x = { y = { z = 100; }; z = { y = 100; }; }; }" + [text| let fix = f: let x = f x; in x; f = self: { x.z.y = 100; x.y.z = self.x.z.y; }; in fix f |] --- case_function_equals1 = --- constantEqualText "true" "{f = x: x;} == {f = x: x;}" - --- case_function_equals2 = --- constantEqualText "true" "[(x: x)] == [(x: x)]" - -case_function_equals3 = - constantEqualText "false" "(let a = (x: x); in a == a)" - -case_function_equals4 = - constantEqualText "true" "(let a = {f = x: x;}; in a == a)" - -case_function_equals5 = - constantEqualText "true" "(let a = [(x: x)]; in a == a)" +case_function_equals = + traverse_ (uncurry constantEqualText) + [ -- ( "true" + -- , "{f = x: x;} == {f = x: x;}" + -- ) + -- ( "true" + -- , "[(x: x)] == [(x: x)]" + -- ) + ( "false" + , "(let a = (x: x); in a == a)" + ) + , ( "true" + , "(let a = {f = x: x;}; in a == a)" + ) + , ( "true" + , "(let a = [(x: x)]; in a == a)" + ) + , ( "false" + , "builtins.pathExists \"/var/empty/invalid-directory\"" + ) + ] case_directory_pathexists = - constantEqualText "false" "builtins.pathExists \"/var/empty/invalid-directory\"" + constantEqualText + "false" + "builtins.pathExists \"/var/empty/invalid-directory\"" -- jww (2018-05-02): This constantly changes! --- case_placeholder = --- constantEqualText --- "\"/1rz4g4znpzjwh1xymhjpm42vipw92pr73vdgl6xs1hycac8kf2n9\"" --- "builtins.placeholder \"out\"" +case_placeholder = + constantEqualText + "\"/1rz4g4znpzjwh1xymhjpm42vipw92pr73vdgl6xs1hycac8kf2n9\"" + "builtins.placeholder \"out\"" case_rec_path_attr = - constantEqualText "10" - "let src = 10; x = rec { passthru.src = src; }; in x.passthru.src" + constantEqualText + "10" + "let src = 10; x = rec { passthru.src = src; }; in x.passthru.src" case_mapattrs_builtin = - constantEqualText' "{ a = \"afoo\"; b = \"bbar\"; }" [text| + constantEqualText' + "{ a = \"afoo\"; b = \"bbar\"; }" + [text| (builtins.mapAttrs (x: y: x + y) { a = "foo"; b = "bar"; @@ -363,102 +446,182 @@ -- Regression test for #373 case_regression_373 :: Assertion -case_regression_373 = do - freeVarsEqual "{ inherit a; }" ["a"] - freeVarsEqual "rec {inherit a; }" ["a"] - freeVarsEqual "let inherit a; in { }" ["a"] +case_regression_373 = + traverse_ (uncurry sameFreeVars) + [ ( "{ inherit a; }" + , one "a" + ) + , ("rec {inherit a; }" + , one "a" + ) + , ( "let inherit a; in { }" + , one "a" + ) + ] +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\" ]" "(x: builtins.deepSeq x x) (builtins.split \"(a)b\" \"abc\")" case_empty_string_equal_null_is_false = - constantEqualText "false" "\"\" == null" + constantEqualText + "false" + "\"\" == null" case_null_equal_empty_string_is_false = - constantEqualText "false" "null == \"\"" + constantEqualText + "false" + "null == \"\"" case_empty_string_not_equal_null_is_true = - constantEqualText "true" "\"\" != null" + constantEqualText + "true" + "\"\" != null" case_null_equal_not_empty_string_is_true = - constantEqualText "true" "null != \"\"" + constantEqualText + "true" + "null != \"\"" case_list_nested_bottom_diverges = - assertNixEvalThrows "let nested = [(let x = x; in x)]; in nested == nested" + assertNixEvalThrows + "let nested = [(let x = x; in x)]; in nested == nested" case_attrset_nested_bottom_diverges = - assertNixEvalThrows "let nested = { y = (let x = x; in x); }; in nested == nested" + assertNixEvalThrows + "let nested = { y = (let x = x; in x); }; in nested == nested" case_list_list_nested_bottom_equal = - constantEqualText "true" "let nested = [[(let x = x; in x)]]; in nested == nested" + constantEqualText + "true" + "let nested = [[(let x = x; in x)]]; in nested == nested" case_list_attrset_nested_bottom_equal = - constantEqualText "true" "let nested = [{ y = (let x = x; in x); }]; in nested == nested" + constantEqualText + "true" + "let nested = [{ y = (let x = x; in x); }]; in nested == nested" case_list_function_nested_bottom_equal = - constantEqualText "true" "let nested = [(_: let x = x; in x)]; in nested == nested" + constantEqualText + "true" + "let nested = [(_: let x = x; in x)]; in nested == nested" case_attrset_list_nested_bottom_equal = - constantEqualText "true" "let nested = { y = [(let x = x; in x)];}; in nested == nested" + constantEqualText + "true" + "let nested = { y = [(let x = x; in x)];}; in nested == nested" case_attrset_attrset_nested_bottom_equal = - constantEqualText "true" "let nested = { y = { y = (let x = x; in x); }; }; in nested == nested" + constantEqualText + "true" + "let nested = { y = { y = (let x = x; in x); }; }; in nested == nested" case_attrset_function_nested_bottom_equal = - constantEqualText "true" "let nested = { y = _: (let x = x; in x); }; in nested == nested" + constantEqualText + "true" + "let nested = { y = _: (let x = x; in x); }; in nested == nested" +case_if_follow_by_with = + constantEqualText + "1" + "let x = { a = true; b = 2; }; in if with x; a then 1 else 2" + -- Regression test for #527 case_add_string_thunk_left = - constantEqualText [text|"cygwin"|] [text|builtins.head ["cyg"] + "win"|] + constantEqualText + [text| + "cygwin" + |] + [text| + builtins.head ["cyg"] + "win" + |] case_add_string_thunk_right = - constantEqualText [text|"cygwin"|] [text|"cyg" + builtins.head ["win"]|] + constantEqualText + [text| + "cygwin" + |] + [text| + "cyg" + builtins.head ["win"] + |] case_add_int_thunk_left = - constantEqualText "3" "builtins.head [1] + 2" + constantEqualText + "3" + "builtins.head [1] + 2" case_add_int_thunk_right = - constantEqualText "3" "1 + builtins.head [2]" + constantEqualText + "3" + "1 + builtins.head [2]" case_concat_thunk_left = - constantEqualText "[1 2 3]" "builtins.tail [0 1 2] ++ [3]" + constantEqualText + "[1 2 3]" + "builtins.tail [0 1 2] ++ [3]" case_concat_thunk_rigth = - constantEqualText "[1 2 3]" "[1] ++ builtins.tail [1 2 3]" + constantEqualText + "[1 2 3]" + "[1] ++ builtins.tail [1 2 3]" --------------------------------------------------------------------------------- tests :: TestTree tests = $testGroupGenerator -genEvalCompareTests = do - td <- D.listDirectory testDir +genEvalCompareTests :: IO TestTree +genEvalCompareTests = + do + files <- coerce D.listDirectory testDir - let unmaskedFiles = filter ((==".nix") . takeExtension) td - let files = unmaskedFiles \\ maskedFiles + let + unmaskedFiles :: [Path] + unmaskedFiles = filter ((== ".nix") . takeExtension) files - pure $ testGroup "Eval comparison tests" $ fmap (mkTestCase testDir) files + testFiles :: [Path] + testFiles = unmaskedFiles \\ maskedFiles + + pure $ testGroup "Eval comparison tests" $ fmap (mkTestCase testDir) testFiles where - mkTestCase td f = testCase f $ assertEvalFileMatchesNix (td f) + mkTestCase :: Path -> Path -> TestTree + mkTestCase dir f = testCase (coerce f :: TestName) $ assertEvalFileMatchesNix $ dir f constantEqual :: NExprLoc -> NExprLoc -> Assertion -constantEqual expected actual = do +constantEqual expected actual = + do time <- getCurrentTime let opts = defaultOptions time -- putStrLn =<< lint (stripAnnotation a) - (eq, expectedNF, actualNF) <- runWithBasicEffectsIO opts $ do - expectedNF <- normalForm =<< nixEvalExprLoc mempty expected - actualNF <- normalForm =<< nixEvalExprLoc mempty actual - eq <- valueEqM expectedNF actualNF - pure (eq, expectedNF, actualNF) - let message = - "Inequal normal forms:\n" - <> "Expected: " <> printNix expectedNF <> "\n" - <> "Actual: " <> printNix actualNF - assertBool message eq + (eq, expectedNF, actualNF) <- + runWithBasicEffectsIO opts $ + do + expectedNF <- getNormForm expected + actualNF <- getNormForm actual + eq <- valueEqM expectedNF actualNF + pure (eq, expectedNF, actualNF) + let + message = + "Inequal normal forms:\n" + <> "Expected: " <> printNix expectedNF <> "\n" + <> "Actual: " <> printNix actualNF + assertBool (toString message) eq + where + getNormForm = normalForm <=< nixEvalExprLoc mempty constantEqualText' :: Text -> Text -> Assertion constantEqualText' expected actual = @@ -467,11 +630,11 @@ constantEqual expected' actual' constantEqualText :: Text -> Text -> Assertion -constantEqualText expected actual = do - constantEqualText' expected actual - mres <- liftIO $ lookupEnv "ALL_TESTS" <|> lookupEnv "MATCHING_TESTS" - when (isJust mres) $ - assertEvalMatchesNix actual +constantEqualText expected actual = + do + constantEqualText' expected actual + mres <- liftIO $ on (<|>) lookupEnv "ALL_TESTS" "MATCHING_TESTS" + whenJust (const $ assertEvalTextMatchesNix actual) mres assertNixEvalThrows :: Text -> Assertion assertNixEvalThrows a = @@ -488,20 +651,18 @@ (normalForm =<< nixEvalExprLoc mempty a') ) (\(_ :: NixException) -> pure True) - unless errored $ assertFailure "Did not catch nix exception" + when (not 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 "" xs' free' + free' = getFreeVars a' + assertEqual mempty (S.fromList xs) free' -maskedFiles :: [FilePath] -maskedFiles = - [ "builtins.fetchurl-01.nix" ] +maskedFiles :: [Path] +maskedFiles = mempty -testDir :: FilePath +testDir :: Path testDir = "tests/eval-compare" diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE QuasiQuotes #-} +{-# language QuasiQuotes #-} module Main where -import Prelude hiding (lookupEnv) +import Nix.Prelude +import Relude (force) import Relude.Unsafe (read) import qualified Control.Exception as Exc import GHC.Err (errorWithoutStackTrace) @@ -25,16 +26,16 @@ import qualified ReduceExprTests import qualified PrettyParseTests import System.Directory -import System.Environment (setEnv, lookupEnv) -import System.FilePath.Glob -import System.Posix.Files +import System.Environment (setEnv) +import System.FilePath.Glob (compile, globDir1) +import System.PosixCompat.Files import Test.Tasty import Test.Tasty.HUnit ensureLangTestsPresent :: Assertion ensureLangTestsPresent = do exist <- fileExist "data/nix/tests/local.mk" - unless exist $ + when (not exist) $ errorWithoutStackTrace $ String.unlines [ "Directory data/nix does not have any files." , "Did you forget to run" @@ -43,9 +44,9 @@ ensureNixpkgsCanParse :: Assertion ensureNixpkgsCanParse = consider "default.nix" (parseNixFile "default.nix") $ \case - Fix (NAbs (ParamSet params _ _) _) -> do - let rev = getString "rev" params - sha256 = getString "sha256" params + Fix (NAbs (ParamSet _ _ pset) _) -> do + let rev = getString "rev" pset + sha256 = getString "sha256" pset consider "fetchTarball expression" (pure $ parseNixTextLoc [text| builtins.fetchTarball { url = "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz"; @@ -55,35 +56,40 @@ time <- getCurrentTime runWithBasicEffectsIO (defaultOptions time) $ Nix.nixEvalExprLoc mempty expr - let dir = stringIgnoreContext ns - exists <- fileExist $ toString dir - unless exists $ + let dir = toString $ ignoreContext ns + exists <- fileExist dir + when (not exists) $ errorWithoutStackTrace $ "Directory " <> show dir <> " does not exist" - files <- globDir1 (compile "**/*.nix") $ toString dir - when (null files) $ - errorWithoutStackTrace $ - "Directory " <> show dir <> " does not have any files" - for_ files $ \file -> do - unless ("azure-cli/default.nix" `isSuffixOf` file || - "os-specific/linux/udisks/2-default.nix" `isSuffixOf` file) $ do - -- Parse and deepseq the resulting expression tree, to ensure the - -- parser is fully executed. - _ <- consider file (parseNixFileLoc file) $ Exc.evaluate . force - pass + files <- globDir1 (compile "**/*.nix") dir + handlePresence + (errorWithoutStackTrace $ + "Directory " <> show dir <> " does not have any files") + (traverse_ + (\ path -> + let notEndsIn suffix = not $ isSuffixOf suffix path in + when + (on (&&) notEndsIn "azure-cli/default.nix" "os-specific/linux/udisks/2-default.nix") + $ -- Parse and deepseq the resulting expression tree, to ensure the + -- parser is fully executed. + mempty <$ consider (coerce path) (parseNixFileLoc (coerce path)) $ Exc.evaluate . force + ) + ) + files v -> fail $ "Unexpected parse from default.nix: " <> show v where - getExpr k m = let Just (Just r) = lookup k m in r + getExpr k m = + let Just r = join $ lookup k m in + r getString k m = - let Fix (NStr (DoubleQuoted [Plain str])) = getExpr k m in str + let Fix (NStr (DoubleQuoted [Plain str])) = getExpr k m in + str consider path action k = - do - x <- action - either - (\ err -> errorWithoutStackTrace $ "Parsing " <> path <> " failed: " <> show err) - k - x + either + (\ err -> errorWithoutStackTrace $ "Parsing " <> coerce @Path path <> " failed: " <> show err) + k + =<< action main :: IO () main = do @@ -94,18 +100,18 @@ prettyTestsEnv <- lookupEnv "PRETTY_TESTS" pwd <- getCurrentDirectory - setEnv "NIX_REMOTE" (pwd <> "/real-store") - setEnv "NIX_DATA_DIR" (pwd <> "/data") + setEnv "NIX_REMOTE" $ pwd <> "/real-store" + setEnv "NIX_DATA_DIR" $ pwd <> "/data" defaultMain $ testGroup "hnix" $ [ ParserTests.tests , EvalTests.tests , PrettyTests.tests - , ReduceExprTests.tests] <> - [ PrettyParseTests.tests - (fromIntegral (read (fromMaybe "0" prettyTestsEnv) :: Int)) ] <> - [ evalComparisonTests ] <> - [ testCase "Nix language tests present" ensureLangTestsPresent + , ReduceExprTests.tests + , PrettyParseTests.tests $ fromIntegral $ read @Int $ fromMaybe "0" prettyTestsEnv + , evalComparisonTests + , testCase "Nix language tests present" ensureLangTestsPresent , nixLanguageTests ] <> [ testCase "Nixpkgs parses without errors" ensureNixpkgsCanParse - | isJust nixpkgsTestsEnv ] + | isJust nixpkgsTestsEnv + ] diff --git a/tests/NixLanguageTests.hs b/tests/NixLanguageTests.hs --- a/tests/NixLanguageTests.hs +++ b/tests/NixLanguageTests.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE ScopedTypeVariables #-} - module NixLanguageTests (genTests) where +import Nix.Prelude import Control.Exception import GHC.Err ( errorWithoutStackTrace ) import Control.Monad.ST @@ -11,7 +10,6 @@ import qualified Data.Set as Set import qualified Data.String as String import qualified Data.Text as Text -import qualified Data.Text.IO as Text import Data.Time import GHC.Exts import Nix.Lint @@ -22,8 +20,7 @@ import Nix.String import Nix.XML import qualified Options.Applicative as Opts -import System.Environment -import System.FilePath +import System.Environment ( setEnv ) import System.FilePath.Glob ( compile , globDir1 ) @@ -59,120 +56,180 @@ -- previously passed. newFailingTests :: Set String newFailingTests = Set.fromList - [ "eval-okay-hash" - , "eval-okay-hashfile" - , "eval-okay-path" - , "eval-okay-types" - , "eval-okay-fromTOML" - , "eval-okay-context-introspection" + [ "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 + [ -- 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 = do - testFiles <- - sort - -- jww (2018-05-07): Temporarily disable this test until #128 is fixed. - . filter ((`Set.notMember` newFailingTests) . takeBaseName) - . filter ((/= ".xml") . takeExtension) - <$> globDir1 (compile "*-*-*.*") "data/nix/tests/lang" - let testsByName = groupBy (takeFileName . dropExtensions) testFiles - let testsByType = groupBy testType (Map.toList testsByName) - let testGroups = fmap mkTestGroup (Map.toList testsByType) - pure $ localOption (mkTimeout 2000000) $ testGroup - "Nix (upstream) language tests" - testGroups +genTests = + do + testFiles <- getTestFiles + let + testsGroupedByName :: Map Path [Path] + testsGroupedByName = groupBy (takeFileName . dropExtensions) testFiles + + testsGroupedByTypeThenName :: Map [String] [(Path, [Path])] + testsGroupedByTypeThenName = groupBy testType $ Map.toList testsGroupedByName + + testTree :: [TestTree] + testTree = mkTestGroup <$> Map.toList testsGroupedByTypeThenName + + pure $ + localOption + (mkTimeout 2000000) + $ testGroup + "Nix (upstream) language tests" + testTree where - testType (fullpath, _files) = take 2 $ splitOn "-" $ takeFileName fullpath - mkTestGroup (kind, tests) = - testGroup (String.unwords kind) $ fmap (mkTestCase kind) tests - mkTestCase kind (basename, files) = testCase (takeFileName basename) $ do - time <- liftIO getCurrentTime - let opts = defaultOptions time - case kind of - ["parse", "okay"] -> assertParse opts $ the files - ["parse", "fail"] -> assertParseFail opts $ the files - ["eval" , "okay"] -> assertEval opts files - ["eval" , "fail"] -> assertEvalFail $ the files - _ -> fail $ "Unexpected: " <> show kind -assertParse :: Options -> FilePath -> Assertion + getTestFiles :: IO [Path] + getTestFiles = sortTestFiles <$> collectTestFiles + where + collectTestFiles :: IO [Path] + collectTestFiles = coerce (globDir1 (compile "*-*-*.*") nixTestDir) + + sortTestFiles :: [Path] -> [Path] + sortTestFiles = + sort + -- Disabling the not yet done tests cases. + . filter withoutDisabledTests + . filter withoutXml + where + withoutDisabledTests :: Path -> Bool + withoutDisabledTests = (`Set.notMember` (newFailingTests `Set.union` deprecatedRareNixQuirkTests)) . takeBaseName + + withoutXml :: Path -> Bool + withoutXml = (/= ".xml") . takeExtension + + testType :: (Path, b) -> [String] + testType (fullpath, _files) = coerce (take 2 . splitOn "-") $ takeFileName fullpath + + mkTestGroup :: ([String], [(Path, [Path])]) -> TestTree + mkTestGroup (tType, tests) = + testGroup (String.unwords tType) $ mkTestCase <$> tests + where + mkTestCase :: (Path, [Path]) -> TestTree + mkTestCase (basename, files) = + testCase + (coerce $ takeFileName basename) + $ do + time <- liftIO getCurrentTime + let opts = defaultOptions time + case tType of + ["parse", "okay"] -> assertParse opts $ the files + ["parse", "fail"] -> assertParseFail opts $ the files + ["eval" , "okay"] -> assertEval opts files + ["eval" , "fail"] -> assertEvalFail $ the files + _ -> fail $ "Unexpected: " <> show tType + + +assertParse :: Options -> Path -> Assertion assertParse _opts file = - do - x <- parseNixFileLoc file - either - (\ err -> assertFailure $ "Failed to parse " <> file <> ":\n" <> show err) - (const pass) -- pure $! runST $ void $ lint opts expr - x + either + (\ err -> assertFailure $ "Failed to parse " <> coerce file <> ":\n" <> show err) + (const stub) -- pure $! runST $ void $ lint opts expr + =<< parseNixFileLoc file -assertParseFail :: Options -> FilePath -> Assertion -assertParseFail opts file = do - eres <- parseNixFileLoc file - (`catch` \(_ :: SomeException) -> pass) - (either - (const pass) +assertParseFail :: Options -> Path -> Assertion +assertParseFail opts file = + (`catch` \(_ :: SomeException) -> stub) $ + either + (const stub) (\ expr -> do _ <- pure $! runST $ void $ lint opts expr - assertFailure $ "Unexpected success parsing `" <> file <> ":\nParsed value: " <> show expr + assertFailure $ "Unexpected success parsing `" <> coerce file <> ":\nParsed value: " <> show expr ) - eres - ) + =<< parseNixFileLoc file -assertLangOk :: Options -> FilePath -> Assertion -assertLangOk opts file = do - actual <- printNix <$> hnixEvalFile opts (file <> ".nix") - expected <- Text.readFile $ file <> ".exp" - assertEqual "" expected $ toText (actual <> "\n") +assertLangOk :: Options -> Path -> Assertion +assertLangOk opts fileBaseName = + do + actual <- printNix <$> hnixEvalFile opts (addNixExt fileBaseName) + expected <- read fileBaseName ".exp" + assertEqual mempty expected (actual <> "\n") -assertLangOkXml :: Options -> FilePath -> Assertion -assertLangOkXml opts file = do - actual <- stringIgnoreContext . toXML <$> hnixEvalFile - opts - (file <> ".nix") - expected <- Text.readFile $ file <> ".exp.xml" - assertEqual "" expected actual +assertLangOkXml :: Options -> Path -> Assertion +assertLangOkXml opts fileBaseName = + do + actual <- ignoreContext . toXML <$> hnixEvalFile opts (addNixExt fileBaseName) + expected <- read fileBaseName ".exp.xml" + assertEqual mempty expected actual -assertEval :: Options -> [FilePath] -> Assertion -assertEval _opts files = do - time <- liftIO getCurrentTime - let opts = defaultOptions time - case delete ".nix" $ sort $ fmap takeExtensions files of - [] -> () <$ hnixEvalFile opts (name <> ".nix") - [".exp" ] -> assertLangOk opts name - [".exp.xml" ] -> assertLangOkXml opts name - [".exp.disabled"] -> pass - [".exp-disabled"] -> pass - [".exp", ".flags"] -> do - liftIO $ setEnv "NIX_PATH" "lang/dir4:lang/dir5" - flags <- Text.readFile (name <> ".flags") - let flags' | Text.last flags == '\n' = Text.init flags - | otherwise = flags - case - Opts.execParserPure - Opts.defaultPrefs - (nixOptionsInfo time) - (fixup (fmap toString (Text.splitOn " " flags'))) - of - Opts.Failure err -> errorWithoutStackTrace $ "Error parsing flags from " <> name <> ".flags: " <> show err - Opts.Success opts' -> assertLangOk opts' name - Opts.CompletionInvoked _ -> fail "unused" - _ -> assertFailure $ "Unknown test type " <> show files +assertEval :: Options -> [Path] -> Assertion +assertEval _opts files = + do + time <- liftIO getCurrentTime + let opts = defaultOptions time + case delete ".nix" $ sort $ fromString @Text . takeExtensions <$> files of + [] -> void $ hnixEvalFile opts $ addNixExt name + [".exp" ] -> assertLangOk opts name + [".exp.xml" ] -> assertLangOkXml opts name + [".exp.disabled" ] -> stub + [".exp-disabled" ] -> stub + [".exp", ".flags"] -> + do + liftIO $ setEnv "NIX_PATH" "lang/dir4:lang/dir5" + flags <- read name ".flags" + let + flags' :: Text + flags' = + bool + id + Text.init + (Text.last flags == '\n') + flags + case runParserGetResult time flags' of + Opts.Failure err -> errorWithoutStackTrace $ "Error parsing flags from " <> coerce name <> ".flags: " <> show err + Opts.CompletionInvoked _ -> fail "unused" + Opts.Success opts' -> assertLangOk opts' name + _ -> assertFailure $ "Unknown test type " <> show files where - name = - "data/nix/tests/lang/" <> the (fmap (takeFileName . dropExtensions) files) + runParserGetResult :: UTCTime -> Text -> Opts.ParserResult Options + runParserGetResult time flags' = + Opts.execParserPure + Opts.defaultPrefs + (nixOptionsInfo time) + (fmap toString $ fixup $ Text.splitOn " " flags') - fixup ("--arg" : x : y : rest) = "--arg" : (x <> "=" <> y) : fixup rest + name :: Path + name = coerce nixTestDir <> the (takeFileName . dropExtensions <$> files) + + fixup :: [Text] -> [Text] + fixup ("--arg" : x : y : rest) = "--arg" : (x <> "=" <> y) : fixup rest fixup ("--argstr" : x : y : rest) = "--argstr" : (x <> "=" <> y) : fixup rest - fixup (x : rest) = x : fixup rest + fixup (x : rest) = x : fixup rest fixup [] = mempty -assertEvalFail :: FilePath -> Assertion -assertEvalFail file = (`catch` (\(_ :: SomeException) -> pass)) $ do - time <- liftIO getCurrentTime - evalResult <- printNix <$> hnixEvalFile (defaultOptions time) file - evalResult `seq` - assertFailure $ - file - <> " should not evaluate.\nThe evaluation result was `" - <> evalResult - <> "`." +assertEvalFail :: Path -> Assertion +assertEvalFail file = + (`catch` (\(_ :: SomeException) -> stub)) $ + do + time <- liftIO getCurrentTime + evalResult <- printNix <$> hnixEvalFile (defaultOptions time) file + evalResult `seq` assertFailure $ "File: ''" <> coerce file <> "'' should not evaluate.\nThe evaluation result was `" <> toString evalResult <> "`." + +nixTestDir :: FilePath +nixTestDir = "data/nix/tests/lang/" + +addNixExt :: Path -> Path +addNixExt path = addExtension path ".nix" + +read :: Path -> String -> IO Text +read path ext = readFile $ addExtension path ext diff --git a/tests/ParserTests.hs b/tests/ParserTests.hs --- a/tests/ParserTests.hs +++ b/tests/ParserTests.hs @@ -1,463 +1,826 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE RankNTypes #-} - -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# OPTIONS_GHC -Wno-missing-signatures #-} - - -module ParserTests (tests) where - -import Data.Fix -import NeatInterpolation (text) -import Nix.Atoms -import Nix.Expr -import Nix.Parser -import Nix.Pretty -import Prettyprinter -import Prettyprinter.Render.Text -import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.TH - -case_constant_int = assertParseText "234" $ mkInt 234 - -case_constant_bool = do - assertParseText "true" $ mkBool True - assertParseText "false" $ mkBool False - -case_constant_bool_respects_attributes = do - assertParseText "true-foo" $ mkSym "true-foo" - assertParseText "false-bar" $ mkSym "false-bar" - -case_constant_path = do - assertParseText "./." $ mkPath False "./." - assertParseText "./+-_/cdef/09ad+-" $ mkPath False "./+-_/cdef/09ad+-" - assertParseText "/abc" $ mkPath False "/abc" - assertParseText "../abc" $ mkPath False "../abc" - assertParseText "" $ mkPath True "abc" - assertParseText "<../cdef>" $ mkPath True "../cdef" - assertParseText "a//b" $ mkOper2 NUpdate (mkSym "a") (mkSym "b") - assertParseText "rec+def/cdef" $ mkPath False "rec+def/cdef" - assertParseText "a/b//c/def// < def/d" $ mkOper2 NLt - (mkOper2 NUpdate (mkPath False "a/b") $ mkOper2 NUpdate - (mkPath False "c/def") (mkPath True "g")) - (mkPath False "def/d") - assertParseText "a'b/c" $ Fix $ NBinary NApp (mkSym "a'b") (mkPath False "/c") - assertParseText "a/b" $ mkPath False "a/b" - assertParseText "4/2" $ mkPath False "4/2" - assertParseFail "." - assertParseFail ".." - assertParseFail "/" - assertParseFail "a/" - assertParseFail "a/def/" - assertParseFail "~" - assertParseFail "~/" - assertParseText "~/a" $ mkPath False "~/a" - assertParseText "~/a/b" $ mkPath False "~/a/b" - -case_constant_uri = do - assertParseText "a:a" $ mkStr "a:a" - assertParseText "http://foo.bar" $ mkStr "http://foo.bar" - assertParseText "a+de+.adA+-:%%%ads%5asdk&/" $ mkStr "a+de+.adA+-:%%%ads%5asdk&/" - assertParseText "rec+def:c" $ mkStr "rec+def:c" - assertParseText "f.foo:bar" $ mkStr "f.foo:bar" - assertParseFail "http://foo${\"bar\"}" - assertParseFail ":bcdef" - assertParseFail "a%20:asda" - assertParseFail ".:adasd" - assertParseFail "+:acdcd" - -case_simple_set = do - assertParseText "{ a = 23; b = 4; }" $ Fix $ NSet NNonRecursive - [ NamedVar (mkSelector "a") (mkInt 23) nullPos - , NamedVar (mkSelector "b") (mkInt 4) nullPos - ] - assertParseFail "{ a = 23 }" - -case_set_inherit = do - assertParseText "{ e = 3; inherit a b; }" $ Fix $ NSet NNonRecursive - [ NamedVar (mkSelector "e") (mkInt 3) nullPos - , Inherit Nothing (StaticKey <$> ["a", "b"]) nullPos - ] - assertParseText "{ inherit; }" $ Fix $ NSet NNonRecursive [ Inherit Nothing mempty nullPos ] - -case_set_scoped_inherit = assertParseText "{ inherit (a) b c; e = 4; inherit(a)b c; }" $ Fix $ NSet NNonRecursive - [ Inherit (pure (mkSym "a")) (StaticKey <$> ["b", "c"]) nullPos - , NamedVar (mkSelector "e") (mkInt 4) nullPos - , Inherit (pure (mkSym "a")) (StaticKey <$> ["b", "c"]) nullPos - ] - -case_set_rec = assertParseText "rec { a = 3; b = a; }" $ Fix $ NSet NRecursive - [ NamedVar (mkSelector "a") (mkInt 3) nullPos - , NamedVar (mkSelector "b") (mkSym "a") nullPos - ] - -case_set_complex_keynames = do - assertParseText "{ \"\" = null; }" $ Fix $ NSet NNonRecursive - [ NamedVar (DynamicKey (Plain (DoubleQuoted mempty)) :| mempty) mkNull nullPos ] - assertParseText "{ a.b = 3; a.c = 4; }" $ Fix $ NSet NNonRecursive - [ NamedVar (StaticKey "a" :| [StaticKey "b"]) (mkInt 3) nullPos - , NamedVar (StaticKey "a" :| [StaticKey "c"]) (mkInt 4) nullPos - ] - assertParseText "{ ${let a = \"b\"; in a} = 4; }" $ Fix $ NSet NNonRecursive - [ NamedVar (DynamicKey (Antiquoted letExpr) :| mempty) (mkInt 4) nullPos ] - assertParseText "{ \"a${let a = \"b\"; in a}c\".e = 4; }" $ Fix $ NSet NNonRecursive - [ NamedVar (DynamicKey (Plain str) :| [StaticKey "e"]) (mkInt 4) nullPos ] - where - letExpr = Fix $ NLet [NamedVar (mkSelector "a") (mkStr "b") nullPos] (mkSym "a") - str = DoubleQuoted [Plain "a", Antiquoted letExpr, Plain "c"] - -case_set_inherit_direct = assertParseText "{ inherit ({a = 3;}); }" $ Fix $ NSet NNonRecursive - [ Inherit (pure $ Fix $ NSet NNonRecursive [NamedVar (mkSelector "a") (mkInt 3) nullPos]) mempty nullPos - ] - -case_inherit_selector = do - assertParseText "{ inherit \"a\"; }" $ Fix $ NSet NNonRecursive - [Inherit Nothing [DynamicKey (Plain (DoubleQuoted [Plain "a"]))] nullPos] - assertParseFail "{ inherit a.x; }" - -case_int_list = assertParseText "[1 2 3]" $ Fix $ NList - [ mkInt i | i <- [1,2,3] ] - -case_int_null_list = assertParseText "[1 2 3 null 4]" $ Fix (NList (fmap (Fix . NConstant) [NInt 1, NInt 2, NInt 3, NNull, NInt 4])) - -case_mixed_list = do - assertParseText "[{a = 3;}.a (if true then null else false) null false 4 [] c.d or null]" $ Fix $ NList - [ Fix (NSelect (Fix (NSet NNonRecursive [NamedVar (mkSelector "a") (mkInt 3) nullPos])) - (mkSelector "a") Nothing) - , Fix (NIf (mkBool True) mkNull (mkBool False)) - , mkNull, mkBool False, mkInt 4, Fix (NList mempty) - , Fix (NSelect (mkSym "c") (mkSelector "d") (pure mkNull)) - ] - assertParseFail "[if true then null else null]" - assertParseFail "[a ? b]" - assertParseFail "[a : a]" - assertParseFail "[${\"test\")]" - -case_simple_lambda = assertParseText "a: a" $ Fix $ NAbs (Param "a") (mkSym "a") - -case_lambda_or_uri = do - assertParseText "a :b" $ Fix $ NAbs (Param "a") (mkSym "b") - assertParseText "a c:def" $ Fix $ NBinary NApp (mkSym "a") (mkStr "c:def") - assertParseText "c:def: c" $ Fix $ NBinary NApp (mkStr "c:def:") (mkSym "c") - assertParseText "a:{}" $ Fix $ NAbs (Param "a") $ Fix $ NSet NNonRecursive mempty - assertParseText "a:[a]" $ Fix $ NAbs (Param "a") $ Fix $ NList [mkSym "a"] - assertParseFail "def:" - -case_lambda_pattern = do - assertParseText "{b, c ? 1}: b" $ - Fix $ NAbs (fixed args mempty) (mkSym "b") - assertParseText "{ b ? x: x }: b" $ - Fix $ NAbs (fixed args2 mempty) (mkSym "b") - assertParseText "a@{b,c ? 1}: b" $ - Fix $ NAbs (fixed args (pure "a")) (mkSym "b") - assertParseText "{b,c?1}@a: c" $ - Fix $ NAbs (fixed args (pure "a")) (mkSym "c") - assertParseText "{b,c?1,...}@a: c" $ - Fix $ NAbs (variadic vargs (pure "a")) (mkSym "c") - assertParseText "{...}: 1" $ - Fix $ NAbs (variadic mempty mempty) (mkInt 1) - assertParseFail "a@b: a" - assertParseFail "{a}@{b}: a" - where - fixed args = ParamSet args False - variadic args = ParamSet args True - args = [("b", Nothing), ("c", pure $ mkInt 1)] - vargs = [("b", Nothing), ("c", pure $ mkInt 1)] - args2 = [("b", pure lam)] - lam = Fix $ NAbs (Param "x") (mkSym "x") - -case_lambda_app_int = assertParseText "(a: a) 3" $ Fix (NBinary NApp lam int) where - int = mkInt 3 - lam = Fix (NAbs (Param "a") asym) - asym = mkSym "a" - -case_simple_let = do - assertParseText "let a = 4; in a" $ Fix (NLet binds $ mkSym "a") - assertParseFail "let a = 4 in a" - where - binds = [NamedVar (mkSelector "a") (mkInt 4) nullPos] - -case_let_body = assertParseText "let { body = 1; }" letBody - where - letBody = Fix $ NSelect aset (mkSelector "body") Nothing - aset = Fix $ NSet NRecursive [NamedVar (mkSelector "body") (mkInt 1) nullPos] - -case_nested_let = do - assertParseText "let a = 4; in let b = 5; in a" $ Fix $ NLet - [NamedVar (mkSelector "a") (mkInt 4) nullPos] - (Fix $ NLet [NamedVar (mkSelector "b") (mkInt 5) nullPos] $ mkSym "a") - assertParseFail "let a = 4; let b = 3; in b" - -case_let_scoped_inherit = do - assertParseText "let a = null; inherit (b) c; in c" $ Fix $ NLet - [ NamedVar (mkSelector "a") mkNull nullPos - , Inherit (pure $ mkSym "b") [StaticKey "c"] nullPos ] - (mkSym "c") - assertParseFail "let inherit (b) c in c" - -case_if = do - assertParseText "if true then true else false" $ - Fix $ NIf (mkBool True) (mkBool True) (mkBool False) - assertParseFail "if true then false" - assertParseFail "else" - assertParseFail "if true then false else" - assertParseFail "if true then false else false else" - assertParseFail "1 + 2 then" - -case_identifier_special_chars = do - assertParseText "_a" $ mkSym "_a" - assertParseText "a_b" $ mkSym "a_b" - assertParseText "a'b" $ mkSym "a'b" - assertParseText "a''b" $ mkSym "a''b" - assertParseText "a-b" $ mkSym "a-b" - assertParseText "a--b" $ mkSym "a--b" - assertParseText "a12a" $ mkSym "a12a" - assertParseFail ".a" - assertParseFail "'a" - -case_identifier_keyword_prefix = do - assertParseText "true-name" $ mkSym "true-name" - assertParseText "trueName" $ mkSym "trueName" - assertParseText "null-name" $ mkSym "null-name" - assertParseText "nullName" $ mkSym "nullName" - assertParseText "[ null-name ]" $ mkList [ mkSym "null-name" ] - -makeTextParseTest str = assertParseText ("\"" <> str <> "\"") $ mkStr str - -case_simple_string = traverse_ makeTextParseTest ["abcdef", "a", "A", " a a ", ""] - -case_string_dollar = traverse_ makeTextParseTest ["a$b", "a$$b", "$cdef", "gh$i"] - -case_string_escape = do - assertParseText "\"\\$\\n\\t\\r\\\\\"" $ mkStr "$\n\t\r\\" - assertParseText "\" \\\" \\' \"" $ mkStr " \" ' " - -case_string_antiquote = do - assertParseText "\"abc${ if true then \"def\" else \"abc\" } g\"" $ - Fix $ NStr $ DoubleQuoted - [ Plain "abc" - , Antiquoted $ Fix $ NIf (mkBool True) (mkStr "def") (mkStr "abc") - , Plain " g" - ] - assertParseText "\"\\${a}\"" $ mkStr "${a}" - assertParseFail "\"a" - assertParseFail "${true}" - assertParseFail "\"${true\"" - -case_select = do - assertParseText "a . e .di. f" $ Fix $ NSelect (mkSym "a") - (StaticKey "e" :| [StaticKey "di", StaticKey "f"]) - Nothing - assertParseText "a.e . d or null" $ Fix $ NSelect (mkSym "a") - (StaticKey "e" :| [StaticKey "d"]) - (pure mkNull) - assertParseText "{}.\"\"or null" $ Fix $ NSelect (Fix (NSet NNonRecursive mempty)) - (DynamicKey (Plain (DoubleQuoted mempty)) :| mempty) (pure mkNull) - assertParseText "{ a = [1]; }.a or [2] ++ [3]" $ Fix $ NBinary NConcat - (Fix (NSelect - (Fix (NSet NNonRecursive [NamedVar (StaticKey "a" :| mempty) - (Fix (NList [Fix (NConstant (NInt 1))])) - nullPos])) - (StaticKey "a" :| mempty) - (pure (Fix (NList [Fix (NConstant (NInt 2))]))))) - (Fix (NList [Fix (NConstant (NInt 3))])) - -case_select_path = do - assertParseText "f ./." $ Fix $ NBinary NApp (mkSym "f") (mkPath False "./.") - assertParseText "f.b ../a" $ Fix $ NBinary NApp select (mkPath False "../a") - assertParseText "{}./def" $ Fix $ NBinary NApp (Fix (NSet NNonRecursive mempty)) (mkPath False "./def") - assertParseText "{}.\"\"./def" $ Fix $ NBinary NApp - (Fix $ NSelect (Fix (NSet NNonRecursive mempty)) (DynamicKey (Plain (DoubleQuoted mempty)) :| mempty) Nothing) - (mkPath False "./def") - where select = Fix $ NSelect (mkSym "f") (mkSelector "b") Nothing - -case_select_keyword = do - assertParseText "{ false = \"foo\"; }" $ Fix $ NSet NNonRecursive [NamedVar (mkSelector "false") (mkStr "foo") nullPos] - -case_fun_app = do - assertParseText "f a b" $ Fix $ NBinary NApp (Fix $ NBinary NApp (mkSym "f") (mkSym "a")) (mkSym "b") - assertParseText "f a.x or null" $ Fix $ NBinary NApp (mkSym "f") $ Fix $ - NSelect (mkSym "a") (mkSelector "x") (pure mkNull) - assertParseFail "f if true then null else null" - -case_indented_string = do - assertParseText "''a''" $ mkIndentedStr 0 "a" - assertParseText "''\n foo\n bar''" $ mkIndentedStr 2 "foo\nbar" - assertParseText "'' ''" $ mkIndentedStr 0 "" - assertParseText "'''''''" $ mkIndentedStr 0 "''" - assertParseText "'' ${null}\n a${null}''" $ Fix $ NStr $ Indented 3 - [ Antiquoted mkNull - , Plain "\na" - , Antiquoted mkNull - ] - assertParseFail "'''''" - assertParseFail "'' '" - -case_indented_string_escape = assertParseText - "'' ''\\n ''\\t ''\\\\ ''${ \\ \\n ' ''' ''" $ - mkIndentedStr 1 "\n \t \\ ${ \\ \\n ' '' " - -case_operator_fun_app = do - assertParseText "a ++ b" $ mkOper2 NConcat (mkSym "a") (mkSym "b") - assertParseText "a ++ f b" $ mkOper2 NConcat (mkSym "a") $ Fix $ NBinary NApp - (mkSym "f") (mkSym "b") - -case_operators = do - assertParseText "1 + 2 - 3" $ mkOper2 NMinus - (mkOper2 NPlus (mkInt 1) (mkInt 2)) (mkInt 3) - assertParseFail "1 + if true then 1 else 2" - assertParseText "1 + (if true then 2 else 3)" $ mkOper2 NPlus (mkInt 1) $ Fix $ NIf - (mkBool True) (mkInt 2) (mkInt 3) - assertParseText "{ a = 3; } // rec { b = 4; }" $ mkOper2 NUpdate - (Fix $ NSet NNonRecursive [NamedVar (mkSelector "a") (mkInt 3) nullPos]) - (Fix $ NSet NRecursive [NamedVar (mkSelector "b") (mkInt 4) nullPos]) - assertParseText "--a" $ mkOper NNeg $ mkOper NNeg $ mkSym "a" - assertParseText "a - b - c" $ mkOper2 NMinus - (mkOper2 NMinus (mkSym "a") (mkSym "b")) $ - mkSym "c" - assertParseText "foo" (mkPos l) (mkPos c) - mkSpan l1 c1 l2 c2 = SrcSpan (mkSPos l1 c1) (mkSPos l2 c2) - in - assertParseTextLoc [text|let - foo = bar - baz "qux"; - in foo - |] - (Fix - (NLet_ - (mkSpan 1 1 4 7) - [ NamedVar - (StaticKey "foo" :| []) - (Fix - (NBinary_ - (mkSpan 2 7 3 15) - NApp - (Fix - (NBinary_ (mkSpan 2 7 3 9) - NApp - (Fix (NSym_ (mkSpan 2 7 2 10) "bar")) - (Fix (NSym_ (mkSpan 3 6 3 9) "baz")) - ) - ) - (Fix (NStr_ (mkSpan 3 10 3 15) (DoubleQuoted [Plain "qux"]))) - ) - ) - (mkSPos 2 1) - ] - (Fix (NSym_ (mkSpan 4 4 4 7) "foo")) - ) - ) - - -tests :: TestTree -tests = $testGroupGenerator - ---------------------------------------------------------------------------------- - -assertParseText :: Text -> NExpr -> Assertion -assertParseText str expected = - either - (\ err -> - assertFailure $ toString $ "Unexpected fail parsing `" <> str <> "':\n" <> show err - ) - (assertEqual - ("When parsing " <> toString str) - (stripPositionInfo expected) - . stripPositionInfo - ) - (parseNixText str) - -assertParseTextLoc :: Text -> NExprLoc -> Assertion -assertParseTextLoc str expected = - either - (\ err -> - assertFailure $ toString $ "Unexpected fail parsing `" <> str <> "':\n" <> show err - ) - (assertEqual - ("When parsing " <> toString str) - expected - ) - (parseNixTextLoc str) - -assertParseFile :: FilePath -> NExpr -> Assertion -assertParseFile file expected = - do - res <- parseNixFile $ "data/" <> file - either - (\ err -> - assertFailure $ "Unexpected fail parsing data file `" <> file <> "':\n" <> show err - ) - (assertEqual - ("Parsing data file " <> file) - (stripPositionInfo expected) - . stripPositionInfo - ) - res - -assertParseFail :: Text -> Assertion -assertParseFail str = - either - (const pass) - (\ r -> - assertFailure $ toString $ "Unexpected success parsing `" <> str <> ":\nParsed value: " <> show r - ) - (parseNixText str) - --- assertRoundTrip :: Text -> Assertion --- assertRoundTrip src = assertParsePrint src src - -assertParsePrint :: Text -> Text -> Assertion -assertParsePrint src expect = - let - Right expr = parseNixTextLoc src - result = - renderStrict - . layoutPretty (LayoutOptions $ AvailablePerLine 80 0.4) - . prettyNix - . stripAnnotation $ - expr - in assertEqual "" expect result +{-# language QuasiQuotes #-} +{-# language TemplateHaskell #-} +{-# language RankNTypes #-} +{-# language ExtendedDefaultRules #-} + +{-# options_ghc -fno-warn-name-shadowing #-} +{-# options_ghc -Wno-missing-signatures #-} +{-# options_ghc -Wno-type-defaults #-} + + +module ParserTests (tests) where + +import Nix.Prelude hiding (($<)) +import Data.Fix +import NeatInterpolation (text) +import Nix.Atoms +import Nix.Expr +import Nix.Parser +import Nix.Pretty +import Prettyprinter +import Prettyprinter.Render.Text +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.TH +import Prettyprinter.Render.String (renderString) +import Prettyprinter.Util (reflow) + +default (NixLang) + +-- * Tests + + +-- ** Literals + +case_constant_int = + checks + ( mkInt 234 + , "234" + ) + +case_constant_bool = + checks + ( mkBool True + , "true" + ) + ( mkBool False + , "false" + ) + +case_constant_bool_respects_attributes = + invariantVals + "true-foo" + "false-bar" + +case_constant_path_invariants = + knownAs (staysInvariantUnder (mkRelPath . toString)) + "./." + "./+-_/cdef/09ad+-" + "/abc" + "../abc" + "~/a" + "~/a/b" + "a/b" + "4/2" + "rec+def/cdef" + +case_constant_path = + checks + ( var "a'b" @@ mkRelPath "/c" + , "a'b/c" + ) + ( mkRelPath "a/b" $// mkRelPath "c/def" $// mkEnvPath "g" $< mkRelPath "def/d" + , "a/b//c/def// < def/d" + ) + ( mkEnvPath "abc" + , "" + ) + ( mkEnvPath "../cdef" + , "<../cdef>" + ) + ( var "a" $// var "b" + , "a//b" + ) + +case_constant_path_syntax_mistakes = + mistakes + "." + ".." + "/" + "a/" + "a/def/" + "~" + "~/" + +case_constant_uri = + knownAs (staysInvariantUnder mkStr) + "a:a" + "http://foo.bar" + "a+de+.adA+-:%%%ads%5asdk&/" + "rec+def:c" + "f.foo:bar" + + +case_constant_uri_syntax_mistakes = + mistakes + "http://foo${\"bar\"}" + ":bcdef" + "a%20:asda" + ".:adasd" + "+:acdcd" + + +-- *** Special chars in vals + +case_identifier_special_chars = + invariantVals + "_a" + "a_b" + "a'b" + "a''b" + "a-b" + "a--b" + "a12a" + +case_identifier_special_chars_syntax_mistakes = + mistakes + ".a" + "'a" + +-- ** Sets + +-- *** Non-recursive sets + +case_simple_set = + checks + ( mkNonRecSet + [ "a" $= mkInt 23 + , "b" $= mkInt 4 + ] + , "{ a = 23; b = 4; }" + ) + +case_simple_set_syntax_mistakes = + mistakes + "{ a = 23 }" + +case_set_complex_keynames = + checks + ( mkNonRecSet $ + one (NamedVar (one (DynamicKey (Plain (DoubleQuoted mempty)))) mkNull nullPos) + , "{ \"\" = null; }" + ) + ( mkNonRecSet + [ NamedVar (StaticKey "a" :| one (StaticKey "b")) (mkInt 3) nullPos + , NamedVar (StaticKey "a" :| one (StaticKey "c")) (mkInt 4) nullPos + ] + , "{ a.b = 3; a.c = 4; }" + ) + ( mkNonRecSet $ + one (NamedVar (one (DynamicKey (Antiquoted letExpr))) (mkInt 4) nullPos) + , "{ ${let a = \"b\"; in a} = 4; }" + ) + ( mkNonRecSet $ + one (NamedVar (DynamicKey (Plain str) :| one (StaticKey "e")) (mkInt 4) nullPos) + , "{ \"a${let a = \"b\"; in a}c\".e = 4; }" + ) + where + letExpr = mkLets (one ("a" $= mkStr "b")) (var "a") + str = DoubleQuoted [Plain "a", Antiquoted letExpr, Plain "c"] + + +-- *** Recursivity in sets + +case_set_rec = + checks + ( mkRecSet + [ "a" $= mkInt 3 + , "b" $= var "a" + ] + , "rec { a = 3; b = a; }" + ) + + +-- *** Inheritance + +case_set_inherit = + checks + ( mkNonRecSet + [ "e" $= mkInt 3 + , inherit ["a", "b"] + ] + , "{ e = 3; inherit a b; }" + ) + ( mkNonRecSet $ one $ inherit mempty + , "{ inherit; }" + ) + +case_set_scoped_inherit = + checks + ( mkNonRecSet $ + (\ x -> [x, "e" $= mkInt 4, x]) $ + inheritFrom (var "a") ["b", "c"] + , "{ inherit (a) b c; e = 4; inherit(a)b c; }" + ) + +case_set_inherit_direct = + checks + ( mkNonRecSet $ one (inheritFrom (mkNonRecSet $ one ("a" $= mkInt 3)) mempty) + , "{ inherit ({a = 3;}); }" + ) + +case_inherit_selector_syntax_mistakes = + mistakes + "{ inherit a.x; }" + -- A rare quirk of Nix that is proper to fix then to support (see git commit history) + -- (old parser test result was): + -- mkNonRecSet [inherit [DynamicKey (Plain (DoubleQuoted [Plain "a"]))]], + "{ inherit \"a\"; }" + + +-- ** Lists + +case_int_list = + checks + ( mkList $ mkInt <$> [1,2,3] + , "[1 2 3]" + ) + +case_int_null_list = + checks + ( mkList (mkConst <$> [NInt 1, NInt 2, NInt 3, NNull, NInt 4]) + , "[1 2 3 null 4]" + ) + +case_mixed_list = + checks + ( mkList + [ mkNonRecSet (one $ "a" $= mkInt 3) @. "a" + , mkIf (mkBool True) mkNull (mkBool False) + , mkNull + , mkBool False + , mkInt 4 + , emptyList + , (@.<|>) (var "c") "d" mkNull + ] + , "[{a = 3;}.a (if true then null else false) null false 4 [] c.d or null]" + ) + +case_mixed_list_syntax_mistakes = + mistakes + "[if true then null else null]" + "[a ? b]" + "[a : a]" + "[${\"test\")]" + + +-- ** Lambdas + +case_simple_lambda = + checks + ( mkFunction (Param "a") (var "a") + , "a: a" + ) + +case_lambda_or_uri = + checks + ( mkFunction (Param "a") $ var "b" + , "a :b" + ) + ( var "a" @@ mkStr "c:def" + , "a c:def" + ) + ( mkStr "c:def:" @@ var "c" + , "c:def: c" + ) + ( mkFunction (Param "a") emptySet + , "a:{}" + ) + ( mkFunction (Param "a") $ mkList $ one $ var "a" + , "a:[a]" + ) + +case_lambda_or_uri_syntax_mistakes = + mistakes + "def:" + +case_lambda_pattern = + checks + ( mkFunction (mkParamSet args) $ var "b" + , "{b, c ? 1}: b" + -- Fix (NAbs (ParamSet [("b",Nothing),("c",Just (Fix (NConstant (NInt 1))))] False Nothing) (Fix (NSym "b"))) + ) + ( mkFunction (mkParamSet args2) $ var "b" + , "{ b ? x: x }: b" + ) + ( mkFunction (mkNamedParamSet "a" args) $ var "b" + , "a@{b,c ? 1}: b" + ) + ( mkFunction (mkNamedParamSet "a" args) $ var "c" + , "{b,c?1}@a: c" + ) + ( mkFunction (mkNamedVariadicParamSet "a" vargs) $ var "c" + , "{b,c?1,...}@a: c" + ) + ( mkFunction (mkVariadicParamSet mempty) $ mkInt 1 + , "{...}: 1" + ) + where + args = [("b", Nothing), ("c", pure $ mkInt 1)] + vargs = [("b", Nothing), ("c", pure $ mkInt 1)] + args2 = one ("b", pure lam) + lam = mkFunction (Param "x") $ var "x" + +case_lambda_pattern_syntax_mistakes = + mistakes + "a@b: a" + "{a}@{b}: a" + +case_lambda_app_int = + checks + ( mkFunction (Param "a") (var "a") @@ mkInt 3 + , "(a: a) 3" + ) + + +-- ** Let + +case_simple_let = + checks + ( mkLets (one $ "a" $= mkInt 4) $ var "a" + , "let a = 4; in a" + ) + +case_simple_let_syntax_mistakes = + mistakes + "let a = 4 in a" + +case_let_body = + checks + ( mkRecSet (one $ "body" $= mkInt 1) @. "body" + , "let { body = 1; }" + ) + +case_nested_let = + checks + ( mkLets (one $ "a" $= mkInt 4) $ + mkLets (one $ "b" $= mkInt 5) $ var "a" + , "let a = 4; in let b = 5; in a" + ) + +case_nested_let_syntax_mistakes = + mistakes + "let a = 4; let b = 3; in b" + +case_let_scoped_inherit = + checks + ( mkLets + [ "a" $= mkNull + , inheritFrom (var "b") $ one "c" + ] + $ var "c" + , "let a = null; inherit (b) c; in c" + ) + +case_let_scoped_inherit_syntax_mistakes = + mistakes + "let inherit (b) c in c" + + +-- ** If + +case_if = + checks + ( mkIf (mkBool True) (mkBool True) (mkBool False) + , "if true then true else false" + ) + +case_if_syntax_mistakes = + mistakes + "if true then false" + "else" + "if true then false else" + "if true then false else false else" + "1 + 2 then" + +-- ** If follow by with + +case_if_follow_by_with = checks + ( + mkLets (one $ "x" $= mkNonRecSet ["a" $= mkBool True, "b" $= mkInt 2 ]) + $ mkIf (mkWith (mkSym "x") (mkSym "a")) (mkInt 1) (mkInt 2) + , "let x = { a = true; b = 2; }; in if with x; a then 1 else 2" + ) + +-- ** Literal expressions in vals + +case_identifier_keyword_prefix_invariants = + invariantVals + "true-name" + "trueName" + "null-name" + "nullName" + +case_identifier_keyword_prefix = + checks + ( mkList $ one $ var "null-name" + , "[ null-name ]" + ) + + +-- ** Strings + +invariantString str = + checks + ( mkStr str + , "\"" <> str <> "\"" + ) + +case_simple_string = + knownAs invariantString + "abcdef" + "a" + "A" + " a a " + "" + +case_string_dollar = + knownAs invariantString + "a$b" + "a$$b" + "$cdef" + "gh$i" + +case_string_escape = + checks + ( mkStr "$\n\t\r\\" + , "\"\\$\\n\\t\\r\\\\\"" + ) + ( mkStr " \" ' " + , "\" \\\" \\' \"" + ) + +case_string_antiquote = + checks + ( Fix $ NStr $ DoubleQuoted + [ Plain "abc" + , Antiquoted $ mkIf (mkBool True) (mkStr "def") (mkStr "abc") + , Plain " g" + ] + , "\"abc${ if true then \"def\" else \"abc\" } g\"" + ) + ( mkStr "${a}" + , "\"\\${a}\"" + ) + +case_string_antiquote_syntax_mistakes = + mistakes + "\"a" + "${true}" + "\"${true\"" + + +-- *** Indented string + +case_indented_string = + checks + ( mkIndentedStr 0 "a" + , "''a''" + ) + ( mkIndentedStr 2 "foo\nbar" + , "''\n foo\n bar''" + ) + ( mkIndentedStr 0 mempty + , "'' ''" + ) + ( mkIndentedStr 0 "''" + , "'''''''" + ) + ( Fix $ NStr $ Indented 3 + [ Antiquoted mkNull + , Plain "\na" + , Antiquoted mkNull + ] + , "'' ${null}\n a${null}''" + ) + +case_indented_string_syntax_mistakes = + mistakes + "'''''" + "'' '" + +case_indented_string_escape = + checks + ( mkIndentedStr 1 "\n \t \\ ${ \\ \\n ' '' " + , "'' ''\\n ''\\t ''\\\\ ''${ \\ \\n ' ''' ''" + ) + +-- ** Selection + +case_select = + checks + ( Fix $ NSelect Nothing (var "a") (StaticKey "e" :| [StaticKey "di", StaticKey "f"]) + , "a . e .di. f" + ) + ( Fix $ NSelect (pure mkNull) (var "a") + (StaticKey "e" :| one (StaticKey "d")) + , "a.e . d or null" + ) + ( Fix $ NSelect (pure mkNull) emptySet + (one $ DynamicKey (Plain $ DoubleQuoted mempty)) + , "{}.\"\"or null" + ) + ( Fix $ NBinary NConcat + ((@.<|>) + (mkNonRecSet $ + one $ + NamedVar + (mkSelector "a") + (mkList $ one $ mkInt 1) + nullPos + ) + "a" + (mkList $ one $ mkInt 2) + ) + (mkList $ one $ mkInt 3) + , "{ a = [1]; }.a or [2] ++ [3]" + ) + +case_select_path = + checks + ( var "f" @@ mkRelPath "./." + , "f ./." + ) + ( var "f" @. "b" @@ mkRelPath "../a" + , "f.b ../a" + ) + ( emptySet @@ mkRelPath "./def" + , "{}./def" + ) + ( Fix (NSelect Nothing emptySet $ one $ DynamicKey $ Plain $ DoubleQuoted mempty) @@ mkRelPath "./def" + , "{}.\"\"./def" + ) + +case_select_keyword = + checks + ( mkNonRecSet $ one $ "false" $= mkStr "foo" + , "{ false = \"foo\"; }" + ) + +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: + 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: + let + case = builtins.head (builtins.attrNames v); + in (matcher.case or null).foo (v.case); + in null + |] + +-- ** Function application + +case_fun_app = + checks + ( var "f" @@ var "a" @@ var "b" + , "f a b" + ) + ( var "f" @@ (@.<|>) (var "a") "x" mkNull + , "f a.x or null" + ) + +case_fun_app_syntax_mistakes = + mistakes + "f if true then null else null" + + +-- ** Operators + +case_operator_fun_app = + checks + ( var "a" $++ var "b" + , "a ++ b" + ) + ( var "a" $++ var "f" @@ var "b" + , "a ++ f b" + ) + +case_operators = + checks + ( mkInt 1 $+ mkInt 2 $- mkInt 3 + , "1 + 2 - 3" + ) + ( mkInt 1 $+ mkIf (mkBool True) (mkInt 2) (mkInt 3) + , "1 + (if true then 2 else 3)" + ) + ( mkNonRecSet (one $ "a" $= mkInt 3) $// mkRecSet (one $ "b" $= mkInt 4) + , "{ a = 3; } // rec { b = 4; }" + ) + ( mkNeg $ mkNeg $ var "a" + , "--a" + ) + ( var "a" $- var "b" $- var "c" + , "a - b - c" + ) + ( var "foo" $< var "bar" + , "foo") (coerce . mkPos) + mkSpan = on SrcSpan (uncurry mkSPos) + in + assertParseTextLoc [text|let + foo = bar + baz "qux"; + in foo + |] + (NLetAnn + (mkSpan (1, 1) (4, 7)) + (one $ + NamedVar + (one $ StaticKey "foo") + (NAppAnn + (mkSpan (2, 7) (3, 15)) + (NAppAnn + (mkSpan (2, 7) (3, 9)) + (NSymAnn (mkSpan (2, 7) (2, 10)) "bar") + (NSymAnn (mkSpan (3, 6) (3, 9 )) "baz") + ) + (NStrAnn (mkSpan (3, 10) (3, 15)) $ DoubleQuoted $ one $ Plain "qux") + ) + (mkSPos 2 1) + ) + (NSymAnn (mkSpan (4, 4) (4, 7)) "foo") + ) + + +tests :: TestTree +tests = $testGroupGenerator + +--------------------------------------------------------------------------------- + +-- * Helpers + +var = mkSym + +invariantVal = staysInvariantUnder var + +staysInvariantUnder :: (NixLang -> ExpectedHask) -> NixLang -> Assertion +staysInvariantUnder f v = + (<=>) (f v) v + +type NixLang = Text +type ExpectedHask = NExpr + +(<=>) :: ExpectedHask -> NixLang -> Assertion +(<=>) = assertParseText + +throwParseError :: forall ann . Text -> Text -> Doc ann -> Assertion +throwParseError entity expr err = + assertFailure $ + renderString $ + layoutSmart Prettyprinter.defaultLayoutOptions $ + nest 2 $ + vsep + [ mempty + , "Unexpected fail parsing " <> reflow entity <> ":" + , nest 2 $ vsep + [ "Expression:" + , reflow expr + , "Error: " <> nest 2 err + ] + ] + +assertParseText :: ExpectedHask -> NixLang -> Assertion +assertParseText expected str = + either + (throwParseError "expression" str) + (assertEqual + ("When parsing " <> toString str) + (stripPositionInfo expected) + . stripPositionInfo + ) + (parseNixText str) + +assertParseTextLoc :: NixLang -> NExprLoc -> Assertion +assertParseTextLoc str expected = + either + (throwParseError "expression" str) + (assertEqual + ("When parsing " <> toString str) + expected + ) + (parseNixTextLoc str) + +assertParseFile :: Path -> NExpr -> Assertion +assertParseFile file expected = + do + res <- parseNixFile $ "data/" <> file + either + (throwParseError "data file" $ coerce fromString file) + (assertEqual + ("Parsing data file " <> coerce file) + (stripPositionInfo expected) + . stripPositionInfo + ) + res + +assertParseFail :: NixLang -> Assertion +assertParseFail str = + either + (const stub) + (\ r -> + assertFailure $ toString $ "\nUnexpected success parsing string ''" <> str <> "'':\n''Parsed value: ''" <> show r <> "''." + ) + (parseNixText str) + +-- assertRoundTrip :: Text -> Assertion +-- assertRoundTrip src = assertParsePrint src src + +assertParsePrint :: Text -> Text -> Assertion +assertParsePrint src expect = + let + Right expr = parseNixTextLoc src + result = + renderStrict + . layoutPretty defaultLayoutOptions + . prettyNix + . stripAnnotation $ + expr + in + assertEqual mempty expect result + + +----- + +-- | This class constructs functions that accept variacic number of argumets. +-- Every argument is an assertion. +-- So now the new assertions can be added just by adding it to a block of according assertions. +class VariadicAssertions t where + checkListPairs' :: ((ExpectedHask, NixLang) -> Assertion) -> [(ExpectedHask, NixLang)] -> t + +instance VariadicAssertions (IO a) where + checkListPairs' f acc = + do + traverse_ f acc + pure $ error "never would be reached, cuz `I'm lazy`." + +instance (VariadicAssertions a) => VariadicAssertions ((ExpectedHask, NixLang) -> a) where + checkListPairs' f acc x = checkListPairs' f (acc <> one x) + +checks :: (VariadicAssertions a) => a +checks = checkListPairs' (uncurry assertParseText) mempty + + +class VariadicArgs t where + checkList' :: (NixLang -> Assertion) -> [NixLang] -> t + +instance VariadicArgs (IO a) where + checkList' f acc = + do + traverse_ f acc + pure $ error "never would be reached, cuz `I'm lazy`." + +instance (VariadicArgs a) => VariadicArgs (NixLang -> a) where + checkList' f acc x = checkList' f (acc <> one x) + +knownAs :: (VariadicArgs a) => (NixLang -> Assertion) -> a +knownAs f = checkList' f mempty + +mistakes :: (VariadicArgs a) => a +mistakes = knownAs assertParseFail + +invariantVals :: (VariadicArgs a) => a +invariantVals = knownAs invariantVal + diff --git a/tests/PrettyParseTests.hs b/tests/PrettyParseTests.hs --- a/tests/PrettyParseTests.hs +++ b/tests/PrettyParseTests.hs @@ -1,11 +1,12 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE MonoLocalBinds #-} -{-# LANGUAGE NoMonomorphismRestriction #-} +{-# language DataKinds #-} +{-# language MonoLocalBinds #-} +{-# language NoMonomorphismRestriction #-} module PrettyParseTests where +import Nix.Prelude import Data.Algorithm.Diff import Data.Algorithm.DiffOutput import Data.Char @@ -18,34 +19,35 @@ import Nix.Expr import Nix.Parser import Nix.Pretty -import Nix.Utils import Prettyprinter import Test.Tasty import Test.Tasty.Hedgehog -import Text.Megaparsec ( Pos ) import qualified Text.Show.Pretty as PS asciiString :: MonadGen m => m String asciiString = Gen.list (Range.linear 1 15) Gen.lower asciiText :: Gen Text -asciiText = toText <$> asciiString +asciiText = fromString <$> asciiString +asciiVarName :: Gen VarName +asciiVarName = coerce <$> asciiText + -- Might want to replace this instance with a constant value -genPos :: Gen Pos -genPos = mkPos <$> Gen.int (Range.linear 1 256) +genNPos :: Gen NPos +genNPos = fmap coerce $ mkPos <$> Gen.int (Range.linear 1 256) -genSourcePos :: Gen SourcePos -genSourcePos = - liftA3 - SourcePos - asciiString - genPos - genPos +genNSourcePos :: Gen NSourcePos +genNSourcePos = + join (liftA3 + NSourcePos + (fmap coerce asciiString) + ) + genNPos genKeyName :: Gen (NKeyName NExpr) genKeyName = - Gen.choice [DynamicKey <$> genAntiquoted genString, StaticKey <$> asciiText] + Gen.choice [DynamicKey <$> genAntiquoted genString, StaticKey <$> asciiVarName] genAntiquoted :: Gen a -> Gen (Antiquoted a NExpr) genAntiquoted gen = @@ -53,51 +55,53 @@ genBinding :: Gen (Binding NExpr) genBinding = Gen.choice - [ liftA3 - NamedVar + [ liftA3 NamedVar genAttrPath genExpr - genSourcePos - , liftA3 - Inherit + genNSourcePos + , liftA3 Inherit (Gen.maybe genExpr) - (Gen.list (Range.linear 0 5) genKeyName) - genSourcePos + (Gen.list (Range.linear 0 5) asciiVarName) + genNSourcePos ] genString :: Gen (NString NExpr) genString = Gen.choice - [ DoubleQuoted <$> Gen.list (Range.linear 0 5) (genAntiquoted asciiText) - , liftA2 - Indented - (Gen.int (Range.linear 0 10)) - (Gen.list - (Range.linear 0 5) - (genAntiquoted asciiText) - ) + [ DoubleQuoted <$> genLines + , liftA2 Indented + (Gen.int $ Range.linear 0 10) + genLines ] + where + genLines = + Gen.list + (Range.linear 0 5) + (genAntiquoted asciiText) genAttrPath :: Gen (NAttrPath NExpr) genAttrPath = - liftA2 - (:|) + liftA2 (:|) genKeyName $ Gen.list (Range.linear 0 4) genKeyName genParams :: Gen (Params NExpr) genParams = Gen.choice - [ Param <$> asciiText - , liftA3 - ParamSet - (Gen.list (Range.linear 0 10) (liftA2 (,) asciiText $ Gen.maybe genExpr)) + [ Param <$> asciiVarName + , liftA3 (mkGeneralParamSet . pure) + (Gen.choice [stub, asciiText]) + (Gen.list (Range.linear 0 10) $ + liftA2 (,) + asciiText + (Gen.maybe genExpr) + ) Gen.bool - (Gen.choice [stub, pure <$> asciiText]) ] + genAtom :: Gen NAtom genAtom = Gen.choice - [ NInt <$> Gen.integral (Range.linear 0 1000) - , NFloat <$> Gen.float (Range.linearFrac 0.0 1000.0) + [ NInt <$> Gen.integral (Range.linear 0 1000 ) + , NFloat <$> Gen.float (Range.linearFrac 0.0 1000.0) , NBool <$> Gen.bool , pure NNull ] @@ -106,48 +110,65 @@ -- list Arbitrary instance which makes the generator terminate. The -- distribution is not scientifically chosen. genExpr :: Gen NExpr -genExpr = Gen.sized $ \(Size n) -> Fix <$> if n < 2 - then Gen.choice [genConstant, genStr, genSym, genLiteralPath, genEnvPath] - else Gen.frequency - [ (1 , genConstant) - , (1 , genSym) - , (4 , Gen.resize (Size (n `div` 3)) genIf) - , (10, genRecSet) - , (20, genSet) - , (5 , genList) - , (2 , genUnary) - , (2, Gen.resize (Size (n `div` 3)) genBinary) - , (3, Gen.resize (Size (n `div` 3)) genSelect) - , (20, Gen.resize (Size (n `div` 2)) genAbs) - , (2, Gen.resize (Size (n `div` 2)) genHasAttr) - , (10, Gen.resize (Size (n `div` 2)) genLet) - , (10, Gen.resize (Size (n `div` 2)) genWith) - , (1, Gen.resize (Size (n `div` 2)) genAssert) - ] +genExpr = + Gen.sized genCurbed where - genConstant = NConstant <$> genAtom - genStr = NStr <$> genString - genSym = NSym <$> asciiText - genList = NList <$> fairList genExpr - genSet = NSet NNonRecursive <$> fairList genBinding - genRecSet = NSet NRecursive <$> fairList genBinding - genLiteralPath = NLiteralPath . ("./" <>) <$> asciiString - genEnvPath = NEnvPath <$> asciiString - genUnary = liftA2 NUnary Gen.enumBounded genExpr - genBinary = liftA3 NBinary Gen.enumBounded genExpr genExpr - genSelect = liftA3 NSelect genExpr genAttrPath (Gen.maybe genExpr) - genHasAttr = liftA2 NHasAttr genExpr genAttrPath - genAbs = liftA2 NAbs genParams genExpr - genLet = liftA2 NLet (fairList genBinding) genExpr - genIf = liftA3 NIf genExpr genExpr genExpr - genWith = liftA2 NWith genExpr genExpr - genAssert = liftA2 NAssert genExpr genExpr + genCurbed (coerce -> n) = + Fix <$> + bool + small + big + (n >= 2) + where + genConstant = NConstant <$> genAtom + genStr = NStr <$> genString + genSym = NSym <$> asciiVarName + genLiteralPath = NLiteralPath . ("./" <>) . coerce <$> asciiString + genEnvPath = NEnvPath . coerce <$> asciiString + + small = Gen.choice [genConstant, genStr, genSym, genLiteralPath, genEnvPath] + + big = + let + sizeDivBy i = Size $ n `div` i + resizeDivBy i = Gen.resize (sizeDivBy i) + in + Gen.frequency + [ (1 , genConstant) + , (1 , genSym) + , (2 , genUnary) + , (5 , genList) + , (20, genSet) + , (10, genRecSet) + , (1 , resizeDivBy 2 genAssert) + , (4 , resizeDivBy 3 genIf) + , (2 , resizeDivBy 3 genBinary) + , (3 , resizeDivBy 3 genSelect) + , (20, resizeDivBy 2 genAbs) + , (2 , resizeDivBy 2 genHasAttr) + , (10, resizeDivBy 2 genLet) + , (10, resizeDivBy 2 genWith) + ] + where + genList = NList <$> fairList genExpr + genSet = NSet mempty <$> fairList genBinding + genRecSet = NSet Recursive <$> fairList genBinding + genUnary = liftA2 NUnary Gen.enumBounded genExpr + genBinary = join (liftA3 NBinary Gen.enumBounded) genExpr + genSelect = liftA3 NSelect (Gen.maybe genExpr) genExpr genAttrPath + genHasAttr = liftA2 NHasAttr genExpr genAttrPath + genAbs = liftA2 NAbs genParams genExpr + genLet = liftA2 NLet (fairList genBinding) genExpr + genIf = join (liftA3 NIf genExpr) genExpr + genWith = join (liftA2 NWith) genExpr + genAssert = join (liftA2 NAssert) genExpr + -- | Useful when there are recursive positions at each element of the list as -- it divides the size by the length of the generated list. fairList :: Gen a -> Gen [a] fairList g = Gen.sized $ \s -> do - k <- Gen.int (Range.linear 0 (unSize s)) + k <- Gen.int $ Range.linear 0 $ unSize s -- Use max here to avoid dividing by zero when there is the empty list Gen.resize (Size (unSize s `div` max 1 k)) $ Gen.list (Range.singleton k) g @@ -155,49 +176,53 @@ equivUpToNormalization x y = normalize x == normalize y normalize :: NExpr -> NExpr -normalize = foldFix $ Fix . \case +normalize = foldFix $ \case NConstant (NInt n) | n < 0 -> - NUnary NNeg $ Fix $ NConstant $ NInt $ negate n + mkNeg $ mkInt $ negate n NConstant (NFloat n) | n < 0 -> - NUnary NNeg $ Fix $ NConstant $ NFloat $ negate n + mkNeg $ mkFloat $ negate n - NSet recur binds -> NSet recur $ normBinding <$> binds - NLet binds r -> NLet (normBinding <$> binds) r + NSet recur binds -> + mkSet recur $ normBinding <$> binds + NLet binds r -> + mkLets (normBinding <$> binds) r - NAbs params r -> NAbs (normParams params) r + NAbs params r -> + mkFunction (normParams params) r - r -> r + r -> Fix r where normBinding (NamedVar path r pos) = NamedVar (normKey <$> path) r pos - normBinding (Inherit mr names pos) = Inherit mr (normKey <$> names) pos + normBinding (Inherit mr names pos) = Inherit mr names pos normKey (DynamicKey quoted) = DynamicKey (normAntiquotedString quoted) normKey (StaticKey name ) = StaticKey name normAntiquotedString - :: Antiquoted (NString NExpr) NExpr -> Antiquoted (NString NExpr) NExpr + :: Antiquoted (NString NExpr) NExpr + -> Antiquoted (NString NExpr) NExpr normAntiquotedString (Plain (DoubleQuoted [EscapedNewline])) = EscapedNewline normAntiquotedString (Plain (DoubleQuoted strs)) = - let strs' = normAntiquotedText <$> strs - in - if strs == strs' - then Plain $ DoubleQuoted strs - else normAntiquotedString $ Plain $ DoubleQuoted strs' + bool normAntiquotedString id (strs == strs') + (Plain $ DoubleQuoted strs') + where + strs' = normAntiquotedText <$> strs normAntiquotedString r = r - normAntiquotedText :: Antiquoted Text NExpr -> Antiquoted Text NExpr + normAntiquotedText + :: Antiquoted Text NExpr + -> Antiquoted Text NExpr normAntiquotedText (Plain "\n" ) = EscapedNewline normAntiquotedText (Plain "''\n") = EscapedNewline normAntiquotedText r = r - normParams (ParamSet binds var (Just "")) = ParamSet binds var mempty + normParams (ParamSet (Just "") variadic pset) = ParamSet Nothing variadic pset normParams r = r -- | Test that parse . pretty == id up to attribute position information. prop_prettyparse :: Monad m => NExpr -> PropertyT m () -prop_prettyparse p = do - let prog = show $ prettyNix p +prop_prettyparse p = either (\ s -> do footnote $ show $ vsep @@ -236,16 +261,18 @@ success (equivUpToNormalization p v) ) - (parse $ toText prog) + (parse $ fromString prog) where + prog = show $ prettyNix p + parse = parseNixText normalise s = String.unlines $ reverse . dropWhile isSpace . reverse <$> String.lines s ldiff :: String -> String -> [Diff [String]] - ldiff s1 s2 = getDiff ((: mempty) <$> String.lines s1) ((: mempty) <$> String.lines s2) + ldiff s1 s2 = getDiff (one <$> String.lines s1) (one <$> String.lines s2) tests :: TestLimit -> TestTree -tests n = testProperty "Pretty/Parse Property" $ withTests n $ property $ do - x <- forAll genExpr - prop_prettyparse x +tests n = + testProperty "Pretty/Parse Property" $ + withTests n $ property $ prop_prettyparse =<< forAll genExpr 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 +{-# language TemplateHaskell #-} +module PrettyTests ( tests ) where + +import Nix.Prelude import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.TH @@ -9,29 +11,48 @@ import Nix.Pretty case_indented_antiquotation :: Assertion -case_indented_antiquotation = do - assertPretty (mkIndentedStr 0 "echo $foo") "''echo $foo''" - assertPretty (mkIndentedStr 0 "echo ${foo}") "''echo ''${foo}''" +case_indented_antiquotation = + do + assertPretty + (mkIndentedStr 0 "echo $foo") + "''echo $foo''" + assertPretty + (mkIndentedStr 0 "echo ${foo}") + "''echo ''${foo}''" case_string_antiquotation :: Assertion -case_string_antiquotation = do - assertPretty (mkStr "echo $foo") "\"echo \\$foo\"" - assertPretty (mkStr "echo ${foo}") "\"echo \\${foo}\"" +case_string_antiquotation = + do + assertPretty + (mkStr "echo $foo") + "\"echo $foo\"" + assertPretty + (mkStr "echo ${foo}") + "\"echo \\${foo}\"" case_function_params :: Assertion case_function_params = - assertPretty (mkFunction (mkParamset mempty True) (mkInt 3)) "{ ... }:\n 3" + assertPretty + (mkFunction (mkVariadicParamSet mempty) (mkInt 3)) + "{ ... }:\n 3" case_paths :: Assertion -case_paths = do - assertPretty (mkPath False "~/test.nix") "~/test.nix" - assertPretty (mkPath False "/test.nix") "/test.nix" - assertPretty (mkPath False "./test.nix") "./test.nix" +case_paths = + do + assertPretty + (mkPath False "~/test.nix") + "~/test.nix" + assertPretty + (mkPath False "/test.nix") + "/test.nix" + assertPretty + (mkPath False "./test.nix") + "./test.nix" tests :: TestTree tests = $testGroupGenerator --------------------------------------------------------------------------------- -assertPretty :: NExpr -> String -> Assertion +assertPretty :: NExpr -> Text -> Assertion assertPretty e s = assertEqual ("When pretty-printing " <> show e) s . show $ prettyNix e diff --git a/tests/ReduceExprTests.hs b/tests/ReduceExprTests.hs --- a/tests/ReduceExprTests.hs +++ b/tests/ReduceExprTests.hs @@ -1,14 +1,16 @@ -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# options_ghc -fno-warn-name-shadowing #-} + module ReduceExprTests (tests) where -import Data.Fix + +import Nix.Prelude import Test.Tasty import Test.Tasty.HUnit -import Nix.Atoms import Nix.Expr.Types import Nix.Expr.Types.Annotated import Nix.Parser import Nix.Reduce ( reduceExpr ) +import Nix.Expr.Shorthands tests :: TestTree @@ -46,13 +48,13 @@ selectBasic = parseNixTextLoc "{b=2;a=42;}.a" selectBasicExpect :: NExpr -selectBasicExpect = Fix . NConstant $ NInt 42 +selectBasicExpect = mkInt 42 selectNested :: Result NExprLoc selectNested = parseNixTextLoc "{a={b=2;a=42;};b={a=2;};}.a.a" selectNestedExpect :: NExpr -selectNestedExpect = Fix . NConstant $ NInt 42 +selectNestedExpect = mkInt 42 selectIncorrectAttrPath :: Result NExprLoc selectIncorrectAttrPath = parseNixTextLoc "{a=42;}.b" diff --git a/tests/TestCommon.hs b/tests/TestCommon.hs --- a/tests/TestCommon.hs +++ b/tests/TestCommon.hs @@ -1,75 +1,82 @@ -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} - 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.Posix.Files -import System.Posix.Temp +import System.PosixCompat.Files +import System.PosixCompat.Temp import System.Process import Test.Tasty.HUnit -hnixEvalFile :: Options -> FilePath -> IO (StdValue (StandardT (StdIdT IO))) +hnixEvalFile :: Options -> Path -> IO StdVal hnixEvalFile opts file = do parseResult <- parseNixFileLoc file either - (\ err -> fail $ "Parsing failed for file `" <> file <> "`.\n" <> show err) + (\ err -> fail $ "Parsing failed for file `" <> coerce file <> "`.\n" <> show err) (\ expr -> do setEnv "TEST_VAR" "foo" runWithBasicEffects opts $ - catch (evaluateExpression (pure 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 :: String -> IO String -nixEvalString expr = do - (fp, h) <- mkstemp "nix-test-eval" - hPutStr h expr - hClose h - res <- nixEvalFile fp - removeLink fp - pure res +nixEvalText :: Text -> IO Text +nixEvalText expr = + do + (fp, h) <- mkstemp "nix-test-eval" + Text.hPutStr h expr + hClose h + res <- nixEvalFile $ coerce fp + removeLink fp + pure res -nixEvalFile :: FilePath -> IO String -nixEvalFile fp = readProcess "nix-instantiate" ["--eval", "--strict", fp] "" +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 -assertEvalFileMatchesNix :: FilePath -> Assertion -assertEvalFileMatchesNix fp = do - time <- liftIO getCurrentTime - hnixVal <- (<> "\n") . printNix <$> hnixEvalFile (defaultOptions time) fp - nixVal <- nixEvalFile fp - assertEqual fp nixVal hnixVal +-- | Compares @HNix@ & @Nix@ return results. +assertEvalFileMatchesNix :: Path -> Assertion +assertEvalFileMatchesNix fp = + 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 expr' nixVal hnixVal - where - expr' = toString expr +assertEvalTextMatchesNix :: Text -> Assertion +assertEvalTextMatchesNix = + assertEvalMatchesNix hnixEvalText nixEvalText