diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -24,7 +24,7 @@ # To run all of the tests, which takes up to a minute: $ env ALL_TESTS=yes cabal test # To run only specific tests (see `tests/Main.hs` for a list) -$ env NIXPKGS_TESTS=yes PRETTY_TESTS=yes cabal test +$ env NIXPKGS_TESTS=yes PRETTY_TESTS=1 cabal test $ ./dist/build/hnix/hnix --help ``` @@ -89,8 +89,18 @@ This will build an `hnix` library that can be linked to your GHCJS application. +## Using the Cachix binary cache + +If you're on macOS, you can use the binary cache at Cachix to avoid building +the specific dependencies used by hnix. Just use these commands: + + nix-env -iA cachix -f https://github.com/NixOS/nixpkgs/tarball/db557aab7b690f5e0e3348459f2e4dc8fd0d9298 + cachix use hnix + ## How you can help +### Issue Tracker Backlog + If you're looking for a way to help out, try taking a look [here](https://github.com/haskell-nix/hnix/issues?q=is%3Aissue+is%3Aopen+label%3A%22help+wanted%22+no%3Aassignee). When you find an issue that looks interesting to you, comment on the ticket to @@ -106,3 +116,13 @@ Make sure that all the tests that were passing prior to your PR are still passing afterwards; it's OK if no new tests are passing. + +### Evaluating Nixpkgs with HNix + +Currently the main high-level goal is to be able to evaluate all of nixpkgs. To +run this yourself, first build hnix with `nix-build`, then run the following +command: + +``` +./result/bin/hnix --eval -E "import {}" --find +``` diff --git a/benchmarks/Main.hs b/benchmarks/Main.hs --- a/benchmarks/Main.hs +++ b/benchmarks/Main.hs @@ -1,10 +1,8 @@ module Main where -import Criterion.Main +import Criterion.Main import qualified ParserBench main :: IO () -main = defaultMain - [ ParserBench.benchmarks - ] +main = defaultMain [ParserBench.benchmarks] diff --git a/benchmarks/ParserBench.hs b/benchmarks/ParserBench.hs --- a/benchmarks/ParserBench.hs +++ b/benchmarks/ParserBench.hs @@ -1,15 +1,16 @@ module ParserBench (benchmarks) where -import Nix.Parser +import Nix.Parser -import Control.Applicative -import Criterion +import Control.Applicative +import Criterion benchFile :: FilePath -> Benchmark benchFile = bench <*> whnfIO . parseNixFile . ("data/" ++) benchmarks :: Benchmark -benchmarks = bgroup "Parser" +benchmarks = bgroup + "Parser" [ benchFile "nixpkgs-all-packages.nix" , benchFile "nixpkgs-all-packages-pretty.nix" , benchFile "let-comments.nix" diff --git a/data/nix/Makefile b/data/nix/Makefile --- a/data/nix/Makefile +++ b/data/nix/Makefile @@ -5,17 +5,7 @@ src/libmain/local.mk \ src/libexpr/local.mk \ src/nix/local.mk \ - src/nix-store/local.mk \ - src/nix-instantiate/local.mk \ - src/nix-env/local.mk \ - src/nix-daemon/local.mk \ - src/nix-collect-garbage/local.mk \ - src/nix-copy-closure/local.mk \ - src/nix-prefetch-url/local.mk \ src/resolve-system-dependencies/local.mk \ - src/nix-channel/local.mk \ - src/nix-build/local.mk \ - src/build-remote/local.mk \ scripts/local.mk \ corepkgs/local.mk \ misc/systemd/local.mk \ diff --git a/data/nix/Makefile.config.in b/data/nix/Makefile.config.in --- a/data/nix/Makefile.config.in +++ b/data/nix/Makefile.config.in @@ -1,4 +1,6 @@ +AR = @AR@ BDW_GC_LIBS = @BDW_GC_LIBS@ +BUILD_SHARED_LIBS = @BUILD_SHARED_LIBS@ CC = @CC@ CFLAGS = @CFLAGS@ CXX = @CXX@ @@ -6,7 +8,6 @@ ENABLE_S3 = @ENABLE_S3@ HAVE_SODIUM = @HAVE_SODIUM@ HAVE_READLINE = @HAVE_READLINE@ -HAVE_BROTLI = @HAVE_BROTLI@ HAVE_SECCOMP = @HAVE_SECCOMP@ LIBCURL_LIBS = @LIBCURL_LIBS@ OPENSSL_LIBS = @OPENSSL_LIBS@ @@ -16,9 +17,9 @@ LIBLZMA_LIBS = @LIBLZMA_LIBS@ SQLITE3_LIBS = @SQLITE3_LIBS@ LIBBROTLI_LIBS = @LIBBROTLI_LIBS@ +EDITLINE_LIBS = @EDITLINE_LIBS@ bash = @bash@ bindir = @bindir@ -brotli = @brotli@ lsof = @lsof@ datadir = @datadir@ datarootdir = @datarootdir@ diff --git a/data/nix/config/config.guess b/data/nix/config/config.guess --- a/data/nix/config/config.guess +++ b/data/nix/config/config.guess @@ -1,14 +1,12 @@ #! /bin/sh # Attempt to guess a canonical system name. -# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, -# 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, -# 2011, 2012 Free Software Foundation, Inc. +# Copyright 1992-2018 Free Software Foundation, Inc. -timestamp='2012-08-14' +timestamp='2018-08-02' # This file is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 2 of the License, or +# the Free Software Foundation; either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, but @@ -17,25 +15,23 @@ # General Public License for more details. # # You should have received a copy of the GNU General Public License -# along with this program; if not, see . +# along with this program; if not, see . # # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under -# the same distribution terms that you use for the rest of that program. - - -# Originally written by Per Bothner. Please send patches (context -# diff format) to and include a ChangeLog -# entry. +# the same distribution terms that you use for the rest of that +# program. This Exception is an additional permission under section 7 +# of the GNU General Public License, version 3 ("GPLv3"). # -# This script attempts to guess a canonical system name similar to -# config.sub. If it succeeds, it prints the system name on stdout, and -# exits with 0. Otherwise, it exits with 1. +# Originally written by Per Bothner; maintained since 2000 by Ben Elliston. # # You can get the latest version of this script from: -# http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess;hb=HEAD +# https://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess +# +# Please send patches to . + me=`echo "$0" | sed -e 's,.*/,,'` usage="\ @@ -43,7 +39,7 @@ Output the configuration name of the system \`$me' is run on. -Operation modes: +Options: -h, --help print this help, then exit -t, --time-stamp print date of last modification, then exit -v, --version print version number, then exit @@ -54,9 +50,7 @@ GNU config.guess ($timestamp) Originally written by Per Bothner. -Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, -2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 -Free Software Foundation, Inc. +Copyright 1992-2018 Free Software Foundation, Inc. This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." @@ -90,8 +84,6 @@ exit 1 fi -trap 'exit 1' 1 2 15 - # CC_FOR_BUILD -- compiler used by this script. Note that the use of a # compiler to aid in system detection is discouraged as it requires # temporary files to be created and, as you can see below, it is a @@ -102,34 +94,39 @@ # Portable tmp directory creation inspired by the Autoconf team. -set_cc_for_build=' -trap "exitcode=\$?; (rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null) && exit \$exitcode" 0 ; -trap "rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null; exit 1" 1 2 13 15 ; -: ${TMPDIR=/tmp} ; - { tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } || - { test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir $tmp) ; } || - { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir $tmp) && echo "Warning: creating insecure temp directory" >&2 ; } || - { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } ; -dummy=$tmp/dummy ; -tmpfiles="$dummy.c $dummy.o $dummy.rel $dummy" ; -case $CC_FOR_BUILD,$HOST_CC,$CC in - ,,) echo "int x;" > $dummy.c ; - for c in cc gcc c89 c99 ; do - if ($c -c -o $dummy.o $dummy.c) >/dev/null 2>&1 ; then - CC_FOR_BUILD="$c"; break ; - fi ; - done ; - if test x"$CC_FOR_BUILD" = x ; then - CC_FOR_BUILD=no_compiler_found ; - fi - ;; - ,,*) CC_FOR_BUILD=$CC ;; - ,*,*) CC_FOR_BUILD=$HOST_CC ;; -esac ; set_cc_for_build= ;' +tmp= +# shellcheck disable=SC2172 +trap 'test -z "$tmp" || rm -fr "$tmp"' 1 2 13 15 +trap 'exitcode=$?; test -z "$tmp" || rm -fr "$tmp"; exit $exitcode' 0 +set_cc_for_build() { + : "${TMPDIR=/tmp}" + # shellcheck disable=SC2039 + { tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } || + { test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir "$tmp" 2>/dev/null) ; } || + { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir "$tmp" 2>/dev/null) && echo "Warning: creating insecure temp directory" >&2 ; } || + { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } + dummy=$tmp/dummy + case ${CC_FOR_BUILD-},${HOST_CC-},${CC-} in + ,,) echo "int x;" > "$dummy.c" + for driver in cc gcc c89 c99 ; do + if ($driver -c -o "$dummy.o" "$dummy.c") >/dev/null 2>&1 ; then + CC_FOR_BUILD="$driver" + break + fi + done + if test x"$CC_FOR_BUILD" = x ; then + CC_FOR_BUILD=no_compiler_found + fi + ;; + ,,*) CC_FOR_BUILD=$CC ;; + ,*,*) CC_FOR_BUILD=$HOST_CC ;; + esac +} + # This is needed to find uname on a Pyramid OSx when run in the BSD universe. # (ghazi@noc.rutgers.edu 1994-08-24) -if (test -f /.attbin/uname) >/dev/null 2>&1 ; then +if test -f /.attbin/uname ; then PATH=$PATH:/.attbin ; export PATH fi @@ -138,9 +135,37 @@ UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown +case "$UNAME_SYSTEM" in +Linux|GNU|GNU/*) + # If the system lacks a compiler, then just pick glibc. + # We could probably try harder. + LIBC=gnu + + set_cc_for_build + cat <<-EOF > "$dummy.c" + #include + #if defined(__UCLIBC__) + LIBC=uclibc + #elif defined(__dietlibc__) + LIBC=dietlibc + #else + LIBC=gnu + #endif + EOF + eval "`$CC_FOR_BUILD -E "$dummy.c" 2>/dev/null | grep '^LIBC' | sed 's, ,,g'`" + + # If ldd exists, use it to detect musl libc. + if command -v ldd >/dev/null && \ + ldd --version 2>&1 | grep -q ^musl + then + LIBC=musl + fi + ;; +esac + # Note: order is significant - the case branches are not exclusive. -case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in +case "$UNAME_MACHINE:$UNAME_SYSTEM:$UNAME_RELEASE:$UNAME_VERSION" in *:NetBSD:*:*) # NetBSD (nbsd) targets should (where applicable) match one or # more of the tuples: *-*-netbsdelf*, *-*-netbsdaout*, @@ -153,21 +178,31 @@ # Note: NetBSD doesn't particularly care about the vendor # portion of the name. We always set it to "unknown". sysctl="sysctl -n hw.machine_arch" - UNAME_MACHINE_ARCH=`(/sbin/$sysctl 2>/dev/null || \ - /usr/sbin/$sysctl 2>/dev/null || echo unknown)` - case "${UNAME_MACHINE_ARCH}" in + UNAME_MACHINE_ARCH=`(uname -p 2>/dev/null || \ + "/sbin/$sysctl" 2>/dev/null || \ + "/usr/sbin/$sysctl" 2>/dev/null || \ + echo unknown)` + case "$UNAME_MACHINE_ARCH" in armeb) machine=armeb-unknown ;; arm*) machine=arm-unknown ;; sh3el) machine=shl-unknown ;; sh3eb) machine=sh-unknown ;; sh5el) machine=sh5le-unknown ;; - *) machine=${UNAME_MACHINE_ARCH}-unknown ;; + earmv*) + arch=`echo "$UNAME_MACHINE_ARCH" | sed -e 's,^e\(armv[0-9]\).*$,\1,'` + endian=`echo "$UNAME_MACHINE_ARCH" | sed -ne 's,^.*\(eb\)$,\1,p'` + machine="${arch}${endian}"-unknown + ;; + *) machine="$UNAME_MACHINE_ARCH"-unknown ;; esac # The Operating System including object format, if it has switched - # to ELF recently, or will in the future. - case "${UNAME_MACHINE_ARCH}" in + # to ELF recently (or will in the future) and ABI. + case "$UNAME_MACHINE_ARCH" in + earm*) + os=netbsdelf + ;; arm*|i386|m68k|ns32k|sh3*|sparc|vax) - eval $set_cc_for_build + set_cc_for_build if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \ | grep -q __ELF__ then @@ -182,44 +217,67 @@ os=netbsd ;; esac + # Determine ABI tags. + case "$UNAME_MACHINE_ARCH" in + earm*) + expr='s/^earmv[0-9]/-eabi/;s/eb$//' + abi=`echo "$UNAME_MACHINE_ARCH" | sed -e "$expr"` + ;; + esac # The OS release # Debian GNU/NetBSD machines have a different userland, and # thus, need a distinct triplet. However, they do not need # kernel version information, so it can be replaced with a # suitable tag, in the style of linux-gnu. - case "${UNAME_VERSION}" in + case "$UNAME_VERSION" in Debian*) release='-gnu' ;; *) - release=`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'` + release=`echo "$UNAME_RELEASE" | sed -e 's/[-_].*//' | cut -d. -f1,2` ;; esac # Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM: # contains redundant information, the shorter form: # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used. - echo "${machine}-${os}${release}" + echo "$machine-${os}${release}${abi-}" exit ;; *:Bitrig:*:*) UNAME_MACHINE_ARCH=`arch | sed 's/Bitrig.//'` - echo ${UNAME_MACHINE_ARCH}-unknown-bitrig${UNAME_RELEASE} + echo "$UNAME_MACHINE_ARCH"-unknown-bitrig"$UNAME_RELEASE" exit ;; *:OpenBSD:*:*) UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'` - echo ${UNAME_MACHINE_ARCH}-unknown-openbsd${UNAME_RELEASE} + echo "$UNAME_MACHINE_ARCH"-unknown-openbsd"$UNAME_RELEASE" exit ;; + *:LibertyBSD:*:*) + UNAME_MACHINE_ARCH=`arch | sed 's/^.*BSD\.//'` + echo "$UNAME_MACHINE_ARCH"-unknown-libertybsd"$UNAME_RELEASE" + exit ;; + *:MidnightBSD:*:*) + echo "$UNAME_MACHINE"-unknown-midnightbsd"$UNAME_RELEASE" + exit ;; *:ekkoBSD:*:*) - echo ${UNAME_MACHINE}-unknown-ekkobsd${UNAME_RELEASE} + echo "$UNAME_MACHINE"-unknown-ekkobsd"$UNAME_RELEASE" exit ;; *:SolidBSD:*:*) - echo ${UNAME_MACHINE}-unknown-solidbsd${UNAME_RELEASE} + echo "$UNAME_MACHINE"-unknown-solidbsd"$UNAME_RELEASE" exit ;; macppc:MirBSD:*:*) - echo powerpc-unknown-mirbsd${UNAME_RELEASE} + echo powerpc-unknown-mirbsd"$UNAME_RELEASE" exit ;; *:MirBSD:*:*) - echo ${UNAME_MACHINE}-unknown-mirbsd${UNAME_RELEASE} + echo "$UNAME_MACHINE"-unknown-mirbsd"$UNAME_RELEASE" exit ;; + *:Sortix:*:*) + echo "$UNAME_MACHINE"-unknown-sortix + exit ;; + *:Redox:*:*) + echo "$UNAME_MACHINE"-unknown-redox + exit ;; + mips:OSF1:*.*) + echo mips-dec-osf1 + exit ;; alpha:OSF1:*:*) case $UNAME_RELEASE in *4.0) @@ -236,63 +294,54 @@ ALPHA_CPU_TYPE=`/usr/sbin/psrinfo -v | sed -n -e 's/^ The alpha \(.*\) processor.*$/\1/p' | head -n 1` case "$ALPHA_CPU_TYPE" in "EV4 (21064)") - UNAME_MACHINE="alpha" ;; + UNAME_MACHINE=alpha ;; "EV4.5 (21064)") - UNAME_MACHINE="alpha" ;; + UNAME_MACHINE=alpha ;; "LCA4 (21066/21068)") - UNAME_MACHINE="alpha" ;; + UNAME_MACHINE=alpha ;; "EV5 (21164)") - UNAME_MACHINE="alphaev5" ;; + UNAME_MACHINE=alphaev5 ;; "EV5.6 (21164A)") - UNAME_MACHINE="alphaev56" ;; + UNAME_MACHINE=alphaev56 ;; "EV5.6 (21164PC)") - UNAME_MACHINE="alphapca56" ;; + UNAME_MACHINE=alphapca56 ;; "EV5.7 (21164PC)") - UNAME_MACHINE="alphapca57" ;; + UNAME_MACHINE=alphapca57 ;; "EV6 (21264)") - UNAME_MACHINE="alphaev6" ;; + UNAME_MACHINE=alphaev6 ;; "EV6.7 (21264A)") - UNAME_MACHINE="alphaev67" ;; + UNAME_MACHINE=alphaev67 ;; "EV6.8CB (21264C)") - UNAME_MACHINE="alphaev68" ;; + UNAME_MACHINE=alphaev68 ;; "EV6.8AL (21264B)") - UNAME_MACHINE="alphaev68" ;; + UNAME_MACHINE=alphaev68 ;; "EV6.8CX (21264D)") - UNAME_MACHINE="alphaev68" ;; + UNAME_MACHINE=alphaev68 ;; "EV6.9A (21264/EV69A)") - UNAME_MACHINE="alphaev69" ;; + UNAME_MACHINE=alphaev69 ;; "EV7 (21364)") - UNAME_MACHINE="alphaev7" ;; + UNAME_MACHINE=alphaev7 ;; "EV7.9 (21364A)") - UNAME_MACHINE="alphaev79" ;; + UNAME_MACHINE=alphaev79 ;; esac # A Pn.n version is a patched version. # A Vn.n version is a released version. # A Tn.n version is a released field test version. # A Xn.n version is an unreleased experimental baselevel. # 1.2 uses "1.2" for uname -r. - echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[PVTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` + echo "$UNAME_MACHINE"-dec-osf"`echo "$UNAME_RELEASE" | sed -e 's/^[PVTX]//' | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz`" # Reset EXIT trap before exiting to avoid spurious non-zero exit code. exitcode=$? trap '' 0 exit $exitcode ;; - Alpha\ *:Windows_NT*:*) - # How do we know it's Interix rather than the generic POSIX subsystem? - # Should we change UNAME_MACHINE based on the output of uname instead - # of the specific Alpha model? - echo alpha-pc-interix - exit ;; - 21064:Windows_NT:50:3) - echo alpha-dec-winnt3.5 - exit ;; Amiga*:UNIX_System_V:4.0:*) echo m68k-unknown-sysv4 exit ;; *:[Aa]miga[Oo][Ss]:*:*) - echo ${UNAME_MACHINE}-unknown-amigaos + echo "$UNAME_MACHINE"-unknown-amigaos exit ;; *:[Mm]orph[Oo][Ss]:*:*) - echo ${UNAME_MACHINE}-unknown-morphos + echo "$UNAME_MACHINE"-unknown-morphos exit ;; *:OS/390:*:*) echo i370-ibm-openedition @@ -304,9 +353,9 @@ echo powerpc-ibm-os400 exit ;; arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) - echo arm-acorn-riscix${UNAME_RELEASE} + echo arm-acorn-riscix"$UNAME_RELEASE" exit ;; - arm:riscos:*:*|arm:RISCOS:*:*) + arm*:riscos:*:*|arm*:RISCOS:*:*) echo arm-unknown-riscos exit ;; SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*) @@ -331,38 +380,33 @@ sparc) echo sparc-icl-nx7; exit ;; esac ;; s390x:SunOS:*:*) - echo ${UNAME_MACHINE}-ibm-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + echo "$UNAME_MACHINE"-ibm-solaris2"`echo "$UNAME_RELEASE" | sed -e 's/[^.]*//'`" exit ;; sun4H:SunOS:5.*:*) - echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + echo sparc-hal-solaris2"`echo "$UNAME_RELEASE"|sed -e 's/[^.]*//'`" exit ;; sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*) - echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + echo sparc-sun-solaris2"`echo "$UNAME_RELEASE" | sed -e 's/[^.]*//'`" exit ;; i86pc:AuroraUX:5.*:* | i86xen:AuroraUX:5.*:*) - echo i386-pc-auroraux${UNAME_RELEASE} + echo i386-pc-auroraux"$UNAME_RELEASE" exit ;; i86pc:SunOS:5.*:* | i86xen:SunOS:5.*:*) - eval $set_cc_for_build - SUN_ARCH="i386" - # If there is a compiler, see if it is configured for 64-bit objects. - # Note that the Sun cc does not turn __LP64__ into 1 like gcc does. - # This test works for both compilers. - if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then - if (echo '#ifdef __amd64'; echo IS_64BIT_ARCH; echo '#endif') | \ - (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ - grep IS_64BIT_ARCH >/dev/null - then - SUN_ARCH="x86_64" - fi - fi - echo ${SUN_ARCH}-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + UNAME_REL="`echo "$UNAME_RELEASE" | sed -e 's/[^.]*//'`" + case `isainfo -b` in + 32) + echo i386-pc-solaris2"$UNAME_REL" + ;; + 64) + echo x86_64-pc-solaris2"$UNAME_REL" + ;; + esac exit ;; sun4*:SunOS:6*:*) # According to config.sub, this is the proper way to canonicalize # SunOS6. Hard to guess exactly what SunOS6 will be like, but # it's likely to be more like Solaris than SunOS4. - echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + echo sparc-sun-solaris3"`echo "$UNAME_RELEASE"|sed -e 's/[^.]*//'`" exit ;; sun4*:SunOS:*:*) case "`/usr/bin/arch -k`" in @@ -371,25 +415,25 @@ ;; esac # Japanese Language versions have a version number like `4.1.3-JL'. - echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'` + echo sparc-sun-sunos"`echo "$UNAME_RELEASE"|sed -e 's/-/_/'`" exit ;; sun3*:SunOS:*:*) - echo m68k-sun-sunos${UNAME_RELEASE} + echo m68k-sun-sunos"$UNAME_RELEASE" exit ;; sun*:*:4.2BSD:*) UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null` - test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3 + test "x$UNAME_RELEASE" = x && UNAME_RELEASE=3 case "`/bin/arch`" in sun3) - echo m68k-sun-sunos${UNAME_RELEASE} + echo m68k-sun-sunos"$UNAME_RELEASE" ;; sun4) - echo sparc-sun-sunos${UNAME_RELEASE} + echo sparc-sun-sunos"$UNAME_RELEASE" ;; esac exit ;; aushp:SunOS:*:*) - echo sparc-auspex-sunos${UNAME_RELEASE} + echo sparc-auspex-sunos"$UNAME_RELEASE" exit ;; # The situation for MiNT is a little confusing. The machine name # can be virtually everything (everything which is not @@ -400,44 +444,44 @@ # MiNT. But MiNT is downward compatible to TOS, so this should # be no problem. atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*) - echo m68k-atari-mint${UNAME_RELEASE} + echo m68k-atari-mint"$UNAME_RELEASE" exit ;; atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*) - echo m68k-atari-mint${UNAME_RELEASE} + echo m68k-atari-mint"$UNAME_RELEASE" exit ;; *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*) - echo m68k-atari-mint${UNAME_RELEASE} + echo m68k-atari-mint"$UNAME_RELEASE" exit ;; milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*) - echo m68k-milan-mint${UNAME_RELEASE} + echo m68k-milan-mint"$UNAME_RELEASE" exit ;; hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*) - echo m68k-hades-mint${UNAME_RELEASE} + echo m68k-hades-mint"$UNAME_RELEASE" exit ;; *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*) - echo m68k-unknown-mint${UNAME_RELEASE} + echo m68k-unknown-mint"$UNAME_RELEASE" exit ;; m68k:machten:*:*) - echo m68k-apple-machten${UNAME_RELEASE} + echo m68k-apple-machten"$UNAME_RELEASE" exit ;; powerpc:machten:*:*) - echo powerpc-apple-machten${UNAME_RELEASE} + echo powerpc-apple-machten"$UNAME_RELEASE" exit ;; RISC*:Mach:*:*) echo mips-dec-mach_bsd4.3 exit ;; RISC*:ULTRIX:*:*) - echo mips-dec-ultrix${UNAME_RELEASE} + echo mips-dec-ultrix"$UNAME_RELEASE" exit ;; VAX*:ULTRIX*:*:*) - echo vax-dec-ultrix${UNAME_RELEASE} + echo vax-dec-ultrix"$UNAME_RELEASE" exit ;; 2020:CLIX:*:* | 2430:CLIX:*:*) - echo clipper-intergraph-clix${UNAME_RELEASE} + echo clipper-intergraph-clix"$UNAME_RELEASE" exit ;; mips:*:*:UMIPS | mips:*:*:RISCos) - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c + set_cc_for_build + sed 's/^ //' << EOF > "$dummy.c" #ifdef __cplusplus #include /* for printf() prototype */ int main (int argc, char *argv[]) { @@ -446,23 +490,23 @@ #endif #if defined (host_mips) && defined (MIPSEB) #if defined (SYSTYPE_SYSV) - printf ("mips-mips-riscos%ssysv\n", argv[1]); exit (0); + printf ("mips-mips-riscos%ssysv\\n", argv[1]); exit (0); #endif #if defined (SYSTYPE_SVR4) - printf ("mips-mips-riscos%ssvr4\n", argv[1]); exit (0); + printf ("mips-mips-riscos%ssvr4\\n", argv[1]); exit (0); #endif #if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD) - printf ("mips-mips-riscos%sbsd\n", argv[1]); exit (0); + printf ("mips-mips-riscos%sbsd\\n", argv[1]); exit (0); #endif #endif exit (-1); } EOF - $CC_FOR_BUILD -o $dummy $dummy.c && - dummyarg=`echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` && - SYSTEM_NAME=`$dummy $dummyarg` && + $CC_FOR_BUILD -o "$dummy" "$dummy.c" && + dummyarg=`echo "$UNAME_RELEASE" | sed -n 's/\([0-9]*\).*/\1/p'` && + SYSTEM_NAME=`"$dummy" "$dummyarg"` && { echo "$SYSTEM_NAME"; exit; } - echo mips-mips-riscos${UNAME_RELEASE} + echo mips-mips-riscos"$UNAME_RELEASE" exit ;; Motorola:PowerMAX_OS:*:*) echo powerpc-motorola-powermax @@ -488,17 +532,17 @@ AViiON:dgux:*:*) # DG/UX returns AViiON for all architectures UNAME_PROCESSOR=`/usr/bin/uname -p` - if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ] + if [ "$UNAME_PROCESSOR" = mc88100 ] || [ "$UNAME_PROCESSOR" = mc88110 ] then - if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \ - [ ${TARGET_BINARY_INTERFACE}x = x ] + if [ "$TARGET_BINARY_INTERFACE"x = m88kdguxelfx ] || \ + [ "$TARGET_BINARY_INTERFACE"x = x ] then - echo m88k-dg-dgux${UNAME_RELEASE} + echo m88k-dg-dgux"$UNAME_RELEASE" else - echo m88k-dg-dguxbcs${UNAME_RELEASE} + echo m88k-dg-dguxbcs"$UNAME_RELEASE" fi else - echo i586-dg-dgux${UNAME_RELEASE} + echo i586-dg-dgux"$UNAME_RELEASE" fi exit ;; M88*:DolphinOS:*:*) # DolphinOS (SVR3) @@ -515,7 +559,7 @@ echo m68k-tektronix-bsd exit ;; *:IRIX*:*:*) - echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'` + echo mips-sgi-irix"`echo "$UNAME_RELEASE"|sed -e 's/-/_/g'`" exit ;; ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX. echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id @@ -527,14 +571,14 @@ if [ -x /usr/bin/oslevel ] ; then IBM_REV=`/usr/bin/oslevel` else - IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} + IBM_REV="$UNAME_VERSION.$UNAME_RELEASE" fi - echo ${UNAME_MACHINE}-ibm-aix${IBM_REV} + echo "$UNAME_MACHINE"-ibm-aix"$IBM_REV" exit ;; *:AIX:2:3) if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c + set_cc_for_build + sed 's/^ //' << EOF > "$dummy.c" #include main() @@ -545,7 +589,7 @@ exit(0); } EOF - if $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` + if $CC_FOR_BUILD -o "$dummy" "$dummy.c" && SYSTEM_NAME=`"$dummy"` then echo "$SYSTEM_NAME" else @@ -559,26 +603,27 @@ exit ;; *:AIX:*:[4567]) IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'` - if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then + if /usr/sbin/lsattr -El "$IBM_CPU_ID" | grep ' POWER' >/dev/null 2>&1; then IBM_ARCH=rs6000 else IBM_ARCH=powerpc fi - if [ -x /usr/bin/oslevel ] ; then - IBM_REV=`/usr/bin/oslevel` + if [ -x /usr/bin/lslpp ] ; then + IBM_REV=`/usr/bin/lslpp -Lqc bos.rte.libc | + awk -F: '{ print $3 }' | sed s/[0-9]*$/0/` else - IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} + IBM_REV="$UNAME_VERSION.$UNAME_RELEASE" fi - echo ${IBM_ARCH}-ibm-aix${IBM_REV} + echo "$IBM_ARCH"-ibm-aix"$IBM_REV" exit ;; *:AIX:*:*) echo rs6000-ibm-aix exit ;; - ibmrt:4.4BSD:*|romp-ibm:BSD:*) + ibmrt:4.4BSD:*|romp-ibm:4.4BSD:*) echo romp-ibm-bsd4.4 exit ;; ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and - echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to + echo romp-ibm-bsd"$UNAME_RELEASE" # 4.3 with uname added to exit ;; # report: romp-ibm BSD 4.3 *:BOSX:*:*) echo rs6000-bull-bosx @@ -593,28 +638,28 @@ echo m68k-hp-bsd4.4 exit ;; 9000/[34678]??:HP-UX:*:*) - HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` - case "${UNAME_MACHINE}" in - 9000/31? ) HP_ARCH=m68000 ;; - 9000/[34]?? ) HP_ARCH=m68k ;; + HPUX_REV=`echo "$UNAME_RELEASE"|sed -e 's/[^.]*.[0B]*//'` + case "$UNAME_MACHINE" in + 9000/31?) HP_ARCH=m68000 ;; + 9000/[34]??) HP_ARCH=m68k ;; 9000/[678][0-9][0-9]) if [ -x /usr/bin/getconf ]; then sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null` sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null` - case "${sc_cpu_version}" in - 523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0 - 528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1 + case "$sc_cpu_version" in + 523) HP_ARCH=hppa1.0 ;; # CPU_PA_RISC1_0 + 528) HP_ARCH=hppa1.1 ;; # CPU_PA_RISC1_1 532) # CPU_PA_RISC2_0 - case "${sc_kernel_bits}" in - 32) HP_ARCH="hppa2.0n" ;; - 64) HP_ARCH="hppa2.0w" ;; - '') HP_ARCH="hppa2.0" ;; # HP-UX 10.20 + case "$sc_kernel_bits" in + 32) HP_ARCH=hppa2.0n ;; + 64) HP_ARCH=hppa2.0w ;; + '') HP_ARCH=hppa2.0 ;; # HP-UX 10.20 esac ;; esac fi - if [ "${HP_ARCH}" = "" ]; then - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c + if [ "$HP_ARCH" = "" ]; then + set_cc_for_build + sed 's/^ //' << EOF > "$dummy.c" #define _HPUX_SOURCE #include @@ -647,13 +692,13 @@ exit (0); } EOF - (CCOPTS= $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null) && HP_ARCH=`$dummy` + (CCOPTS="" $CC_FOR_BUILD -o "$dummy" "$dummy.c" 2>/dev/null) && HP_ARCH=`"$dummy"` test -z "$HP_ARCH" && HP_ARCH=hppa fi ;; esac - if [ ${HP_ARCH} = "hppa2.0w" ] + if [ "$HP_ARCH" = hppa2.0w ] then - eval $set_cc_for_build + set_cc_for_build # hppa2.0w-hp-hpux* has a 64-bit kernel and a compiler generating # 32-bit code. hppa64-hp-hpux* has the same kernel and a compiler @@ -664,23 +709,23 @@ # $ CC_FOR_BUILD="cc +DA2.0w" ./config.guess # => hppa64-hp-hpux11.23 - if echo __LP64__ | (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | + if echo __LP64__ | (CCOPTS="" $CC_FOR_BUILD -E - 2>/dev/null) | grep -q __LP64__ then - HP_ARCH="hppa2.0w" + HP_ARCH=hppa2.0w else - HP_ARCH="hppa64" + HP_ARCH=hppa64 fi fi - echo ${HP_ARCH}-hp-hpux${HPUX_REV} + echo "$HP_ARCH"-hp-hpux"$HPUX_REV" exit ;; ia64:HP-UX:*:*) - HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` - echo ia64-hp-hpux${HPUX_REV} + HPUX_REV=`echo "$UNAME_RELEASE"|sed -e 's/[^.]*.[0B]*//'` + echo ia64-hp-hpux"$HPUX_REV" exit ;; 3050*:HI-UX:*:*) - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c + set_cc_for_build + sed 's/^ //' << EOF > "$dummy.c" #include int main () @@ -705,11 +750,11 @@ exit (0); } EOF - $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` && + $CC_FOR_BUILD -o "$dummy" "$dummy.c" && SYSTEM_NAME=`"$dummy"` && { echo "$SYSTEM_NAME"; exit; } echo unknown-hitachi-hiuxwe2 exit ;; - 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* ) + 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:*) echo hppa1.1-hp-bsd exit ;; 9000/8??:4.3bsd:*:*) @@ -718,7 +763,7 @@ *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*) echo hppa1.0-hp-mpeix exit ;; - hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* ) + hp7??:OSF1:*:* | hp8?[79]:OSF1:*:*) echo hppa1.1-hp-osf exit ;; hp8??:OSF1:*:*) @@ -726,9 +771,9 @@ exit ;; i*86:OSF1:*:*) if [ -x /usr/sbin/sysversion ] ; then - echo ${UNAME_MACHINE}-unknown-osf1mk + echo "$UNAME_MACHINE"-unknown-osf1mk else - echo ${UNAME_MACHINE}-unknown-osf1 + echo "$UNAME_MACHINE"-unknown-osf1 fi exit ;; parisc*:Lites*:*:*) @@ -753,127 +798,120 @@ echo c4-convex-bsd exit ;; CRAY*Y-MP:*:*:*) - echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + echo ymp-cray-unicos"$UNAME_RELEASE" | sed -e 's/\.[^.]*$/.X/' exit ;; CRAY*[A-Z]90:*:*:*) - echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \ + echo "$UNAME_MACHINE"-cray-unicos"$UNAME_RELEASE" \ | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \ -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \ -e 's/\.[^.]*$/.X/' exit ;; CRAY*TS:*:*:*) - echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + echo t90-cray-unicos"$UNAME_RELEASE" | sed -e 's/\.[^.]*$/.X/' exit ;; CRAY*T3E:*:*:*) - echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + echo alphaev5-cray-unicosmk"$UNAME_RELEASE" | sed -e 's/\.[^.]*$/.X/' exit ;; CRAY*SV1:*:*:*) - echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + echo sv1-cray-unicos"$UNAME_RELEASE" | sed -e 's/\.[^.]*$/.X/' exit ;; *:UNICOS/mp:*:*) - echo craynv-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + echo craynv-cray-unicosmp"$UNAME_RELEASE" | sed -e 's/\.[^.]*$/.X/' exit ;; F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*) - FUJITSU_PROC=`uname -m | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` - FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` - FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'` + FUJITSU_PROC=`uname -m | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz` + FUJITSU_SYS=`uname -p | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz | sed -e 's/\///'` + FUJITSU_REL=`echo "$UNAME_RELEASE" | sed -e 's/ /_/'` echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" exit ;; 5000:UNIX_System_V:4.*:*) - FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` - FUJITSU_REL=`echo ${UNAME_RELEASE} | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/ /_/'` + FUJITSU_SYS=`uname -p | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz | sed -e 's/\///'` + FUJITSU_REL=`echo "$UNAME_RELEASE" | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz | sed -e 's/ /_/'` echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" exit ;; i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*) - echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE} + echo "$UNAME_MACHINE"-pc-bsdi"$UNAME_RELEASE" exit ;; sparc*:BSD/OS:*:*) - echo sparc-unknown-bsdi${UNAME_RELEASE} + echo sparc-unknown-bsdi"$UNAME_RELEASE" exit ;; *:BSD/OS:*:*) - echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE} + echo "$UNAME_MACHINE"-unknown-bsdi"$UNAME_RELEASE" exit ;; + arm*:FreeBSD:*:*) + UNAME_PROCESSOR=`uname -p` + set_cc_for_build + if echo __ARM_PCS_VFP | $CC_FOR_BUILD -E - 2>/dev/null \ + | grep -q __ARM_PCS_VFP + then + echo "${UNAME_PROCESSOR}"-unknown-freebsd"`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`"-gnueabi + else + echo "${UNAME_PROCESSOR}"-unknown-freebsd"`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`"-gnueabihf + fi + exit ;; *:FreeBSD:*:*) UNAME_PROCESSOR=`/usr/bin/uname -p` - case ${UNAME_PROCESSOR} in + case "$UNAME_PROCESSOR" in amd64) - echo x86_64-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; - *) - echo ${UNAME_PROCESSOR}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; + UNAME_PROCESSOR=x86_64 ;; + i386) + UNAME_PROCESSOR=i586 ;; esac + echo "$UNAME_PROCESSOR"-unknown-freebsd"`echo "$UNAME_RELEASE"|sed -e 's/[-(].*//'`" exit ;; i*:CYGWIN*:*) - echo ${UNAME_MACHINE}-pc-cygwin + echo "$UNAME_MACHINE"-pc-cygwin exit ;; *:MINGW64*:*) - echo ${UNAME_MACHINE}-pc-mingw64 + echo "$UNAME_MACHINE"-pc-mingw64 exit ;; *:MINGW*:*) - echo ${UNAME_MACHINE}-pc-mingw32 - exit ;; - i*:MSYS*:*) - echo ${UNAME_MACHINE}-pc-msys + echo "$UNAME_MACHINE"-pc-mingw32 exit ;; - i*:windows32*:*) - # uname -m includes "-pc" on this system. - echo ${UNAME_MACHINE}-mingw32 + *:MSYS*:*) + echo "$UNAME_MACHINE"-pc-msys exit ;; i*:PW*:*) - echo ${UNAME_MACHINE}-pc-pw32 + echo "$UNAME_MACHINE"-pc-pw32 exit ;; *:Interix*:*) - case ${UNAME_MACHINE} in + case "$UNAME_MACHINE" in x86) - echo i586-pc-interix${UNAME_RELEASE} + echo i586-pc-interix"$UNAME_RELEASE" exit ;; authenticamd | genuineintel | EM64T) - echo x86_64-unknown-interix${UNAME_RELEASE} + echo x86_64-unknown-interix"$UNAME_RELEASE" exit ;; IA64) - echo ia64-unknown-interix${UNAME_RELEASE} + echo ia64-unknown-interix"$UNAME_RELEASE" exit ;; esac ;; - [345]86:Windows_95:* | [345]86:Windows_98:* | [345]86:Windows_NT:*) - echo i${UNAME_MACHINE}-pc-mks - exit ;; - 8664:Windows_NT:*) - echo x86_64-pc-mks - exit ;; - i*:Windows_NT*:* | Pentium*:Windows_NT*:*) - # How do we know it's Interix rather than the generic POSIX subsystem? - # It also conflicts with pre-2.0 versions of AT&T UWIN. Should we - # UNAME_MACHINE based on the output of uname instead of i386? - echo i586-pc-interix - exit ;; i*:UWIN*:*) - echo ${UNAME_MACHINE}-pc-uwin + echo "$UNAME_MACHINE"-pc-uwin exit ;; amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*) echo x86_64-unknown-cygwin exit ;; - p*:CYGWIN*:*) - echo powerpcle-unknown-cygwin - exit ;; prep*:SunOS:5.*:*) - echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + echo powerpcle-unknown-solaris2"`echo "$UNAME_RELEASE"|sed -e 's/[^.]*//'`" exit ;; *:GNU:*:*) # the GNU system - echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` + echo "`echo "$UNAME_MACHINE"|sed -e 's,[-/].*$,,'`-unknown-$LIBC`echo "$UNAME_RELEASE"|sed -e 's,/.*$,,'`" exit ;; *:GNU/*:*:*) # other systems with GNU libc and userland - echo ${UNAME_MACHINE}-unknown-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr '[A-Z]' '[a-z]'``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-gnu + echo "$UNAME_MACHINE-unknown-`echo "$UNAME_SYSTEM" | sed 's,^[^/]*/,,' | tr "[:upper:]" "[:lower:]"``echo "$UNAME_RELEASE"|sed -e 's/[-(].*//'`-$LIBC" exit ;; - i*86:Minix:*:*) - echo ${UNAME_MACHINE}-pc-minix + *:Minix:*:*) + echo "$UNAME_MACHINE"-unknown-minix exit ;; aarch64:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu + echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" exit ;; aarch64_be:Linux:*:*) UNAME_MACHINE=aarch64_be - echo ${UNAME_MACHINE}-unknown-linux-gnu + echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" exit ;; alpha:Linux:*:*) case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in @@ -886,63 +924,64 @@ EV68*) UNAME_MACHINE=alphaev68 ;; esac objdump --private-headers /bin/sh | grep -q ld.so.1 - if test "$?" = 0 ; then LIBC="libc1" ; else LIBC="" ; fi - echo ${UNAME_MACHINE}-unknown-linux-gnu${LIBC} + if test "$?" = 0 ; then LIBC=gnulibc1 ; fi + echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" exit ;; + arc:Linux:*:* | arceb:Linux:*:*) + echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" + exit ;; arm*:Linux:*:*) - eval $set_cc_for_build + set_cc_for_build if echo __ARM_EABI__ | $CC_FOR_BUILD -E - 2>/dev/null \ | grep -q __ARM_EABI__ then - echo ${UNAME_MACHINE}-unknown-linux-gnu + echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" else if echo __ARM_PCS_VFP | $CC_FOR_BUILD -E - 2>/dev/null \ | grep -q __ARM_PCS_VFP then - echo ${UNAME_MACHINE}-unknown-linux-gnueabi + echo "$UNAME_MACHINE"-unknown-linux-"$LIBC"eabi else - echo ${UNAME_MACHINE}-unknown-linux-gnueabihf + echo "$UNAME_MACHINE"-unknown-linux-"$LIBC"eabihf fi fi exit ;; avr32*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu + echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" exit ;; cris:Linux:*:*) - echo ${UNAME_MACHINE}-axis-linux-gnu + echo "$UNAME_MACHINE"-axis-linux-"$LIBC" exit ;; crisv32:Linux:*:*) - echo ${UNAME_MACHINE}-axis-linux-gnu + echo "$UNAME_MACHINE"-axis-linux-"$LIBC" exit ;; + e2k:Linux:*:*) + echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" + exit ;; frv:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu + echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" exit ;; hexagon:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu + echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" exit ;; i*86:Linux:*:*) - LIBC=gnu - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c - #ifdef __dietlibc__ - LIBC=dietlibc - #endif -EOF - eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^LIBC'` - echo "${UNAME_MACHINE}-pc-linux-${LIBC}" + echo "$UNAME_MACHINE"-pc-linux-"$LIBC" exit ;; ia64:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu + echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" exit ;; + k1om:Linux:*:*) + echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" + exit ;; m32r*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu + echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" exit ;; m68*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu + echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" exit ;; mips:Linux:*:* | mips64:Linux:*:*) - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c + set_cc_for_build + sed 's/^ //' << EOF > "$dummy.c" #undef CPU #undef ${UNAME_MACHINE} #undef ${UNAME_MACHINE}el @@ -956,55 +995,70 @@ #endif #endif EOF - eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^CPU'` - test x"${CPU}" != x && { echo "${CPU}-unknown-linux-gnu"; exit; } + eval "`$CC_FOR_BUILD -E "$dummy.c" 2>/dev/null | grep '^CPU'`" + test "x$CPU" != x && { echo "$CPU-unknown-linux-$LIBC"; exit; } ;; - or32:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu + mips64el:Linux:*:*) + echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" exit ;; + openrisc*:Linux:*:*) + echo or1k-unknown-linux-"$LIBC" + exit ;; + or32:Linux:*:* | or1k*:Linux:*:*) + echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" + exit ;; padre:Linux:*:*) - echo sparc-unknown-linux-gnu + echo sparc-unknown-linux-"$LIBC" exit ;; parisc64:Linux:*:* | hppa64:Linux:*:*) - echo hppa64-unknown-linux-gnu + echo hppa64-unknown-linux-"$LIBC" exit ;; parisc:Linux:*:* | hppa:Linux:*:*) # Look for CPU level case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in - PA7*) echo hppa1.1-unknown-linux-gnu ;; - PA8*) echo hppa2.0-unknown-linux-gnu ;; - *) echo hppa-unknown-linux-gnu ;; + PA7*) echo hppa1.1-unknown-linux-"$LIBC" ;; + PA8*) echo hppa2.0-unknown-linux-"$LIBC" ;; + *) echo hppa-unknown-linux-"$LIBC" ;; esac exit ;; ppc64:Linux:*:*) - echo powerpc64-unknown-linux-gnu + echo powerpc64-unknown-linux-"$LIBC" exit ;; ppc:Linux:*:*) - echo powerpc-unknown-linux-gnu + echo powerpc-unknown-linux-"$LIBC" exit ;; + ppc64le:Linux:*:*) + echo powerpc64le-unknown-linux-"$LIBC" + exit ;; + ppcle:Linux:*:*) + echo powerpcle-unknown-linux-"$LIBC" + exit ;; + riscv32:Linux:*:* | riscv64:Linux:*:*) + echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" + exit ;; s390:Linux:*:* | s390x:Linux:*:*) - echo ${UNAME_MACHINE}-ibm-linux + echo "$UNAME_MACHINE"-ibm-linux-"$LIBC" exit ;; sh64*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu + echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" exit ;; sh*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu + echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" exit ;; sparc:Linux:*:* | sparc64:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu + echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" exit ;; tile*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu + echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" exit ;; vax:Linux:*:*) - echo ${UNAME_MACHINE}-dec-linux-gnu + echo "$UNAME_MACHINE"-dec-linux-"$LIBC" exit ;; x86_64:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu + echo "$UNAME_MACHINE"-pc-linux-"$LIBC" exit ;; xtensa*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu + echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" exit ;; i*86:DYNIX/ptx:4*:*) # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. @@ -1018,34 +1072,34 @@ # I am not positive that other SVR4 systems won't match this, # I just have to hope. -- rms. # Use sysv4.2uw... so that sysv4* matches it. - echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION} + echo "$UNAME_MACHINE"-pc-sysv4.2uw"$UNAME_VERSION" exit ;; i*86:OS/2:*:*) # If we were able to find `uname', then EMX Unix compatibility # is probably installed. - echo ${UNAME_MACHINE}-pc-os2-emx + echo "$UNAME_MACHINE"-pc-os2-emx exit ;; i*86:XTS-300:*:STOP) - echo ${UNAME_MACHINE}-unknown-stop + echo "$UNAME_MACHINE"-unknown-stop exit ;; i*86:atheos:*:*) - echo ${UNAME_MACHINE}-unknown-atheos + echo "$UNAME_MACHINE"-unknown-atheos exit ;; i*86:syllable:*:*) - echo ${UNAME_MACHINE}-pc-syllable + echo "$UNAME_MACHINE"-pc-syllable exit ;; i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.[02]*:*) - echo i386-unknown-lynxos${UNAME_RELEASE} + echo i386-unknown-lynxos"$UNAME_RELEASE" exit ;; i*86:*DOS:*:*) - echo ${UNAME_MACHINE}-pc-msdosdjgpp + echo "$UNAME_MACHINE"-pc-msdosdjgpp exit ;; - i*86:*:4.*:* | i*86:SYSTEM_V:4.*:*) - UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'` + i*86:*:4.*:*) + UNAME_REL=`echo "$UNAME_RELEASE" | sed 's/\/MP$//'` if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then - echo ${UNAME_MACHINE}-univel-sysv${UNAME_REL} + echo "$UNAME_MACHINE"-univel-sysv"$UNAME_REL" else - echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL} + echo "$UNAME_MACHINE"-pc-sysv"$UNAME_REL" fi exit ;; i*86:*:5:[678]*) @@ -1055,12 +1109,12 @@ *Pentium) UNAME_MACHINE=i586 ;; *Pent*|*Celeron) UNAME_MACHINE=i686 ;; esac - echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION} + echo "$UNAME_MACHINE-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}{$UNAME_VERSION}" exit ;; i*86:*:3.2:*) if test -f /usr/options/cb.name; then UNAME_REL=`sed -n 's/.*Version //p' /dev/null >/dev/null ; then UNAME_REL=`(/bin/uname -X|grep Release|sed -e 's/.*= //')` (/bin/uname -X|grep i80486 >/dev/null) && UNAME_MACHINE=i486 @@ -1070,9 +1124,9 @@ && UNAME_MACHINE=i686 (/bin/uname -X|grep '^Machine.*Pentium Pro' >/dev/null) \ && UNAME_MACHINE=i686 - echo ${UNAME_MACHINE}-pc-sco$UNAME_REL + echo "$UNAME_MACHINE"-pc-sco"$UNAME_REL" else - echo ${UNAME_MACHINE}-pc-sysv32 + echo "$UNAME_MACHINE"-pc-sysv32 fi exit ;; pc:*:*:*) @@ -1080,7 +1134,7 @@ # uname -m prints for DJGPP always 'pc', but it prints nothing about # the processor, so we play safe by assuming i586. # Note: whatever this is, it MUST be the same as what config.sub - # prints for the "djgpp" host, or else GDB configury will decide that + # prints for the "djgpp" host, or else GDB configure will decide that # this is a cross-build. echo i586-pc-msdosdjgpp exit ;; @@ -1092,9 +1146,9 @@ exit ;; i860:*:4.*:*) # i860-SVR4 if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then - echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4 + echo i860-stardent-sysv"$UNAME_RELEASE" # Stardent Vistra i860-SVR4 else # Add other i860-SVR4 vendors below as they are discovered. - echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4 + echo i860-unknown-sysv"$UNAME_RELEASE" # Unknown i860-SVR4 fi exit ;; mini*:CTIX:SYS*5:*) @@ -1114,9 +1168,9 @@ test -r /etc/.relid \ && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ - && { echo i486-ncr-sysv4.3${OS_REL}; exit; } + && { echo i486-ncr-sysv4.3"$OS_REL"; exit; } /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ - && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; + && { echo i586-ncr-sysv4.3"$OS_REL"; exit; } ;; 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*) /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ && { echo i486-ncr-sysv4; exit; } ;; @@ -1125,28 +1179,28 @@ test -r /etc/.relid \ && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ - && { echo i486-ncr-sysv4.3${OS_REL}; exit; } + && { echo i486-ncr-sysv4.3"$OS_REL"; exit; } /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ - && { echo i586-ncr-sysv4.3${OS_REL}; exit; } + && { echo i586-ncr-sysv4.3"$OS_REL"; exit; } /bin/uname -p 2>/dev/null | /bin/grep pteron >/dev/null \ - && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; + && { echo i586-ncr-sysv4.3"$OS_REL"; exit; } ;; m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*) - echo m68k-unknown-lynxos${UNAME_RELEASE} + echo m68k-unknown-lynxos"$UNAME_RELEASE" exit ;; mc68030:UNIX_System_V:4.*:*) echo m68k-atari-sysv4 exit ;; TSUNAMI:LynxOS:2.*:*) - echo sparc-unknown-lynxos${UNAME_RELEASE} + echo sparc-unknown-lynxos"$UNAME_RELEASE" exit ;; rs6000:LynxOS:2.*:*) - echo rs6000-unknown-lynxos${UNAME_RELEASE} + echo rs6000-unknown-lynxos"$UNAME_RELEASE" exit ;; PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.[02]*:*) - echo powerpc-unknown-lynxos${UNAME_RELEASE} + echo powerpc-unknown-lynxos"$UNAME_RELEASE" exit ;; SM[BE]S:UNIX_SV:*:*) - echo mips-dde-sysv${UNAME_RELEASE} + echo mips-dde-sysv"$UNAME_RELEASE" exit ;; RM*:ReliantUNIX-*:*:*) echo mips-sni-sysv4 @@ -1157,7 +1211,7 @@ *:SINIX-*:*:*) if uname -p 2>/dev/null >/dev/null ; then UNAME_MACHINE=`(uname -p) 2>/dev/null` - echo ${UNAME_MACHINE}-sni-sysv4 + echo "$UNAME_MACHINE"-sni-sysv4 else echo ns32k-sni-sysv fi @@ -1177,23 +1231,23 @@ exit ;; i*86:VOS:*:*) # From Paul.Green@stratus.com. - echo ${UNAME_MACHINE}-stratus-vos + echo "$UNAME_MACHINE"-stratus-vos exit ;; *:VOS:*:*) # From Paul.Green@stratus.com. echo hppa1.1-stratus-vos exit ;; mc68*:A/UX:*:*) - echo m68k-apple-aux${UNAME_RELEASE} + echo m68k-apple-aux"$UNAME_RELEASE" exit ;; news*:NEWS-OS:6*:*) echo mips-sony-newsos6 exit ;; R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*) if [ -d /usr/nec ]; then - echo mips-nec-sysv${UNAME_RELEASE} + echo mips-nec-sysv"$UNAME_RELEASE" else - echo mips-unknown-sysv${UNAME_RELEASE} + echo mips-unknown-sysv"$UNAME_RELEASE" fi exit ;; BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only. @@ -1212,66 +1266,94 @@ echo x86_64-unknown-haiku exit ;; SX-4:SUPER-UX:*:*) - echo sx4-nec-superux${UNAME_RELEASE} + echo sx4-nec-superux"$UNAME_RELEASE" exit ;; SX-5:SUPER-UX:*:*) - echo sx5-nec-superux${UNAME_RELEASE} + echo sx5-nec-superux"$UNAME_RELEASE" exit ;; SX-6:SUPER-UX:*:*) - echo sx6-nec-superux${UNAME_RELEASE} + echo sx6-nec-superux"$UNAME_RELEASE" exit ;; SX-7:SUPER-UX:*:*) - echo sx7-nec-superux${UNAME_RELEASE} + echo sx7-nec-superux"$UNAME_RELEASE" exit ;; SX-8:SUPER-UX:*:*) - echo sx8-nec-superux${UNAME_RELEASE} + echo sx8-nec-superux"$UNAME_RELEASE" exit ;; SX-8R:SUPER-UX:*:*) - echo sx8r-nec-superux${UNAME_RELEASE} + echo sx8r-nec-superux"$UNAME_RELEASE" exit ;; + SX-ACE:SUPER-UX:*:*) + echo sxace-nec-superux"$UNAME_RELEASE" + exit ;; Power*:Rhapsody:*:*) - echo powerpc-apple-rhapsody${UNAME_RELEASE} + echo powerpc-apple-rhapsody"$UNAME_RELEASE" exit ;; *:Rhapsody:*:*) - echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE} + echo "$UNAME_MACHINE"-apple-rhapsody"$UNAME_RELEASE" exit ;; *:Darwin:*:*) UNAME_PROCESSOR=`uname -p` || UNAME_PROCESSOR=unknown - case $UNAME_PROCESSOR in - i386) - eval $set_cc_for_build - if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then - if (echo '#ifdef __LP64__'; echo IS_64BIT_ARCH; echo '#endif') | \ - (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ - grep IS_64BIT_ARCH >/dev/null - then - UNAME_PROCESSOR="x86_64" - fi - fi ;; - unknown) UNAME_PROCESSOR=powerpc ;; - esac - echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE} + set_cc_for_build + if test "$UNAME_PROCESSOR" = unknown ; then + UNAME_PROCESSOR=powerpc + fi + if test "`echo "$UNAME_RELEASE" | sed -e 's/\..*//'`" -le 10 ; then + if [ "$CC_FOR_BUILD" != no_compiler_found ]; then + if (echo '#ifdef __LP64__'; echo IS_64BIT_ARCH; echo '#endif') | \ + (CCOPTS="" $CC_FOR_BUILD -E - 2>/dev/null) | \ + grep IS_64BIT_ARCH >/dev/null + then + case $UNAME_PROCESSOR in + i386) UNAME_PROCESSOR=x86_64 ;; + powerpc) UNAME_PROCESSOR=powerpc64 ;; + esac + fi + # On 10.4-10.6 one might compile for PowerPC via gcc -arch ppc + if (echo '#ifdef __POWERPC__'; echo IS_PPC; echo '#endif') | \ + (CCOPTS="" $CC_FOR_BUILD -E - 2>/dev/null) | \ + grep IS_PPC >/dev/null + then + UNAME_PROCESSOR=powerpc + fi + fi + elif test "$UNAME_PROCESSOR" = i386 ; then + # Avoid executing cc on OS X 10.9, as it ships with a stub + # that puts up a graphical alert prompting to install + # developer tools. Any system running Mac OS X 10.7 or + # later (Darwin 11 and later) is required to have a 64-bit + # processor. This is not true of the ARM version of Darwin + # that Apple uses in portable devices. + UNAME_PROCESSOR=x86_64 + fi + echo "$UNAME_PROCESSOR"-apple-darwin"$UNAME_RELEASE" exit ;; *:procnto*:*:* | *:QNX:[0123456789]*:*) UNAME_PROCESSOR=`uname -p` - if test "$UNAME_PROCESSOR" = "x86"; then + if test "$UNAME_PROCESSOR" = x86; then UNAME_PROCESSOR=i386 UNAME_MACHINE=pc fi - echo ${UNAME_PROCESSOR}-${UNAME_MACHINE}-nto-qnx${UNAME_RELEASE} + echo "$UNAME_PROCESSOR"-"$UNAME_MACHINE"-nto-qnx"$UNAME_RELEASE" exit ;; *:QNX:*:4*) echo i386-pc-qnx exit ;; - NEO-?:NONSTOP_KERNEL:*:*) - echo neo-tandem-nsk${UNAME_RELEASE} + NEO-*:NONSTOP_KERNEL:*:*) + echo neo-tandem-nsk"$UNAME_RELEASE" exit ;; NSE-*:NONSTOP_KERNEL:*:*) - echo nse-tandem-nsk${UNAME_RELEASE} + echo nse-tandem-nsk"$UNAME_RELEASE" exit ;; - NSR-?:NONSTOP_KERNEL:*:*) - echo nsr-tandem-nsk${UNAME_RELEASE} + NSR-*:NONSTOP_KERNEL:*:*) + echo nsr-tandem-nsk"$UNAME_RELEASE" exit ;; + NSV-*:NONSTOP_KERNEL:*:*) + echo nsv-tandem-nsk"$UNAME_RELEASE" + exit ;; + NSX-*:NONSTOP_KERNEL:*:*) + echo nsx-tandem-nsk"$UNAME_RELEASE" + exit ;; *:NonStop-UX:*:*) echo mips-compaq-nonstopux exit ;; @@ -1279,18 +1361,19 @@ echo bs2000-siemens-sysv exit ;; DS/*:UNIX_System_V:*:*) - echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE} + echo "$UNAME_MACHINE"-"$UNAME_SYSTEM"-"$UNAME_RELEASE" exit ;; *:Plan9:*:*) # "uname -m" is not consistent, so use $cputype instead. 386 # is converted to i386 for consistency with other x86 # operating systems. - if test "$cputype" = "386"; then + # shellcheck disable=SC2154 + if test "$cputype" = 386; then UNAME_MACHINE=i386 else UNAME_MACHINE="$cputype" fi - echo ${UNAME_MACHINE}-unknown-plan9 + echo "$UNAME_MACHINE"-unknown-plan9 exit ;; *:TOPS-10:*:*) echo pdp10-unknown-tops10 @@ -1311,14 +1394,14 @@ echo pdp10-unknown-its exit ;; SEI:*:*:SEIUX) - echo mips-sei-seiux${UNAME_RELEASE} + echo mips-sei-seiux"$UNAME_RELEASE" exit ;; *:DragonFly:*:*) - echo ${UNAME_MACHINE}-unknown-dragonfly`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` + echo "$UNAME_MACHINE"-unknown-dragonfly"`echo "$UNAME_RELEASE"|sed -e 's/[-(].*//'`" exit ;; *:*VMS:*:*) UNAME_MACHINE=`(uname -p) 2>/dev/null` - case "${UNAME_MACHINE}" in + case "$UNAME_MACHINE" in A*) echo alpha-dec-vms ; exit ;; I*) echo ia64-dec-vms ; exit ;; V*) echo vax-dec-vms ; exit ;; @@ -1327,182 +1410,48 @@ echo i386-pc-xenix exit ;; i*86:skyos:*:*) - echo ${UNAME_MACHINE}-pc-skyos`echo ${UNAME_RELEASE}` | sed -e 's/ .*$//' + echo "$UNAME_MACHINE"-pc-skyos"`echo "$UNAME_RELEASE" | sed -e 's/ .*$//'`" exit ;; i*86:rdos:*:*) - echo ${UNAME_MACHINE}-pc-rdos + echo "$UNAME_MACHINE"-pc-rdos exit ;; i*86:AROS:*:*) - echo ${UNAME_MACHINE}-pc-aros + echo "$UNAME_MACHINE"-pc-aros exit ;; x86_64:VMkernel:*:*) - echo ${UNAME_MACHINE}-unknown-esx + echo "$UNAME_MACHINE"-unknown-esx exit ;; + amd64:Isilon\ OneFS:*:*) + echo x86_64-unknown-onefs + exit ;; esac -eval $set_cc_for_build -cat >$dummy.c < -# include -#endif -main () -{ -#if defined (sony) -#if defined (MIPSEB) - /* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed, - I don't know.... */ - printf ("mips-sony-bsd\n"); exit (0); -#else -#include - printf ("m68k-sony-newsos%s\n", -#ifdef NEWSOS4 - "4" -#else - "" -#endif - ); exit (0); -#endif -#endif - -#if defined (__arm) && defined (__acorn) && defined (__unix) - printf ("arm-acorn-riscix\n"); exit (0); -#endif - -#if defined (hp300) && !defined (hpux) - printf ("m68k-hp-bsd\n"); exit (0); -#endif - -#if defined (NeXT) -#if !defined (__ARCHITECTURE__) -#define __ARCHITECTURE__ "m68k" -#endif - int version; - version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`; - if (version < 4) - printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version); - else - printf ("%s-next-openstep%d\n", __ARCHITECTURE__, version); - exit (0); -#endif - -#if defined (MULTIMAX) || defined (n16) -#if defined (UMAXV) - printf ("ns32k-encore-sysv\n"); exit (0); -#else -#if defined (CMU) - printf ("ns32k-encore-mach\n"); exit (0); -#else - printf ("ns32k-encore-bsd\n"); exit (0); -#endif -#endif -#endif - -#if defined (__386BSD__) - printf ("i386-pc-bsd\n"); exit (0); -#endif - -#if defined (sequent) -#if defined (i386) - printf ("i386-sequent-dynix\n"); exit (0); -#endif -#if defined (ns32000) - printf ("ns32k-sequent-dynix\n"); exit (0); -#endif -#endif - -#if defined (_SEQUENT_) - struct utsname un; - - uname(&un); - - if (strncmp(un.version, "V2", 2) == 0) { - printf ("i386-sequent-ptx2\n"); exit (0); - } - if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */ - printf ("i386-sequent-ptx1\n"); exit (0); - } - printf ("i386-sequent-ptx\n"); exit (0); - -#endif - -#if defined (vax) -# if !defined (ultrix) -# include -# if defined (BSD) -# if BSD == 43 - printf ("vax-dec-bsd4.3\n"); exit (0); -# else -# if BSD == 199006 - printf ("vax-dec-bsd4.3reno\n"); exit (0); -# else - printf ("vax-dec-bsd\n"); exit (0); -# endif -# endif -# else - printf ("vax-dec-bsd\n"); exit (0); -# endif -# else - printf ("vax-dec-ultrix\n"); exit (0); -# endif -#endif +echo "$0: unable to guess system type" >&2 -#if defined (alliant) && defined (i860) - printf ("i860-alliant-bsd\n"); exit (0); -#endif +case "$UNAME_MACHINE:$UNAME_SYSTEM" in + mips:Linux | mips64:Linux) + # If we got here on MIPS GNU/Linux, output extra information. + cat >&2 </dev/null && SYSTEM_NAME=`$dummy` && - { echo "$SYSTEM_NAME"; exit; } - -# Apollos put the system type in the environment. - -test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit; } - -# Convex versions that predate uname can use getsysinfo(1) - -if [ -x /usr/convex/getsysinfo ] -then - case `getsysinfo -f cpu_type` in - c1*) - echo c1-convex-bsd - exit ;; - c2*) - if getsysinfo -f scalar_acc - then echo c32-convex-bsd - else echo c2-convex-bsd - fi - exit ;; - c34*) - echo c34-convex-bsd - exit ;; - c38*) - echo c38-convex-bsd - exit ;; - c4*) - echo c4-convex-bsd - exit ;; - esac -fi + ;; +esac cat >&2 < in order to provide the needed -information to handle your system. +If $0 has already been updated, send the following data and any +information you think might be pertinent to config-patches@gnu.org to +provide the necessary information to handle your system. config.guess timestamp = $timestamp @@ -1521,16 +1470,16 @@ /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null` -UNAME_MACHINE = ${UNAME_MACHINE} -UNAME_RELEASE = ${UNAME_RELEASE} -UNAME_SYSTEM = ${UNAME_SYSTEM} -UNAME_VERSION = ${UNAME_VERSION} +UNAME_MACHINE = "$UNAME_MACHINE" +UNAME_RELEASE = "$UNAME_RELEASE" +UNAME_SYSTEM = "$UNAME_SYSTEM" +UNAME_VERSION = "$UNAME_VERSION" EOF exit 1 # Local variables: -# eval: (add-hook 'write-file-hooks 'time-stamp) +# eval: (add-hook 'before-save-hook 'time-stamp) # time-stamp-start: "timestamp='" # time-stamp-format: "%:y-%02m-%02d" # time-stamp-end: "'" diff --git a/data/nix/config/config.sub b/data/nix/config/config.sub --- a/data/nix/config/config.sub +++ b/data/nix/config/config.sub @@ -1,1785 +1,1817 @@ #! /bin/sh # Configuration validation subroutine script. -# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, -# 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, -# 2011, 2012 Free Software Foundation, Inc. - -timestamp='2012-08-18' - -# This file is (in principle) common to ALL GNU software. -# The presence of a machine in this file suggests that SOME GNU software -# can handle that machine. It does not imply ALL GNU software can. -# -# This file is free software; you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 2 of the License, or -# (at your option) any later version. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, see . -# -# As a special exception to the GNU General Public License, if you -# distribute this file as part of a program that contains a -# configuration script generated by Autoconf, you may include it under -# the same distribution terms that you use for the rest of that program. - - -# Please send patches to . Submit a context -# diff and a properly formatted GNU ChangeLog entry. -# -# Configuration subroutine to validate and canonicalize a configuration type. -# Supply the specified configuration type as an argument. -# If it is invalid, we print an error message on stderr and exit with code 1. -# Otherwise, we print the canonical config type on stdout and succeed. - -# You can get the latest version of this script from: -# http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.sub;hb=HEAD - -# This file is supposed to be the same for all GNU packages -# and recognize all the CPU types, system types and aliases -# that are meaningful with *any* GNU software. -# Each package is responsible for reporting which valid configurations -# it does not support. The user should be able to distinguish -# a failure to support a valid configuration from a meaningless -# configuration. - -# The goal of this file is to map all the various variations of a given -# machine specification into a single specification in the form: -# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM -# or in some cases, the newer four-part form: -# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM -# It is wrong to echo any other type of specification. - -me=`echo "$0" | sed -e 's,.*/,,'` - -usage="\ -Usage: $0 [OPTION] CPU-MFR-OPSYS - $0 [OPTION] ALIAS - -Canonicalize a configuration name. - -Operation modes: - -h, --help print this help, then exit - -t, --time-stamp print date of last modification, then exit - -v, --version print version number, then exit - -Report bugs and patches to ." - -version="\ -GNU config.sub ($timestamp) - -Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, -2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 -Free Software Foundation, Inc. - -This is free software; see the source for copying conditions. There is NO -warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." - -help=" -Try \`$me --help' for more information." - -# Parse command line -while test $# -gt 0 ; do - case $1 in - --time-stamp | --time* | -t ) - echo "$timestamp" ; exit ;; - --version | -v ) - echo "$version" ; exit ;; - --help | --h* | -h ) - echo "$usage"; exit ;; - -- ) # Stop option processing - shift; break ;; - - ) # Use stdin as input. - break ;; - -* ) - echo "$me: invalid option $1$help" - exit 1 ;; - - *local*) - # First pass through any local machine types. - echo $1 - exit ;; - - * ) - break ;; - esac -done - -case $# in - 0) echo "$me: missing argument$help" >&2 - exit 1;; - 1) ;; - *) echo "$me: too many arguments$help" >&2 - exit 1;; -esac - -# Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any). -# Here we must recognize all the valid KERNEL-OS combinations. -maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'` -case $maybe_os in - nto-qnx* | linux-gnu* | linux-android* | linux-dietlibc | linux-newlib* | \ - linux-musl* | linux-uclibc* | uclinux-uclibc* | uclinux-gnu* | kfreebsd*-gnu* | \ - knetbsd*-gnu* | netbsd*-gnu* | \ - kopensolaris*-gnu* | \ - storm-chaos* | os2-emx* | rtmk-nova*) - os=-$maybe_os - basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'` - ;; - android-linux) - os=-linux-android - basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'`-unknown - ;; - *) - basic_machine=`echo $1 | sed 's/-[^-]*$//'` - if [ $basic_machine != $1 ] - then os=`echo $1 | sed 's/.*-/-/'` - else os=; fi - ;; -esac - -### Let's recognize common machines as not being operating systems so -### that things like config.sub decstation-3100 work. We also -### recognize some manufacturers as not being operating systems, so we -### can provide default operating systems below. -case $os in - -sun*os*) - # Prevent following clause from handling this invalid input. - ;; - -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \ - -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \ - -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \ - -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\ - -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \ - -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \ - -apple | -axis | -knuth | -cray | -microblaze) - os= - basic_machine=$1 - ;; - -bluegene*) - os=-cnk - ;; - -sim | -cisco | -oki | -wec | -winbond) - os= - basic_machine=$1 - ;; - -scout) - ;; - -wrs) - os=-vxworks - basic_machine=$1 - ;; - -chorusos*) - os=-chorusos - basic_machine=$1 - ;; - -chorusrdb) - os=-chorusrdb - basic_machine=$1 - ;; - -hiux*) - os=-hiuxwe2 - ;; - -sco6) - os=-sco5v6 - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco5) - os=-sco3.2v5 - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco4) - os=-sco3.2v4 - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco3.2.[4-9]*) - os=`echo $os | sed -e 's/sco3.2./sco3.2v/'` - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco3.2v[4-9]*) - # Don't forget version if it is 3.2v4 or newer. - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco5v6*) - # Don't forget version if it is 3.2v4 or newer. - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco*) - os=-sco3.2v2 - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -udk*) - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -isc) - os=-isc2.2 - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -clix*) - basic_machine=clipper-intergraph - ;; - -isc*) - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -lynx*178) - os=-lynxos178 - ;; - -lynx*5) - os=-lynxos5 - ;; - -lynx*) - os=-lynxos - ;; - -ptx*) - basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'` - ;; - -windowsnt*) - os=`echo $os | sed -e 's/windowsnt/winnt/'` - ;; - -psos*) - os=-psos - ;; - -mint | -mint[0-9]*) - basic_machine=m68k-atari - os=-mint - ;; -esac - -# Decode aliases for certain CPU-COMPANY combinations. -case $basic_machine in - # Recognize the basic CPU types without company name. - # Some are omitted here because they have special meanings below. - 1750a | 580 \ - | a29k \ - | aarch64 | aarch64_be \ - | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \ - | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \ - | am33_2.0 \ - | arc | arm | arm[bl]e | arme[lb] | armv[2345] | armv[345][lb] | avr | avr32 \ - | be32 | be64 \ - | bfin \ - | c4x | clipper \ - | d10v | d30v | dlx | dsp16xx \ - | epiphany \ - | fido | fr30 | frv \ - | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \ - | hexagon \ - | i370 | i860 | i960 | ia64 \ - | ip2k | iq2000 \ - | le32 | le64 \ - | lm32 \ - | m32c | m32r | m32rle | m68000 | m68k | m88k \ - | maxq | mb | microblaze | mcore | mep | metag \ - | mips | mipsbe | mipseb | mipsel | mipsle \ - | mips16 \ - | mips64 | mips64el \ - | mips64octeon | mips64octeonel \ - | mips64orion | mips64orionel \ - | mips64r5900 | mips64r5900el \ - | mips64vr | mips64vrel \ - | mips64vr4100 | mips64vr4100el \ - | mips64vr4300 | mips64vr4300el \ - | mips64vr5000 | mips64vr5000el \ - | mips64vr5900 | mips64vr5900el \ - | mipsisa32 | mipsisa32el \ - | mipsisa32r2 | mipsisa32r2el \ - | mipsisa64 | mipsisa64el \ - | mipsisa64r2 | mipsisa64r2el \ - | mipsisa64sb1 | mipsisa64sb1el \ - | mipsisa64sr71k | mipsisa64sr71kel \ - | mipstx39 | mipstx39el \ - | mn10200 | mn10300 \ - | moxie \ - | mt \ - | msp430 \ - | nds32 | nds32le | nds32be \ - | nios | nios2 \ - | ns16k | ns32k \ - | open8 \ - | or32 \ - | pdp10 | pdp11 | pj | pjl \ - | powerpc | powerpc64 | powerpc64le | powerpcle \ - | pyramid \ - | rl78 | rx \ - | score \ - | sh | sh[1234] | sh[24]a | sh[24]aeb | sh[23]e | sh[34]eb | sheb | shbe | shle | sh[1234]le | sh3ele \ - | sh64 | sh64le \ - | sparc | sparc64 | sparc64b | sparc64v | sparc86x | sparclet | sparclite \ - | sparcv8 | sparcv9 | sparcv9b | sparcv9v \ - | spu \ - | tahoe | tic4x | tic54x | tic55x | tic6x | tic80 | tron \ - | ubicom32 \ - | v850 | v850e | v850e1 | v850e2 | v850es | v850e2v3 \ - | we32k \ - | x86 | xc16x | xstormy16 | xtensa \ - | z8k | z80) - basic_machine=$basic_machine-unknown - ;; - c54x) - basic_machine=tic54x-unknown - ;; - c55x) - basic_machine=tic55x-unknown - ;; - c6x) - basic_machine=tic6x-unknown - ;; - m6811 | m68hc11 | m6812 | m68hc12 | m68hcs12x | picochip) - basic_machine=$basic_machine-unknown - os=-none - ;; - m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k) - ;; - ms1) - basic_machine=mt-unknown - ;; - - strongarm | thumb | xscale) - basic_machine=arm-unknown - ;; - xgate) - basic_machine=$basic_machine-unknown - os=-none - ;; - xscaleeb) - basic_machine=armeb-unknown - ;; - - xscaleel) - basic_machine=armel-unknown - ;; - - # We use `pc' rather than `unknown' - # because (1) that's what they normally are, and - # (2) the word "unknown" tends to confuse beginning users. - i*86 | x86_64) - basic_machine=$basic_machine-pc - ;; - # Object if more than one company name word. - *-*-*) - echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 - exit 1 - ;; - # Recognize the basic CPU types with company name. - 580-* \ - | a29k-* \ - | aarch64-* | aarch64_be-* \ - | alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \ - | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \ - | alphapca5[67]-* | alpha64pca5[67]-* | arc-* \ - | arm-* | armbe-* | armle-* | armeb-* | armv*-* \ - | avr-* | avr32-* \ - | be32-* | be64-* \ - | bfin-* | bs2000-* \ - | c[123]* | c30-* | [cjt]90-* | c4x-* \ - | clipper-* | craynv-* | cydra-* \ - | d10v-* | d30v-* | dlx-* \ - | elxsi-* \ - | f30[01]-* | f700-* | fido-* | fr30-* | frv-* | fx80-* \ - | h8300-* | h8500-* \ - | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \ - | hexagon-* \ - | i*86-* | i860-* | i960-* | ia64-* \ - | ip2k-* | iq2000-* \ - | le32-* | le64-* \ - | lm32-* \ - | m32c-* | m32r-* | m32rle-* \ - | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \ - | m88110-* | m88k-* | maxq-* | mcore-* | metag-* | microblaze-* \ - | mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \ - | mips16-* \ - | mips64-* | mips64el-* \ - | mips64octeon-* | mips64octeonel-* \ - | mips64orion-* | mips64orionel-* \ - | mips64r5900-* | mips64r5900el-* \ - | mips64vr-* | mips64vrel-* \ - | mips64vr4100-* | mips64vr4100el-* \ - | mips64vr4300-* | mips64vr4300el-* \ - | mips64vr5000-* | mips64vr5000el-* \ - | mips64vr5900-* | mips64vr5900el-* \ - | mipsisa32-* | mipsisa32el-* \ - | mipsisa32r2-* | mipsisa32r2el-* \ - | mipsisa64-* | mipsisa64el-* \ - | mipsisa64r2-* | mipsisa64r2el-* \ - | mipsisa64sb1-* | mipsisa64sb1el-* \ - | mipsisa64sr71k-* | mipsisa64sr71kel-* \ - | mipstx39-* | mipstx39el-* \ - | mmix-* \ - | mt-* \ - | msp430-* \ - | nds32-* | nds32le-* | nds32be-* \ - | nios-* | nios2-* \ - | none-* | np1-* | ns16k-* | ns32k-* \ - | open8-* \ - | orion-* \ - | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \ - | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* \ - | pyramid-* \ - | rl78-* | romp-* | rs6000-* | rx-* \ - | sh-* | sh[1234]-* | sh[24]a-* | sh[24]aeb-* | sh[23]e-* | sh[34]eb-* | sheb-* | shbe-* \ - | shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \ - | sparc-* | sparc64-* | sparc64b-* | sparc64v-* | sparc86x-* | sparclet-* \ - | sparclite-* \ - | sparcv8-* | sparcv9-* | sparcv9b-* | sparcv9v-* | sv1-* | sx?-* \ - | tahoe-* \ - | tic30-* | tic4x-* | tic54x-* | tic55x-* | tic6x-* | tic80-* \ - | tile*-* \ - | tron-* \ - | ubicom32-* \ - | v850-* | v850e-* | v850e1-* | v850es-* | v850e2-* | v850e2v3-* \ - | vax-* \ - | we32k-* \ - | x86-* | x86_64-* | xc16x-* | xps100-* \ - | xstormy16-* | xtensa*-* \ - | ymp-* \ - | z8k-* | z80-*) - ;; - # Recognize the basic CPU types without company name, with glob match. - xtensa*) - basic_machine=$basic_machine-unknown - ;; - # Recognize the various machine names and aliases which stand - # for a CPU type and a company and sometimes even an OS. - 386bsd) - basic_machine=i386-unknown - os=-bsd - ;; - 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc) - basic_machine=m68000-att - ;; - 3b*) - basic_machine=we32k-att - ;; - a29khif) - basic_machine=a29k-amd - os=-udi - ;; - abacus) - basic_machine=abacus-unknown - ;; - adobe68k) - basic_machine=m68010-adobe - os=-scout - ;; - alliant | fx80) - basic_machine=fx80-alliant - ;; - altos | altos3068) - basic_machine=m68k-altos - ;; - am29k) - basic_machine=a29k-none - os=-bsd - ;; - amd64) - basic_machine=x86_64-pc - ;; - amd64-*) - basic_machine=x86_64-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - amdahl) - basic_machine=580-amdahl - os=-sysv - ;; - amiga | amiga-*) - basic_machine=m68k-unknown - ;; - amigaos | amigados) - basic_machine=m68k-unknown - os=-amigaos - ;; - amigaunix | amix) - basic_machine=m68k-unknown - os=-sysv4 - ;; - apollo68) - basic_machine=m68k-apollo - os=-sysv - ;; - apollo68bsd) - basic_machine=m68k-apollo - os=-bsd - ;; - aros) - basic_machine=i386-pc - os=-aros - ;; - aux) - basic_machine=m68k-apple - os=-aux - ;; - balance) - basic_machine=ns32k-sequent - os=-dynix - ;; - blackfin) - basic_machine=bfin-unknown - os=-linux - ;; - blackfin-*) - basic_machine=bfin-`echo $basic_machine | sed 's/^[^-]*-//'` - os=-linux - ;; - bluegene*) - basic_machine=powerpc-ibm - os=-cnk - ;; - c54x-*) - basic_machine=tic54x-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - c55x-*) - basic_machine=tic55x-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - c6x-*) - basic_machine=tic6x-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - c90) - basic_machine=c90-cray - os=-unicos - ;; - cegcc) - basic_machine=arm-unknown - os=-cegcc - ;; - convex-c1) - basic_machine=c1-convex - os=-bsd - ;; - convex-c2) - basic_machine=c2-convex - os=-bsd - ;; - convex-c32) - basic_machine=c32-convex - os=-bsd - ;; - convex-c34) - basic_machine=c34-convex - os=-bsd - ;; - convex-c38) - basic_machine=c38-convex - os=-bsd - ;; - cray | j90) - basic_machine=j90-cray - os=-unicos - ;; - craynv) - basic_machine=craynv-cray - os=-unicosmp - ;; - cr16 | cr16-*) - basic_machine=cr16-unknown - os=-elf - ;; - crds | unos) - basic_machine=m68k-crds - ;; - crisv32 | crisv32-* | etraxfs*) - basic_machine=crisv32-axis - ;; - cris | cris-* | etrax*) - basic_machine=cris-axis - ;; - crx) - basic_machine=crx-unknown - os=-elf - ;; - da30 | da30-*) - basic_machine=m68k-da30 - ;; - decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn) - basic_machine=mips-dec - ;; - decsystem10* | dec10*) - basic_machine=pdp10-dec - os=-tops10 - ;; - decsystem20* | dec20*) - basic_machine=pdp10-dec - os=-tops20 - ;; - delta | 3300 | motorola-3300 | motorola-delta \ - | 3300-motorola | delta-motorola) - basic_machine=m68k-motorola - ;; - delta88) - basic_machine=m88k-motorola - os=-sysv3 - ;; - dicos) - basic_machine=i686-pc - os=-dicos - ;; - djgpp) - basic_machine=i586-pc - os=-msdosdjgpp - ;; - dpx20 | dpx20-*) - basic_machine=rs6000-bull - os=-bosx - ;; - dpx2* | dpx2*-bull) - basic_machine=m68k-bull - os=-sysv3 - ;; - ebmon29k) - basic_machine=a29k-amd - os=-ebmon - ;; - elxsi) - basic_machine=elxsi-elxsi - os=-bsd - ;; - encore | umax | mmax) - basic_machine=ns32k-encore - ;; - es1800 | OSE68k | ose68k | ose | OSE) - basic_machine=m68k-ericsson - os=-ose - ;; - fx2800) - basic_machine=i860-alliant - ;; - genix) - basic_machine=ns32k-ns - ;; - gmicro) - basic_machine=tron-gmicro - os=-sysv - ;; - go32) - basic_machine=i386-pc - os=-go32 - ;; - h3050r* | hiux*) - basic_machine=hppa1.1-hitachi - os=-hiuxwe2 - ;; - h8300hms) - basic_machine=h8300-hitachi - os=-hms - ;; - h8300xray) - basic_machine=h8300-hitachi - os=-xray - ;; - h8500hms) - basic_machine=h8500-hitachi - os=-hms - ;; - harris) - basic_machine=m88k-harris - os=-sysv3 - ;; - hp300-*) - basic_machine=m68k-hp - ;; - hp300bsd) - basic_machine=m68k-hp - os=-bsd - ;; - hp300hpux) - basic_machine=m68k-hp - os=-hpux - ;; - hp3k9[0-9][0-9] | hp9[0-9][0-9]) - basic_machine=hppa1.0-hp - ;; - hp9k2[0-9][0-9] | hp9k31[0-9]) - basic_machine=m68000-hp - ;; - hp9k3[2-9][0-9]) - basic_machine=m68k-hp - ;; - hp9k6[0-9][0-9] | hp6[0-9][0-9]) - basic_machine=hppa1.0-hp - ;; - hp9k7[0-79][0-9] | hp7[0-79][0-9]) - basic_machine=hppa1.1-hp - ;; - hp9k78[0-9] | hp78[0-9]) - # FIXME: really hppa2.0-hp - basic_machine=hppa1.1-hp - ;; - hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893) - # FIXME: really hppa2.0-hp - basic_machine=hppa1.1-hp - ;; - hp9k8[0-9][13679] | hp8[0-9][13679]) - basic_machine=hppa1.1-hp - ;; - hp9k8[0-9][0-9] | hp8[0-9][0-9]) - basic_machine=hppa1.0-hp - ;; - hppa-next) - os=-nextstep3 - ;; - hppaosf) - basic_machine=hppa1.1-hp - os=-osf - ;; - hppro) - basic_machine=hppa1.1-hp - os=-proelf - ;; - i370-ibm* | ibm*) - basic_machine=i370-ibm - ;; - i*86v32) - basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` - os=-sysv32 - ;; - i*86v4*) - basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` - os=-sysv4 - ;; - i*86v) - basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` - os=-sysv - ;; - i*86sol2) - basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` - os=-solaris2 - ;; - i386mach) - basic_machine=i386-mach - os=-mach - ;; - i386-vsta | vsta) - basic_machine=i386-unknown - os=-vsta - ;; - iris | iris4d) - basic_machine=mips-sgi - case $os in - -irix*) - ;; - *) - os=-irix4 - ;; - esac - ;; - isi68 | isi) - basic_machine=m68k-isi - os=-sysv - ;; - m68knommu) - basic_machine=m68k-unknown - os=-linux - ;; - m68knommu-*) - basic_machine=m68k-`echo $basic_machine | sed 's/^[^-]*-//'` - os=-linux - ;; - m88k-omron*) - basic_machine=m88k-omron - ;; - magnum | m3230) - basic_machine=mips-mips - os=-sysv - ;; - merlin) - basic_machine=ns32k-utek - os=-sysv - ;; - microblaze) - basic_machine=microblaze-xilinx - ;; - mingw64) - basic_machine=x86_64-pc - os=-mingw64 - ;; - mingw32) - basic_machine=i386-pc - os=-mingw32 - ;; - mingw32ce) - basic_machine=arm-unknown - os=-mingw32ce - ;; - miniframe) - basic_machine=m68000-convergent - ;; - *mint | -mint[0-9]* | *MiNT | *MiNT[0-9]*) - basic_machine=m68k-atari - os=-mint - ;; - mips3*-*) - basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'` - ;; - mips3*) - basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown - ;; - monitor) - basic_machine=m68k-rom68k - os=-coff - ;; - morphos) - basic_machine=powerpc-unknown - os=-morphos - ;; - msdos) - basic_machine=i386-pc - os=-msdos - ;; - ms1-*) - basic_machine=`echo $basic_machine | sed -e 's/ms1-/mt-/'` - ;; - msys) - basic_machine=i386-pc - os=-msys - ;; - mvs) - basic_machine=i370-ibm - os=-mvs - ;; - nacl) - basic_machine=le32-unknown - os=-nacl - ;; - ncr3000) - basic_machine=i486-ncr - os=-sysv4 - ;; - netbsd386) - basic_machine=i386-unknown - os=-netbsd - ;; - netwinder) - basic_machine=armv4l-rebel - os=-linux - ;; - news | news700 | news800 | news900) - basic_machine=m68k-sony - os=-newsos - ;; - news1000) - basic_machine=m68030-sony - os=-newsos - ;; - news-3600 | risc-news) - basic_machine=mips-sony - os=-newsos - ;; - necv70) - basic_machine=v70-nec - os=-sysv - ;; - next | m*-next ) - basic_machine=m68k-next - case $os in - -nextstep* ) - ;; - -ns2*) - os=-nextstep2 - ;; - *) - os=-nextstep3 - ;; - esac - ;; - nh3000) - basic_machine=m68k-harris - os=-cxux - ;; - nh[45]000) - basic_machine=m88k-harris - os=-cxux - ;; - nindy960) - basic_machine=i960-intel - os=-nindy - ;; - mon960) - basic_machine=i960-intel - os=-mon960 - ;; - nonstopux) - basic_machine=mips-compaq - os=-nonstopux - ;; - np1) - basic_machine=np1-gould - ;; - neo-tandem) - basic_machine=neo-tandem - ;; - nse-tandem) - basic_machine=nse-tandem - ;; - nsr-tandem) - basic_machine=nsr-tandem - ;; - op50n-* | op60c-*) - basic_machine=hppa1.1-oki - os=-proelf - ;; - openrisc | openrisc-*) - basic_machine=or32-unknown - ;; - os400) - basic_machine=powerpc-ibm - os=-os400 - ;; - OSE68000 | ose68000) - basic_machine=m68000-ericsson - os=-ose - ;; - os68k) - basic_machine=m68k-none - os=-os68k - ;; - pa-hitachi) - basic_machine=hppa1.1-hitachi - os=-hiuxwe2 - ;; - paragon) - basic_machine=i860-intel - os=-osf - ;; - parisc) - basic_machine=hppa-unknown - os=-linux - ;; - parisc-*) - basic_machine=hppa-`echo $basic_machine | sed 's/^[^-]*-//'` - os=-linux - ;; - pbd) - basic_machine=sparc-tti - ;; - pbb) - basic_machine=m68k-tti - ;; - pc532 | pc532-*) - basic_machine=ns32k-pc532 - ;; - pc98) - basic_machine=i386-pc - ;; - pc98-*) - basic_machine=i386-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - pentium | p5 | k5 | k6 | nexgen | viac3) - basic_machine=i586-pc - ;; - pentiumpro | p6 | 6x86 | athlon | athlon_*) - basic_machine=i686-pc - ;; - pentiumii | pentium2 | pentiumiii | pentium3) - basic_machine=i686-pc - ;; - pentium4) - basic_machine=i786-pc - ;; - pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*) - basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - pentiumpro-* | p6-* | 6x86-* | athlon-*) - basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - pentiumii-* | pentium2-* | pentiumiii-* | pentium3-*) - basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - pentium4-*) - basic_machine=i786-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - pn) - basic_machine=pn-gould - ;; - power) basic_machine=power-ibm - ;; - ppc | ppcbe) basic_machine=powerpc-unknown - ;; - ppc-* | ppcbe-*) - basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - ppcle | powerpclittle | ppc-le | powerpc-little) - basic_machine=powerpcle-unknown - ;; - ppcle-* | powerpclittle-*) - basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - ppc64) basic_machine=powerpc64-unknown - ;; - ppc64-*) basic_machine=powerpc64-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - ppc64le | powerpc64little | ppc64-le | powerpc64-little) - basic_machine=powerpc64le-unknown - ;; - ppc64le-* | powerpc64little-*) - basic_machine=powerpc64le-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - ps2) - basic_machine=i386-ibm - ;; - pw32) - basic_machine=i586-unknown - os=-pw32 - ;; - rdos) - basic_machine=i386-pc - os=-rdos - ;; - rom68k) - basic_machine=m68k-rom68k - os=-coff - ;; - rm[46]00) - basic_machine=mips-siemens - ;; - rtpc | rtpc-*) - basic_machine=romp-ibm - ;; - s390 | s390-*) - basic_machine=s390-ibm - ;; - s390x | s390x-*) - basic_machine=s390x-ibm - ;; - sa29200) - basic_machine=a29k-amd - os=-udi - ;; - sb1) - basic_machine=mipsisa64sb1-unknown - ;; - sb1el) - basic_machine=mipsisa64sb1el-unknown - ;; - sde) - basic_machine=mipsisa32-sde - os=-elf - ;; - sei) - basic_machine=mips-sei - os=-seiux - ;; - sequent) - basic_machine=i386-sequent - ;; - sh) - basic_machine=sh-hitachi - os=-hms - ;; - sh5el) - basic_machine=sh5le-unknown - ;; - sh64) - basic_machine=sh64-unknown - ;; - sparclite-wrs | simso-wrs) - basic_machine=sparclite-wrs - os=-vxworks - ;; - sps7) - basic_machine=m68k-bull - os=-sysv2 - ;; - spur) - basic_machine=spur-unknown - ;; - st2000) - basic_machine=m68k-tandem - ;; - stratus) - basic_machine=i860-stratus - os=-sysv4 - ;; - strongarm-* | thumb-*) - basic_machine=arm-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - sun2) - basic_machine=m68000-sun - ;; - sun2os3) - basic_machine=m68000-sun - os=-sunos3 - ;; - sun2os4) - basic_machine=m68000-sun - os=-sunos4 - ;; - sun3os3) - basic_machine=m68k-sun - os=-sunos3 - ;; - sun3os4) - basic_machine=m68k-sun - os=-sunos4 - ;; - sun4os3) - basic_machine=sparc-sun - os=-sunos3 - ;; - sun4os4) - basic_machine=sparc-sun - os=-sunos4 - ;; - sun4sol2) - basic_machine=sparc-sun - os=-solaris2 - ;; - sun3 | sun3-*) - basic_machine=m68k-sun - ;; - sun4) - basic_machine=sparc-sun - ;; - sun386 | sun386i | roadrunner) - basic_machine=i386-sun - ;; - sv1) - basic_machine=sv1-cray - os=-unicos - ;; - symmetry) - basic_machine=i386-sequent - os=-dynix - ;; - t3e) - basic_machine=alphaev5-cray - os=-unicos - ;; - t90) - basic_machine=t90-cray - os=-unicos - ;; - tile*) - basic_machine=$basic_machine-unknown - os=-linux-gnu - ;; - tx39) - basic_machine=mipstx39-unknown - ;; - tx39el) - basic_machine=mipstx39el-unknown - ;; - toad1) - basic_machine=pdp10-xkl - os=-tops20 - ;; - tower | tower-32) - basic_machine=m68k-ncr - ;; - tpf) - basic_machine=s390x-ibm - os=-tpf - ;; - udi29k) - basic_machine=a29k-amd - os=-udi - ;; - ultra3) - basic_machine=a29k-nyu - os=-sym1 - ;; - v810 | necv810) - basic_machine=v810-nec - os=-none - ;; - vaxv) - basic_machine=vax-dec - os=-sysv - ;; - vms) - basic_machine=vax-dec - os=-vms - ;; - vpp*|vx|vx-*) - basic_machine=f301-fujitsu - ;; - vxworks960) - basic_machine=i960-wrs - os=-vxworks - ;; - vxworks68) - basic_machine=m68k-wrs - os=-vxworks - ;; - vxworks29k) - basic_machine=a29k-wrs - os=-vxworks - ;; - w65*) - basic_machine=w65-wdc - os=-none - ;; - w89k-*) - basic_machine=hppa1.1-winbond - os=-proelf - ;; - xbox) - basic_machine=i686-pc - os=-mingw32 - ;; - xps | xps100) - basic_machine=xps100-honeywell - ;; - xscale-* | xscalee[bl]-*) - basic_machine=`echo $basic_machine | sed 's/^xscale/arm/'` - ;; - ymp) - basic_machine=ymp-cray - os=-unicos - ;; - z8k-*-coff) - basic_machine=z8k-unknown - os=-sim - ;; - z80-*-coff) - basic_machine=z80-unknown - os=-sim - ;; - none) - basic_machine=none-none - os=-none - ;; - -# Here we handle the default manufacturer of certain CPU types. It is in -# some cases the only manufacturer, in others, it is the most popular. - w89k) - basic_machine=hppa1.1-winbond - ;; - op50n) - basic_machine=hppa1.1-oki - ;; - op60c) - basic_machine=hppa1.1-oki - ;; - romp) - basic_machine=romp-ibm - ;; - mmix) - basic_machine=mmix-knuth - ;; - rs6000) - basic_machine=rs6000-ibm - ;; - vax) - basic_machine=vax-dec - ;; - pdp10) - # there are many clones, so DEC is not a safe bet - basic_machine=pdp10-unknown - ;; - pdp11) - basic_machine=pdp11-dec - ;; - we32k) - basic_machine=we32k-att - ;; - sh[1234] | sh[24]a | sh[24]aeb | sh[34]eb | sh[1234]le | sh[23]ele) - basic_machine=sh-unknown - ;; - sparc | sparcv8 | sparcv9 | sparcv9b | sparcv9v) - basic_machine=sparc-sun - ;; - cydra) - basic_machine=cydra-cydrome - ;; - orion) - basic_machine=orion-highlevel - ;; - orion105) - basic_machine=clipper-highlevel - ;; - mac | mpw | mac-mpw) - basic_machine=m68k-apple - ;; - pmac | pmac-mpw) - basic_machine=powerpc-apple - ;; - *-unknown) - # Make sure to match an already-canonicalized machine name. - ;; - *) - echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 - exit 1 - ;; -esac - -# Here we canonicalize certain aliases for manufacturers. -case $basic_machine in - *-digital*) - basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'` - ;; - *-commodore*) - basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'` - ;; - *) - ;; -esac - -# Decode manufacturer-specific aliases for certain operating systems. - -if [ x"$os" != x"" ] -then -case $os in - # First match some system type aliases - # that might get confused with valid system types. - # -solaris* is a basic system type, with this one exception. - -auroraux) - os=-auroraux - ;; - -solaris1 | -solaris1.*) - os=`echo $os | sed -e 's|solaris1|sunos4|'` - ;; - -solaris) - os=-solaris2 - ;; - -svr4*) - os=-sysv4 - ;; - -unixware*) - os=-sysv4.2uw - ;; - -gnu/linux*) - os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'` - ;; - # First accept the basic system types. - # The portable systems comes first. - # Each alternative MUST END IN A *, to match a version number. - # -sysv* is not here because it comes later, after sysvr4. - -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \ - | -*vms* | -sco* | -esix* | -isc* | -aix* | -cnk* | -sunos | -sunos[34]*\ - | -hpux* | -unos* | -osf* | -luna* | -dgux* | -auroraux* | -solaris* \ - | -sym* | -kopensolaris* \ - | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \ - | -aos* | -aros* \ - | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \ - | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \ - | -hiux* | -386bsd* | -knetbsd* | -mirbsd* | -netbsd* \ - | -bitrig* | -openbsd* | -solidbsd* \ - | -ekkobsd* | -kfreebsd* | -freebsd* | -riscix* | -lynxos* \ - | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \ - | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \ - | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \ - | -chorusos* | -chorusrdb* | -cegcc* \ - | -cygwin* | -msys* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ - | -mingw32* | -mingw64* | -linux-gnu* | -linux-android* \ - | -linux-newlib* | -linux-musl* | -linux-uclibc* \ - | -uxpv* | -beos* | -mpeix* | -udk* \ - | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* | -opened* \ - | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \ - | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \ - | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \ - | -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* \ - | -powermax* | -dnix* | -nx6 | -nx7 | -sei* | -dragonfly* \ - | -skyos* | -haiku* | -rdos* | -toppers* | -drops* | -es*) - # Remember, each alternative MUST END IN *, to match a version number. - ;; - -qnx*) - case $basic_machine in - x86-* | i*86-*) - ;; - *) - os=-nto$os - ;; - esac - ;; - -nto-qnx*) - ;; - -nto*) - os=`echo $os | sed -e 's|nto|nto-qnx|'` - ;; - -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \ - | -windows* | -osx | -abug | -netware* | -os9* | -beos* | -haiku* \ - | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*) - ;; - -mac*) - os=`echo $os | sed -e 's|mac|macos|'` - ;; - -linux-dietlibc) - os=-linux-dietlibc - ;; - -linux*) - os=`echo $os | sed -e 's|linux|linux-gnu|'` - ;; - -sunos5*) - os=`echo $os | sed -e 's|sunos5|solaris2|'` - ;; - -sunos6*) - os=`echo $os | sed -e 's|sunos6|solaris3|'` - ;; - -opened*) - os=-openedition - ;; - -os400*) - os=-os400 - ;; - -wince*) - os=-wince - ;; - -osfrose*) - os=-osfrose - ;; - -osf*) - os=-osf - ;; - -utek*) - os=-bsd - ;; - -dynix*) - os=-bsd - ;; - -acis*) - os=-aos - ;; - -atheos*) - os=-atheos - ;; - -syllable*) - os=-syllable - ;; - -386bsd) - os=-bsd - ;; - -ctix* | -uts*) - os=-sysv - ;; - -nova*) - os=-rtmk-nova - ;; - -ns2 ) - os=-nextstep2 - ;; - -nsk*) - os=-nsk - ;; - # Preserve the version number of sinix5. - -sinix5.*) - os=`echo $os | sed -e 's|sinix|sysv|'` - ;; - -sinix*) - os=-sysv4 - ;; - -tpf*) - os=-tpf - ;; - -triton*) - os=-sysv3 - ;; - -oss*) - os=-sysv3 - ;; - -svr4) - os=-sysv4 - ;; - -svr3) - os=-sysv3 - ;; - -sysvr4) - os=-sysv4 - ;; - # This must come after -sysvr4. - -sysv*) - ;; - -ose*) - os=-ose - ;; - -es1800*) - os=-ose - ;; - -xenix) - os=-xenix - ;; - -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) - os=-mint - ;; - -aros*) - os=-aros - ;; - -kaos*) - os=-kaos - ;; - -zvmoe) - os=-zvmoe - ;; - -dicos*) - os=-dicos - ;; - -nacl*) - ;; - -none) - ;; - *) - # Get rid of the `-' at the beginning of $os. - os=`echo $os | sed 's/[^-]*-//'` - echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2 - exit 1 - ;; -esac -else - -# Here we handle the default operating systems that come with various machines. -# The value should be what the vendor currently ships out the door with their -# machine or put another way, the most popular os provided with the machine. - -# Note that if you're going to try to match "-MANUFACTURER" here (say, -# "-sun"), then you have to tell the case statement up towards the top -# that MANUFACTURER isn't an operating system. Otherwise, code above -# will signal an error saying that MANUFACTURER isn't an operating -# system, and we'll never get to this point. - -case $basic_machine in - score-*) - os=-elf - ;; - spu-*) - os=-elf - ;; - *-acorn) - os=-riscix1.2 - ;; - arm*-rebel) - os=-linux - ;; - arm*-semi) - os=-aout - ;; - c4x-* | tic4x-*) - os=-coff - ;; - hexagon-*) - os=-elf - ;; - tic54x-*) - os=-coff - ;; - tic55x-*) - os=-coff - ;; - tic6x-*) - os=-coff - ;; - # This must come before the *-dec entry. - pdp10-*) - os=-tops20 - ;; - pdp11-*) - os=-none - ;; - *-dec | vax-*) - os=-ultrix4.2 - ;; - m68*-apollo) - os=-domain - ;; - i386-sun) - os=-sunos4.0.2 - ;; - m68000-sun) - os=-sunos3 - ;; - m68*-cisco) - os=-aout - ;; - mep-*) - os=-elf - ;; - mips*-cisco) - os=-elf - ;; - mips*-*) - os=-elf - ;; - or32-*) - os=-coff - ;; - *-tti) # must be before sparc entry or we get the wrong os. - os=-sysv3 - ;; - sparc-* | *-sun) - os=-sunos4.1.1 - ;; - *-be) - os=-beos - ;; - *-haiku) - os=-haiku - ;; - *-ibm) - os=-aix - ;; - *-knuth) - os=-mmixware - ;; - *-wec) - os=-proelf - ;; - *-winbond) - os=-proelf - ;; - *-oki) - os=-proelf - ;; - *-hp) - os=-hpux - ;; - *-hitachi) - os=-hiux - ;; - i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent) - os=-sysv - ;; - *-cbm) - os=-amigaos - ;; - *-dg) - os=-dgux - ;; - *-dolphin) - os=-sysv3 - ;; - m68k-ccur) - os=-rtu - ;; - m88k-omron*) - os=-luna - ;; - *-next ) - os=-nextstep - ;; - *-sequent) - os=-ptx - ;; - *-crds) - os=-unos - ;; - *-ns) - os=-genix - ;; - i370-*) - os=-mvs - ;; - *-next) - os=-nextstep3 - ;; - *-gould) - os=-sysv - ;; - *-highlevel) - os=-bsd - ;; - *-encore) - os=-bsd - ;; - *-sgi) - os=-irix - ;; - *-siemens) - os=-sysv4 - ;; - *-masscomp) - os=-rtu - ;; - f30[01]-fujitsu | f700-fujitsu) - os=-uxpv - ;; - *-rom68k) - os=-coff - ;; - *-*bug) - os=-coff - ;; - *-apple) - os=-macos - ;; - *-atari*) - os=-mint - ;; - *) - os=-none - ;; -esac -fi - -# Here we handle the case where we know the os, and the CPU type, but not the -# manufacturer. We pick the logical manufacturer. -vendor=unknown -case $basic_machine in - *-unknown) - case $os in - -riscix*) - vendor=acorn - ;; - -sunos*) - vendor=sun - ;; - -cnk*|-aix*) - vendor=ibm - ;; - -beos*) - vendor=be - ;; - -hpux*) - vendor=hp - ;; - -mpeix*) - vendor=hp - ;; - -hiux*) - vendor=hitachi - ;; - -unos*) - vendor=crds - ;; - -dgux*) - vendor=dg - ;; - -luna*) - vendor=omron - ;; - -genix*) - vendor=ns - ;; - -mvs* | -opened*) - vendor=ibm - ;; - -os400*) - vendor=ibm - ;; - -ptx*) - vendor=sequent - ;; - -tpf*) - vendor=ibm - ;; - -vxsim* | -vxworks* | -windiss*) - vendor=wrs - ;; - -aux*) - vendor=apple - ;; - -hms*) - vendor=hitachi - ;; - -mpw* | -macos*) - vendor=apple - ;; - -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) - vendor=atari - ;; - -vos*) - vendor=stratus - ;; - esac - basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"` - ;; -esac - -echo $basic_machine$os -exit - -# Local variables: -# eval: (add-hook 'write-file-hooks 'time-stamp) +# Copyright 1992-2018 Free Software Foundation, Inc. + +timestamp='2018-08-13' + +# This file is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, see . +# +# As a special exception to the GNU General Public License, if you +# distribute this file as part of a program that contains a +# configuration script generated by Autoconf, you may include it under +# the same distribution terms that you use for the rest of that +# program. This Exception is an additional permission under section 7 +# of the GNU General Public License, version 3 ("GPLv3"). + + +# Please send patches to . +# +# Configuration subroutine to validate and canonicalize a configuration type. +# Supply the specified configuration type as an argument. +# If it is invalid, we print an error message on stderr and exit with code 1. +# Otherwise, we print the canonical config type on stdout and succeed. + +# You can get the latest version of this script from: +# https://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.sub + +# This file is supposed to be the same for all GNU packages +# and recognize all the CPU types, system types and aliases +# that are meaningful with *any* GNU software. +# Each package is responsible for reporting which valid configurations +# it does not support. The user should be able to distinguish +# a failure to support a valid configuration from a meaningless +# configuration. + +# The goal of this file is to map all the various variations of a given +# machine specification into a single specification in the form: +# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM +# or in some cases, the newer four-part form: +# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM +# It is wrong to echo any other type of specification. + +me=`echo "$0" | sed -e 's,.*/,,'` + +usage="\ +Usage: $0 [OPTION] CPU-MFR-OPSYS or ALIAS + +Canonicalize a configuration name. + +Options: + -h, --help print this help, then exit + -t, --time-stamp print date of last modification, then exit + -v, --version print version number, then exit + +Report bugs and patches to ." + +version="\ +GNU config.sub ($timestamp) + +Copyright 1992-2018 Free Software Foundation, Inc. + +This is free software; see the source for copying conditions. There is NO +warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." + +help=" +Try \`$me --help' for more information." + +# Parse command line +while test $# -gt 0 ; do + case $1 in + --time-stamp | --time* | -t ) + echo "$timestamp" ; exit ;; + --version | -v ) + echo "$version" ; exit ;; + --help | --h* | -h ) + echo "$usage"; exit ;; + -- ) # Stop option processing + shift; break ;; + - ) # Use stdin as input. + break ;; + -* ) + echo "$me: invalid option $1$help" + exit 1 ;; + + *local*) + # First pass through any local machine types. + echo "$1" + exit ;; + + * ) + break ;; + esac +done + +case $# in + 0) echo "$me: missing argument$help" >&2 + exit 1;; + 1) ;; + *) echo "$me: too many arguments$help" >&2 + exit 1;; +esac + +# Split fields of configuration type +IFS="-" read -r field1 field2 field3 field4 <&2 + exit 1 + ;; + *-*-*-*) + basic_machine=$field1-$field2 + os=$field3-$field4 + ;; + *-*-*) + # Ambiguous whether COMPANY is present, or skipped and KERNEL-OS is two + # parts + maybe_os=$field2-$field3 + case $maybe_os in + nto-qnx* | linux-gnu* | linux-android* | linux-dietlibc \ + | linux-newlib* | linux-musl* | linux-uclibc* | uclinux-uclibc* \ + | uclinux-gnu* | kfreebsd*-gnu* | knetbsd*-gnu* | netbsd*-gnu* \ + | netbsd*-eabi* | kopensolaris*-gnu* | cloudabi*-eabi* \ + | storm-chaos* | os2-emx* | rtmk-nova*) + basic_machine=$field1 + os=$maybe_os + ;; + android-linux) + basic_machine=$field1-unknown + os=linux-android + ;; + *) + basic_machine=$field1-$field2 + os=$field3 + ;; + esac + ;; + *-*) + # Second component is usually, but not always the OS + case $field2 in + # Prevent following clause from handling this valid os + sun*os*) + basic_machine=$field1 + os=$field2 + ;; + # Manufacturers + dec* | mips* | sequent* | encore* | pc532* | sgi* | sony* \ + | att* | 7300* | 3300* | delta* | motorola* | sun[234]* \ + | unicom* | ibm* | next | hp | isi* | apollo | altos* \ + | convergent* | ncr* | news | 32* | 3600* | 3100* | hitachi* \ + | c[123]* | convex* | sun | crds | omron* | dg | ultra | tti* \ + | harris | dolphin | highlevel | gould | cbm | ns | masscomp \ + | apple | axis | knuth | cray | microblaze* \ + | sim | cisco | oki | wec | wrs | winbond) + basic_machine=$field1-$field2 + os= + ;; + *) + basic_machine=$field1 + os=$field2 + ;; + esac + ;; + *) + # Convert single-component short-hands not valid as part of + # multi-component configurations. + case $field1 in + 386bsd) + basic_machine=i386-pc + os=bsd + ;; + a29khif) + basic_machine=a29k-amd + os=udi + ;; + adobe68k) + basic_machine=m68010-adobe + os=scout + ;; + alliant) + basic_machine=fx80-alliant + os= + ;; + altos | altos3068) + basic_machine=m68k-altos + os= + ;; + am29k) + basic_machine=a29k-none + os=bsd + ;; + amdahl) + basic_machine=580-amdahl + os=sysv + ;; + amigaos | amigados) + basic_machine=m68k-unknown + os=amigaos + ;; + amigaunix | amix) + basic_machine=m68k-unknown + os=sysv4 + ;; + apollo68) + basic_machine=m68k-apollo + os=sysv + ;; + apollo68bsd) + basic_machine=m68k-apollo + os=bsd + ;; + aros) + basic_machine=i386-pc + os=aros + ;; + aux) + basic_machine=m68k-apple + os=aux + ;; + balance) + basic_machine=ns32k-sequent + os=dynix + ;; + blackfin) + basic_machine=bfin-unknown + os=linux + ;; + cegcc) + basic_machine=arm-unknown + os=cegcc + ;; + convex-c1) + basic_machine=c1-convex + os=bsd + ;; + convex-c2) + basic_machine=c2-convex + os=bsd + ;; + convex-c32) + basic_machine=c32-convex + os=bsd + ;; + convex-c34) + basic_machine=c34-convex + os=bsd + ;; + convex-c38) + basic_machine=c38-convex + os=bsd + ;; + cray) + basic_machine=j90-cray + os=unicos + ;; + crds | unos) + basic_machine=m68k-crds + os= + ;; + delta88) + basic_machine=m88k-motorola + os=sysv3 + ;; + dicos) + basic_machine=i686-pc + os=dicos + ;; + djgpp) + basic_machine=i586-pc + os=msdosdjgpp + ;; + ebmon29k) + basic_machine=a29k-amd + os=ebmon + ;; + es1800 | OSE68k | ose68k | ose | OSE) + basic_machine=m68k-ericsson + os=ose + ;; + gmicro) + basic_machine=tron-gmicro + os=sysv + ;; + go32) + basic_machine=i386-pc + os=go32 + ;; + h8300hms) + basic_machine=h8300-hitachi + os=hms + ;; + h8300xray) + basic_machine=h8300-hitachi + os=xray + ;; + h8500hms) + basic_machine=h8500-hitachi + os=hms + ;; + harris) + basic_machine=m88k-harris + os=sysv3 + ;; + hp300bsd) + basic_machine=m68k-hp + os=bsd + ;; + hp300hpux) + basic_machine=m68k-hp + os=hpux + ;; + hppaosf) + basic_machine=hppa1.1-hp + os=osf + ;; + hppro) + basic_machine=hppa1.1-hp + os=proelf + ;; + i386mach) + basic_machine=i386-mach + os=mach + ;; + vsta) + basic_machine=i386-pc + os=vsta + ;; + isi68 | isi) + basic_machine=m68k-isi + os=sysv + ;; + m68knommu) + basic_machine=m68k-unknown + os=linux + ;; + magnum | m3230) + basic_machine=mips-mips + os=sysv + ;; + merlin) + basic_machine=ns32k-utek + os=sysv + ;; + mingw64) + basic_machine=x86_64-pc + os=mingw64 + ;; + mingw32) + basic_machine=i686-pc + os=mingw32 + ;; + mingw32ce) + basic_machine=arm-unknown + os=mingw32ce + ;; + monitor) + basic_machine=m68k-rom68k + os=coff + ;; + morphos) + basic_machine=powerpc-unknown + os=morphos + ;; + moxiebox) + basic_machine=moxie-unknown + os=moxiebox + ;; + msdos) + basic_machine=i386-pc + os=msdos + ;; + msys) + basic_machine=i686-pc + os=msys + ;; + mvs) + basic_machine=i370-ibm + os=mvs + ;; + nacl) + basic_machine=le32-unknown + os=nacl + ;; + ncr3000) + basic_machine=i486-ncr + os=sysv4 + ;; + netbsd386) + basic_machine=i386-pc + os=netbsd + ;; + netwinder) + basic_machine=armv4l-rebel + os=linux + ;; + news | news700 | news800 | news900) + basic_machine=m68k-sony + os=newsos + ;; + news1000) + basic_machine=m68030-sony + os=newsos + ;; + necv70) + basic_machine=v70-nec + os=sysv + ;; + nh3000) + basic_machine=m68k-harris + os=cxux + ;; + nh[45]000) + basic_machine=m88k-harris + os=cxux + ;; + nindy960) + basic_machine=i960-intel + os=nindy + ;; + mon960) + basic_machine=i960-intel + os=mon960 + ;; + nonstopux) + basic_machine=mips-compaq + os=nonstopux + ;; + os400) + basic_machine=powerpc-ibm + os=os400 + ;; + OSE68000 | ose68000) + basic_machine=m68000-ericsson + os=ose + ;; + os68k) + basic_machine=m68k-none + os=os68k + ;; + paragon) + basic_machine=i860-intel + os=osf + ;; + parisc) + basic_machine=hppa-unknown + os=linux + ;; + pw32) + basic_machine=i586-unknown + os=pw32 + ;; + rdos | rdos64) + basic_machine=x86_64-pc + os=rdos + ;; + rdos32) + basic_machine=i386-pc + os=rdos + ;; + rom68k) + basic_machine=m68k-rom68k + os=coff + ;; + sa29200) + basic_machine=a29k-amd + os=udi + ;; + sei) + basic_machine=mips-sei + os=seiux + ;; + sps7) + basic_machine=m68k-bull + os=sysv2 + ;; + st2000) + basic_machine=m68k-tandem + os= + ;; + stratus) + basic_machine=i860-stratus + os=sysv4 + ;; + sun2) + basic_machine=m68000-sun + os= + ;; + sun2os3) + basic_machine=m68000-sun + os=sunos3 + ;; + sun2os4) + basic_machine=m68000-sun + os=sunos4 + ;; + sun3) + basic_machine=m68k-sun + os= + ;; + sun3os3) + basic_machine=m68k-sun + os=sunos3 + ;; + sun3os4) + basic_machine=m68k-sun + os=sunos4 + ;; + sun4) + basic_machine=sparc-sun + os= + ;; + sun4os3) + basic_machine=sparc-sun + os=sunos3 + ;; + sun4os4) + basic_machine=sparc-sun + os=sunos4 + ;; + sun4sol2) + basic_machine=sparc-sun + os=solaris2 + ;; + sun386 | sun386i | roadrunner) + basic_machine=i386-sun + os= + ;; + sv1) + basic_machine=sv1-cray + os=unicos + ;; + symmetry) + basic_machine=i386-sequent + os=dynix + ;; + t3e) + basic_machine=alphaev5-cray + os=unicos + ;; + t90) + basic_machine=t90-cray + os=unicos + ;; + toad1) + basic_machine=pdp10-xkl + os=tops20 + ;; + tpf) + basic_machine=s390x-ibm + os=tpf + ;; + udi29k) + basic_machine=a29k-amd + os=udi + ;; + ultra3) + basic_machine=a29k-nyu + os=sym1 + ;; + v810 | necv810) + basic_machine=v810-nec + os=none + ;; + vaxv) + basic_machine=vax-dec + os=sysv + ;; + vms) + basic_machine=vax-dec + os=vms + ;; + vxworks960) + basic_machine=i960-wrs + os=vxworks + ;; + vxworks68) + basic_machine=m68k-wrs + os=vxworks + ;; + vxworks29k) + basic_machine=a29k-wrs + os=vxworks + ;; + xbox) + basic_machine=i686-pc + os=mingw32 + ;; + ymp) + basic_machine=ymp-cray + os=unicos + ;; + *) + basic_machine=$1 + os= + ;; + esac + ;; +esac + +# Decode aliases for certain CPU-COMPANY combinations. +case $basic_machine in + # Here we handle the default manufacturer of certain CPU types. It is in + # some cases the only manufacturer, in others, it is the most popular. + craynv) + basic_machine=craynv-cray + os=${os:-unicosmp} + ;; + fx80) + basic_machine=fx80-alliant + ;; + w89k) + basic_machine=hppa1.1-winbond + ;; + op50n) + basic_machine=hppa1.1-oki + ;; + op60c) + basic_machine=hppa1.1-oki + ;; + romp) + basic_machine=romp-ibm + ;; + mmix) + basic_machine=mmix-knuth + ;; + rs6000) + basic_machine=rs6000-ibm + ;; + vax) + basic_machine=vax-dec + ;; + pdp11) + basic_machine=pdp11-dec + ;; + we32k) + basic_machine=we32k-att + ;; + cydra) + basic_machine=cydra-cydrome + ;; + i370-ibm* | ibm*) + basic_machine=i370-ibm + ;; + orion) + basic_machine=orion-highlevel + ;; + orion105) + basic_machine=clipper-highlevel + ;; + mac | mpw | mac-mpw) + basic_machine=m68k-apple + ;; + pmac | pmac-mpw) + basic_machine=powerpc-apple + ;; + xps | xps100) + basic_machine=xps100-honeywell + ;; + + # Recognize the basic CPU types without company name. + # Some are omitted here because they have special meanings below. + 1750a | 580 \ + | a29k \ + | aarch64 | aarch64_be \ + | abacus \ + | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \ + | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \ + | am33_2.0 \ + | arc | arceb \ + | arm | arm[bl]e | arme[lb] | armv[2-8] | armv[3-8][lb] | armv6m | armv[78][arm] \ + | avr | avr32 \ + | asmjs \ + | ba \ + | be32 | be64 \ + | bfin \ + | c4x | c8051 | clipper | csky \ + | d10v | d30v | dlx | dsp16xx \ + | e2k | epiphany \ + | fido | fr30 | frv | ft32 \ + | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \ + | hexagon \ + | i370 | i860 | i960 | ia16 | ia64 \ + | ip2k | iq2000 \ + | k1om \ + | le32 | le64 \ + | lm32 \ + | m32c | m32r | m32rle | m68000 | m68k | m88k \ + | m6811 | m68hc11 | m6812 | m68hc12 | m68hcs12x | nvptx | picochip \ + | maxq | mb | microblaze | microblazeel | mcore | mep | metag \ + | mips | mipsbe | mipseb | mipsel | mipsle \ + | mips16 \ + | mips64 | mips64el \ + | mips64octeon | mips64octeonel \ + | mips64orion | mips64orionel \ + | mips64r5900 | mips64r5900el \ + | mips64vr | mips64vrel \ + | mips64vr4100 | mips64vr4100el \ + | mips64vr4300 | mips64vr4300el \ + | mips64vr5000 | mips64vr5000el \ + | mips64vr5900 | mips64vr5900el \ + | mipsisa32 | mipsisa32el \ + | mipsisa32r2 | mipsisa32r2el \ + | mipsisa32r6 | mipsisa32r6el \ + | mipsisa64 | mipsisa64el \ + | mipsisa64r2 | mipsisa64r2el \ + | mipsisa64r6 | mipsisa64r6el \ + | mipsisa64sb1 | mipsisa64sb1el \ + | mipsisa64sr71k | mipsisa64sr71kel \ + | mipsr5900 | mipsr5900el \ + | mipstx39 | mipstx39el \ + | mn10200 | mn10300 \ + | moxie \ + | mt \ + | msp430 \ + | nds32 | nds32le | nds32be \ + | nfp \ + | nios | nios2 | nios2eb | nios2el \ + | ns16k | ns32k \ + | open8 | or1k | or1knd | or32 \ + | pdp10 | pj | pjl \ + | powerpc | powerpc64 | powerpc64le | powerpcle \ + | pru \ + | pyramid \ + | riscv | riscv32 | riscv64 \ + | rl78 | rx \ + | score \ + | sh | sh[1234] | sh[24]a | sh[24]aeb | sh[23]e | sh[234]eb | sheb | shbe | shle | sh[1234]le | sh[23]ele \ + | sh64 | sh64le \ + | sparc | sparc64 | sparc64b | sparc64v | sparc86x | sparclet | sparclite \ + | sparcv8 | sparcv9 | sparcv9b | sparcv9v \ + | spu \ + | tahoe | tic4x | tic54x | tic55x | tic6x | tic80 | tron \ + | ubicom32 \ + | v850 | v850e | v850e1 | v850e2 | v850es | v850e2v3 \ + | visium \ + | wasm32 \ + | x86 | xc16x | xstormy16 | xgate | xtensa \ + | z8k | z80) + basic_machine=$basic_machine-unknown + ;; + c54x) + basic_machine=tic54x-unknown + ;; + c55x) + basic_machine=tic55x-unknown + ;; + c6x) + basic_machine=tic6x-unknown + ;; + leon|leon[3-9]) + basic_machine=sparc-$basic_machine + ;; + m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65) + ;; + m9s12z | m68hcs12z | hcs12z | s12z) + basic_machine=s12z-unknown + ;; + m9s12z-* | m68hcs12z-* | hcs12z-* | s12z-*) + basic_machine=s12z-`echo "$basic_machine" | sed 's/^[^-]*-//'` + ;; + ms1) + basic_machine=mt-unknown + ;; + strongarm | thumb | xscale) + basic_machine=arm-unknown + ;; + xscaleeb) + basic_machine=armeb-unknown + ;; + + xscaleel) + basic_machine=armel-unknown + ;; + + # We use `pc' rather than `unknown' + # because (1) that's what they normally are, and + # (2) the word "unknown" tends to confuse beginning users. + i*86 | x86_64) + basic_machine=$basic_machine-pc + ;; + # Recognize the basic CPU types with company name. + 1750a-* | 580-* \ + | a29k-* \ + | aarch64-* | aarch64_be-* \ + | abacus-* \ + | alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \ + | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \ + | alphapca5[67]-* | alpha64pca5[67]-* \ + | am33_2.0-* \ + | arc-* | arceb-* \ + | arm-* | arm[lb]e-* | arme[lb]-* | armv*-* \ + | avr-* | avr32-* \ + | asmjs-* \ + | ba-* \ + | be32-* | be64-* \ + | bfin-* | bs2000-* \ + | c[123]* | c30-* | [cjt]90-* | c4x-* \ + | c8051-* | clipper-* | craynv-* | csky-* | cydra-* \ + | d10v-* | d30v-* | dlx-* | dsp16xx-* \ + | e2k-* | elxsi-* | epiphany-* \ + | f30[01]-* | f700-* | fido-* | fr30-* | frv-* | ft32-* | fx80-* \ + | h8300-* | h8500-* \ + | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \ + | hexagon-* \ + | i370-* | i*86-* | i860-* | i960-* | ia16-* | ia64-* \ + | ip2k-* | iq2000-* \ + | k1om-* \ + | le32-* | le64-* \ + | lm32-* \ + | m32c-* | m32r-* | m32rle-* \ + | m5200-* | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* | v70-* | w65-* \ + | m6811-* | m68hc11-* | m6812-* | m68hc12-* | m68hcs12x-* | nvptx-* | picochip-* \ + | m88110-* | m88k-* | maxq-* | mb-* | mcore-* | mep-* | metag-* \ + | microblaze-* | microblazeel-* \ + | mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \ + | mips16-* \ + | mips64-* | mips64el-* \ + | mips64octeon-* | mips64octeonel-* \ + | mips64orion-* | mips64orionel-* \ + | mips64r5900-* | mips64r5900el-* \ + | mips64vr-* | mips64vrel-* \ + | mips64vr4100-* | mips64vr4100el-* \ + | mips64vr4300-* | mips64vr4300el-* \ + | mips64vr5000-* | mips64vr5000el-* \ + | mips64vr5900-* | mips64vr5900el-* \ + | mipsisa32-* | mipsisa32el-* \ + | mipsisa32r2-* | mipsisa32r2el-* \ + | mipsisa32r6-* | mipsisa32r6el-* \ + | mipsisa64-* | mipsisa64el-* \ + | mipsisa64r2-* | mipsisa64r2el-* \ + | mipsisa64r6-* | mipsisa64r6el-* \ + | mipsisa64sb1-* | mipsisa64sb1el-* \ + | mipsisa64sr71k-* | mipsisa64sr71kel-* \ + | mipsr5900-* | mipsr5900el-* \ + | mipstx39-* | mipstx39el-* \ + | mmix-* \ + | mn10200-* | mn10300-* \ + | moxie-* \ + | mt-* \ + | msp430-* \ + | nds32-* | nds32le-* | nds32be-* \ + | nfp-* \ + | nios-* | nios2-* | nios2eb-* | nios2el-* \ + | none-* | np1-* | ns16k-* | ns32k-* \ + | open8-* \ + | or1k*-* \ + | or32-* \ + | orion-* \ + | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \ + | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* \ + | pru-* \ + | pyramid-* \ + | riscv-* | riscv32-* | riscv64-* \ + | rl78-* | romp-* | rs6000-* | rx-* \ + | score-* \ + | sh-* | sh[1234]-* | sh[24]a-* | sh[24]ae[lb]-* | sh[23]e-* | she[lb]-* | sh[lb]e-* \ + | sh[1234]e[lb]-* | sh[12345][lb]e-* | sh[23]ele-* | sh64-* | sh64le-* \ + | sparc-* | sparc64-* | sparc64b-* | sparc64v-* | sparc86x-* | sparclet-* \ + | sparclite-* \ + | sparcv8-* | sparcv9-* | sparcv9b-* | sparcv9v-* | sv1-* | sx*-* \ + | spu-* \ + | tahoe-* \ + | tic30-* | tic4x-* | tic54x-* | tic55x-* | tic6x-* | tic80-* \ + | tron-* \ + | ubicom32-* \ + | v850-* | v850e-* | v850e1-* | v850es-* | v850e2-* | v850e2v3-* \ + | vax-* \ + | visium-* \ + | wasm32-* \ + | we32k-* \ + | x86-* | x86_64-* | xc16x-* | xgate-* | xps100-* \ + | xstormy16-* | xtensa*-* \ + | ymp-* \ + | z8k-* | z80-*) + ;; + # Recognize the basic CPU types without company name, with glob match. + xtensa*) + basic_machine=$basic_machine-unknown + ;; + # Recognize the various machine names and aliases which stand + # for a CPU type and a company and sometimes even an OS. + 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc) + basic_machine=m68000-att + ;; + 3b*) + basic_machine=we32k-att + ;; + amd64) + basic_machine=x86_64-pc + ;; + amd64-*) + basic_machine=x86_64-`echo "$basic_machine" | sed 's/^[^-]*-//'` + ;; + amiga | amiga-*) + basic_machine=m68k-unknown + ;; + blackfin-*) + basic_machine=bfin-`echo "$basic_machine" | sed 's/^[^-]*-//'` + os=linux + ;; + bluegene*) + basic_machine=powerpc-ibm + os=cnk + ;; + c54x-*) + basic_machine=tic54x-`echo "$basic_machine" | sed 's/^[^-]*-//'` + ;; + c55x-*) + basic_machine=tic55x-`echo "$basic_machine" | sed 's/^[^-]*-//'` + ;; + c6x-*) + basic_machine=tic6x-`echo "$basic_machine" | sed 's/^[^-]*-//'` + ;; + c90) + basic_machine=c90-cray + os=${os:-unicos} + ;; + cr16 | cr16-*) + basic_machine=cr16-unknown + os=${os:-elf} + ;; + crisv32 | crisv32-* | etraxfs*) + basic_machine=crisv32-axis + ;; + cris | cris-* | etrax*) + basic_machine=cris-axis + ;; + crx) + basic_machine=crx-unknown + os=${os:-elf} + ;; + da30 | da30-*) + basic_machine=m68k-da30 + ;; + decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn) + basic_machine=mips-dec + ;; + decsystem10* | dec10*) + basic_machine=pdp10-dec + os=tops10 + ;; + decsystem20* | dec20*) + basic_machine=pdp10-dec + os=tops20 + ;; + delta | 3300 | motorola-3300 | motorola-delta \ + | 3300-motorola | delta-motorola) + basic_machine=m68k-motorola + ;; + dpx20 | dpx20-*) + basic_machine=rs6000-bull + os=${os:-bosx} + ;; + dpx2*) + basic_machine=m68k-bull + os=sysv3 + ;; + e500v[12]) + basic_machine=powerpc-unknown + os=$os"spe" + ;; + e500v[12]-*) + basic_machine=powerpc-`echo "$basic_machine" | sed 's/^[^-]*-//'` + os=$os"spe" + ;; + encore | umax | mmax) + basic_machine=ns32k-encore + ;; + elxsi) + basic_machine=elxsi-elxsi + os=${os:-bsd} + ;; + fx2800) + basic_machine=i860-alliant + ;; + genix) + basic_machine=ns32k-ns + ;; + h3050r* | hiux*) + basic_machine=hppa1.1-hitachi + os=hiuxwe2 + ;; + hp300-*) + basic_machine=m68k-hp + ;; + hp3k9[0-9][0-9] | hp9[0-9][0-9]) + basic_machine=hppa1.0-hp + ;; + hp9k2[0-9][0-9] | hp9k31[0-9]) + basic_machine=m68000-hp + ;; + hp9k3[2-9][0-9]) + basic_machine=m68k-hp + ;; + hp9k6[0-9][0-9] | hp6[0-9][0-9]) + basic_machine=hppa1.0-hp + ;; + hp9k7[0-79][0-9] | hp7[0-79][0-9]) + basic_machine=hppa1.1-hp + ;; + hp9k78[0-9] | hp78[0-9]) + # FIXME: really hppa2.0-hp + basic_machine=hppa1.1-hp + ;; + hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893) + # FIXME: really hppa2.0-hp + basic_machine=hppa1.1-hp + ;; + hp9k8[0-9][13679] | hp8[0-9][13679]) + basic_machine=hppa1.1-hp + ;; + hp9k8[0-9][0-9] | hp8[0-9][0-9]) + basic_machine=hppa1.0-hp + ;; + i*86v32) + basic_machine=`echo "$1" | sed -e 's/86.*/86-pc/'` + os=sysv32 + ;; + i*86v4*) + basic_machine=`echo "$1" | sed -e 's/86.*/86-pc/'` + os=sysv4 + ;; + i*86v) + basic_machine=`echo "$1" | sed -e 's/86.*/86-pc/'` + os=sysv + ;; + i*86sol2) + basic_machine=`echo "$1" | sed -e 's/86.*/86-pc/'` + os=solaris2 + ;; + j90 | j90-cray) + basic_machine=j90-cray + os=${os:-unicos} + ;; + iris | iris4d) + basic_machine=mips-sgi + case $os in + irix*) + ;; + *) + os=irix4 + ;; + esac + ;; + leon-*|leon[3-9]-*) + basic_machine=sparc-`echo "$basic_machine" | sed 's/-.*//'` + ;; + m68knommu-*) + basic_machine=m68k-`echo "$basic_machine" | sed 's/^[^-]*-//'` + os=linux + ;; + microblaze*) + basic_machine=microblaze-xilinx + ;; + miniframe) + basic_machine=m68000-convergent + ;; + *mint | mint[0-9]* | *MiNT | *MiNT[0-9]*) + basic_machine=m68k-atari + os=mint + ;; + mips3*-*) + basic_machine=`echo "$basic_machine" | sed -e 's/mips3/mips64/'` + ;; + mips3*) + basic_machine=`echo "$basic_machine" | sed -e 's/mips3/mips64/'`-unknown + ;; + ms1-*) + basic_machine=`echo "$basic_machine" | sed -e 's/ms1-/mt-/'` + ;; + news-3600 | risc-news) + basic_machine=mips-sony + os=newsos + ;; + next | m*-next) + basic_machine=m68k-next + case $os in + nextstep* ) + ;; + ns2*) + os=nextstep2 + ;; + *) + os=nextstep3 + ;; + esac + ;; + np1) + basic_machine=np1-gould + ;; + neo-tandem) + basic_machine=neo-tandem + ;; + nse-tandem) + basic_machine=nse-tandem + ;; + nsr-tandem) + basic_machine=nsr-tandem + ;; + nsv-tandem) + basic_machine=nsv-tandem + ;; + nsx-tandem) + basic_machine=nsx-tandem + ;; + op50n-* | op60c-*) + basic_machine=hppa1.1-oki + os=proelf + ;; + openrisc | openrisc-*) + basic_machine=or32-unknown + ;; + pa-hitachi) + basic_machine=hppa1.1-hitachi + os=hiuxwe2 + ;; + parisc-*) + basic_machine=hppa-`echo "$basic_machine" | sed 's/^[^-]*-//'` + os=linux + ;; + pbd) + basic_machine=sparc-tti + ;; + pbb) + basic_machine=m68k-tti + ;; + pc532 | pc532-*) + basic_machine=ns32k-pc532 + ;; + pc98) + basic_machine=i386-pc + ;; + pc98-*) + basic_machine=i386-`echo "$basic_machine" | sed 's/^[^-]*-//'` + ;; + pentium | p5 | k5 | k6 | nexgen | viac3) + basic_machine=i586-pc + ;; + pentiumpro | p6 | 6x86 | athlon | athlon_*) + basic_machine=i686-pc + ;; + pentiumii | pentium2 | pentiumiii | pentium3) + basic_machine=i686-pc + ;; + pentium4) + basic_machine=i786-pc + ;; + pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*) + basic_machine=i586-`echo "$basic_machine" | sed 's/^[^-]*-//'` + ;; + pentiumpro-* | p6-* | 6x86-* | athlon-*) + basic_machine=i686-`echo "$basic_machine" | sed 's/^[^-]*-//'` + ;; + pentiumii-* | pentium2-* | pentiumiii-* | pentium3-*) + basic_machine=i686-`echo "$basic_machine" | sed 's/^[^-]*-//'` + ;; + pentium4-*) + basic_machine=i786-`echo "$basic_machine" | sed 's/^[^-]*-//'` + ;; + pn) + basic_machine=pn-gould + ;; + power) basic_machine=power-ibm + ;; + ppc | ppcbe) basic_machine=powerpc-unknown + ;; + ppc-* | ppcbe-*) + basic_machine=powerpc-`echo "$basic_machine" | sed 's/^[^-]*-//'` + ;; + ppcle | powerpclittle) + basic_machine=powerpcle-unknown + ;; + ppcle-* | powerpclittle-*) + basic_machine=powerpcle-`echo "$basic_machine" | sed 's/^[^-]*-//'` + ;; + ppc64) basic_machine=powerpc64-unknown + ;; + ppc64-*) basic_machine=powerpc64-`echo "$basic_machine" | sed 's/^[^-]*-//'` + ;; + ppc64le | powerpc64little) + basic_machine=powerpc64le-unknown + ;; + ppc64le-* | powerpc64little-*) + basic_machine=powerpc64le-`echo "$basic_machine" | sed 's/^[^-]*-//'` + ;; + ps2) + basic_machine=i386-ibm + ;; + rm[46]00) + basic_machine=mips-siemens + ;; + rtpc | rtpc-*) + basic_machine=romp-ibm + ;; + s390 | s390-*) + basic_machine=s390-ibm + ;; + s390x | s390x-*) + basic_machine=s390x-ibm + ;; + sb1) + basic_machine=mipsisa64sb1-unknown + ;; + sb1el) + basic_machine=mipsisa64sb1el-unknown + ;; + sde) + basic_machine=mipsisa32-sde + os=${os:-elf} + ;; + sequent) + basic_machine=i386-sequent + ;; + sh5el) + basic_machine=sh5le-unknown + ;; + sh5el-*) + basic_machine=sh5le-`echo "$basic_machine" | sed 's/^[^-]*-//'` + ;; + simso-wrs) + basic_machine=sparclite-wrs + os=vxworks + ;; + spur) + basic_machine=spur-unknown + ;; + strongarm-* | thumb-*) + basic_machine=arm-`echo "$basic_machine" | sed 's/^[^-]*-//'` + ;; + tile*-*) + ;; + tile*) + basic_machine=$basic_machine-unknown + os=${os:-linux-gnu} + ;; + tx39) + basic_machine=mipstx39-unknown + ;; + tx39el) + basic_machine=mipstx39el-unknown + ;; + tower | tower-32) + basic_machine=m68k-ncr + ;; + vpp*|vx|vx-*) + basic_machine=f301-fujitsu + ;; + w65*) + basic_machine=w65-wdc + os=none + ;; + w89k-*) + basic_machine=hppa1.1-winbond + os=proelf + ;; + x64) + basic_machine=x86_64-pc + ;; + xscale-* | xscalee[bl]-*) + basic_machine=`echo "$basic_machine" | sed 's/^xscale/arm/'` + ;; + none) + basic_machine=none-none + ;; + + *) + echo Invalid configuration \`"$1"\': machine \`"$basic_machine"\' not recognized 1>&2 + exit 1 + ;; +esac + +# Here we canonicalize certain aliases for manufacturers. +case $basic_machine in + *-digital*) + basic_machine=`echo "$basic_machine" | sed 's/digital.*/dec/'` + ;; + *-commodore*) + basic_machine=`echo "$basic_machine" | sed 's/commodore.*/cbm/'` + ;; + *) + ;; +esac + +# Decode manufacturer-specific aliases for certain operating systems. + +if [ x$os != x ] +then +case $os in + # First match some system type aliases that might get confused + # with valid system types. + # solaris* is a basic system type, with this one exception. + auroraux) + os=auroraux + ;; + bluegene*) + os=cnk + ;; + solaris1 | solaris1.*) + os=`echo $os | sed -e 's|solaris1|sunos4|'` + ;; + solaris) + os=solaris2 + ;; + unixware*) + os=sysv4.2uw + ;; + gnu/linux*) + os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'` + ;; + # es1800 is here to avoid being matched by es* (a different OS) + es1800*) + os=ose + ;; + # Some version numbers need modification + chorusos*) + os=chorusos + ;; + isc) + os=isc2.2 + ;; + sco6) + os=sco5v6 + ;; + sco5) + os=sco3.2v5 + ;; + sco4) + os=sco3.2v4 + ;; + sco3.2.[4-9]*) + os=`echo $os | sed -e 's/sco3.2./sco3.2v/'` + ;; + sco3.2v[4-9]* | sco5v6*) + # Don't forget version if it is 3.2v4 or newer. + ;; + scout) + # Don't match below + ;; + sco*) + os=sco3.2v2 + ;; + psos*) + os=psos + ;; + # Now accept the basic system types. + # The portable systems comes first. + # Each alternative MUST end in a * to match a version number. + # sysv* is not here because it comes later, after sysvr4. + gnu* | bsd* | mach* | minix* | genix* | ultrix* | irix* \ + | *vms* | esix* | aix* | cnk* | sunos | sunos[34]*\ + | hpux* | unos* | osf* | luna* | dgux* | auroraux* | solaris* \ + | sym* | kopensolaris* | plan9* \ + | amigaos* | amigados* | msdos* | newsos* | unicos* | aof* \ + | aos* | aros* | cloudabi* | sortix* \ + | nindy* | vxsim* | vxworks* | ebmon* | hms* | mvs* \ + | clix* | riscos* | uniplus* | iris* | isc* | rtu* | xenix* \ + | knetbsd* | mirbsd* | netbsd* \ + | bitrig* | openbsd* | solidbsd* | libertybsd* \ + | ekkobsd* | kfreebsd* | freebsd* | riscix* | lynxos* \ + | bosx* | nextstep* | cxux* | aout* | elf* | oabi* \ + | ptx* | coff* | ecoff* | winnt* | domain* | vsta* \ + | udi* | eabi* | lites* | ieee* | go32* | aux* | hcos* \ + | chorusrdb* | cegcc* | glidix* \ + | cygwin* | msys* | pe* | moss* | proelf* | rtems* \ + | midipix* | mingw32* | mingw64* | linux-gnu* | linux-android* \ + | linux-newlib* | linux-musl* | linux-uclibc* \ + | uxpv* | beos* | mpeix* | udk* | moxiebox* \ + | interix* | uwin* | mks* | rhapsody* | darwin* \ + | openstep* | oskit* | conix* | pw32* | nonstopux* \ + | storm-chaos* | tops10* | tenex* | tops20* | its* \ + | os2* | vos* | palmos* | uclinux* | nucleus* \ + | morphos* | superux* | rtmk* | windiss* \ + | powermax* | dnix* | nx6 | nx7 | sei* | dragonfly* \ + | skyos* | haiku* | rdos* | toppers* | drops* | es* \ + | onefs* | tirtos* | phoenix* | fuchsia* | redox* | bme* \ + | midnightbsd*) + # Remember, each alternative MUST END IN *, to match a version number. + ;; + qnx*) + case $basic_machine in + x86-* | i*86-*) + ;; + *) + os=nto-$os + ;; + esac + ;; + hiux*) + os=hiuxwe2 + ;; + nto-qnx*) + ;; + nto*) + os=`echo $os | sed -e 's|nto|nto-qnx|'` + ;; + sim | xray | os68k* | v88r* \ + | windows* | osx | abug | netware* | os9* \ + | macos* | mpw* | magic* | mmixware* | mon960* | lnews*) + ;; + linux-dietlibc) + os=linux-dietlibc + ;; + linux*) + os=`echo $os | sed -e 's|linux|linux-gnu|'` + ;; + lynx*178) + os=lynxos178 + ;; + lynx*5) + os=lynxos5 + ;; + lynx*) + os=lynxos + ;; + mac*) + os=`echo "$os" | sed -e 's|mac|macos|'` + ;; + opened*) + os=openedition + ;; + os400*) + os=os400 + ;; + sunos5*) + os=`echo "$os" | sed -e 's|sunos5|solaris2|'` + ;; + sunos6*) + os=`echo "$os" | sed -e 's|sunos6|solaris3|'` + ;; + wince*) + os=wince + ;; + utek*) + os=bsd + ;; + dynix*) + os=bsd + ;; + acis*) + os=aos + ;; + atheos*) + os=atheos + ;; + syllable*) + os=syllable + ;; + 386bsd) + os=bsd + ;; + ctix* | uts*) + os=sysv + ;; + nova*) + os=rtmk-nova + ;; + ns2) + os=nextstep2 + ;; + nsk*) + os=nsk + ;; + # Preserve the version number of sinix5. + sinix5.*) + os=`echo $os | sed -e 's|sinix|sysv|'` + ;; + sinix*) + os=sysv4 + ;; + tpf*) + os=tpf + ;; + triton*) + os=sysv3 + ;; + oss*) + os=sysv3 + ;; + svr4*) + os=sysv4 + ;; + svr3) + os=sysv3 + ;; + sysvr4) + os=sysv4 + ;; + # This must come after sysvr4. + sysv*) + ;; + ose*) + os=ose + ;; + *mint | mint[0-9]* | *MiNT | MiNT[0-9]*) + os=mint + ;; + zvmoe) + os=zvmoe + ;; + dicos*) + os=dicos + ;; + pikeos*) + # Until real need of OS specific support for + # particular features comes up, bare metal + # configurations are quite functional. + case $basic_machine in + arm*) + os=eabi + ;; + *) + os=elf + ;; + esac + ;; + nacl*) + ;; + ios) + ;; + none) + ;; + *-eabi) + ;; + *) + echo Invalid configuration \`"$1"\': system \`"$os"\' not recognized 1>&2 + exit 1 + ;; +esac +else + +# Here we handle the default operating systems that come with various machines. +# The value should be what the vendor currently ships out the door with their +# machine or put another way, the most popular os provided with the machine. + +# Note that if you're going to try to match "-MANUFACTURER" here (say, +# "-sun"), then you have to tell the case statement up towards the top +# that MANUFACTURER isn't an operating system. Otherwise, code above +# will signal an error saying that MANUFACTURER isn't an operating +# system, and we'll never get to this point. + +case $basic_machine in + score-*) + os=elf + ;; + spu-*) + os=elf + ;; + *-acorn) + os=riscix1.2 + ;; + arm*-rebel) + os=linux + ;; + arm*-semi) + os=aout + ;; + c4x-* | tic4x-*) + os=coff + ;; + c8051-*) + os=elf + ;; + clipper-intergraph) + os=clix + ;; + hexagon-*) + os=elf + ;; + tic54x-*) + os=coff + ;; + tic55x-*) + os=coff + ;; + tic6x-*) + os=coff + ;; + # This must come before the *-dec entry. + pdp10-*) + os=tops20 + ;; + pdp11-*) + os=none + ;; + *-dec | vax-*) + os=ultrix4.2 + ;; + m68*-apollo) + os=domain + ;; + i386-sun) + os=sunos4.0.2 + ;; + m68000-sun) + os=sunos3 + ;; + m68*-cisco) + os=aout + ;; + mep-*) + os=elf + ;; + mips*-cisco) + os=elf + ;; + mips*-*) + os=elf + ;; + or32-*) + os=coff + ;; + *-tti) # must be before sparc entry or we get the wrong os. + os=sysv3 + ;; + sparc-* | *-sun) + os=sunos4.1.1 + ;; + pru-*) + os=elf + ;; + *-be) + os=beos + ;; + *-ibm) + os=aix + ;; + *-knuth) + os=mmixware + ;; + *-wec) + os=proelf + ;; + *-winbond) + os=proelf + ;; + *-oki) + os=proelf + ;; + *-hp) + os=hpux + ;; + *-hitachi) + os=hiux + ;; + i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent) + os=sysv + ;; + *-cbm) + os=amigaos + ;; + *-dg) + os=dgux + ;; + *-dolphin) + os=sysv3 + ;; + m68k-ccur) + os=rtu + ;; + m88k-omron*) + os=luna + ;; + *-next) + os=nextstep + ;; + *-sequent) + os=ptx + ;; + *-crds) + os=unos + ;; + *-ns) + os=genix + ;; + i370-*) + os=mvs + ;; + *-gould) + os=sysv + ;; + *-highlevel) + os=bsd + ;; + *-encore) + os=bsd + ;; + *-sgi) + os=irix + ;; + *-siemens) + os=sysv4 + ;; + *-masscomp) + os=rtu + ;; + f30[01]-fujitsu | f700-fujitsu) + os=uxpv + ;; + *-rom68k) + os=coff + ;; + *-*bug) + os=coff + ;; + *-apple) + os=macos + ;; + *-atari*) + os=mint + ;; + *-wrs) + os=vxworks + ;; + *) + os=none + ;; +esac +fi + +# Here we handle the case where we know the os, and the CPU type, but not the +# manufacturer. We pick the logical manufacturer. +vendor=unknown +case $basic_machine in + *-unknown) + case $os in + riscix*) + vendor=acorn + ;; + sunos*) + vendor=sun + ;; + cnk*|-aix*) + vendor=ibm + ;; + beos*) + vendor=be + ;; + hpux*) + vendor=hp + ;; + mpeix*) + vendor=hp + ;; + hiux*) + vendor=hitachi + ;; + unos*) + vendor=crds + ;; + dgux*) + vendor=dg + ;; + luna*) + vendor=omron + ;; + genix*) + vendor=ns + ;; + clix*) + vendor=intergraph + ;; + mvs* | opened*) + vendor=ibm + ;; + os400*) + vendor=ibm + ;; + ptx*) + vendor=sequent + ;; + tpf*) + vendor=ibm + ;; + vxsim* | vxworks* | windiss*) + vendor=wrs + ;; + aux*) + vendor=apple + ;; + hms*) + vendor=hitachi + ;; + mpw* | macos*) + vendor=apple + ;; + *mint | mint[0-9]* | *MiNT | MiNT[0-9]*) + vendor=atari + ;; + vos*) + vendor=stratus + ;; + esac + basic_machine=`echo "$basic_machine" | sed "s/unknown/$vendor/"` + ;; +esac + +echo "$basic_machine-$os" +exit + +# Local variables: +# eval: (add-hook 'before-save-hook 'time-stamp) # time-stamp-start: "timestamp='" # time-stamp-format: "%:y-%02m-%02d" # time-stamp-end: "'" diff --git a/data/nix/configure.ac b/data/nix/configure.ac --- a/data/nix/configure.ac +++ b/data/nix/configure.ac @@ -64,6 +64,7 @@ AC_PROG_CPP AX_CXX_COMPILE_STDCXX_14 +AC_CHECK_TOOL([AR], [ar]) # Use 64-bit file system calls so that we can support files > 2 GiB. AC_SYS_LARGEFILE @@ -127,8 +128,6 @@ NEED_PROG(gzip, gzip) NEED_PROG(xz, xz) AC_PATH_PROG(dot, dot) -AC_PATH_PROG(pv, pv, pv) -AC_PATH_PROGS(brotli, brotli bro, bro) AC_PATH_PROG(lsof, lsof, lsof) @@ -152,9 +151,9 @@ # Look for libbz2, a required dependency. AC_CHECK_LIB([bz2], [BZ2_bzWriteOpen], [true], - [AC_MSG_ERROR([Nix requires libbz2, which is part of bzip2. See http://www.bzip.org/.])]) + [AC_MSG_ERROR([Nix requires libbz2, which is part of bzip2. See https://web.archive.org/web/20180624184756/http://www.bzip.org/.])]) AC_CHECK_HEADERS([bzlib.h], [true], - [AC_MSG_ERROR([Nix requires libbz2, which is part of bzip2. See http://www.bzip.org/.])]) + [AC_MSG_ERROR([Nix requires libbz2, which is part of bzip2. See https://web.archive.org/web/20180624184756/http://www.bzip.org/.])]) # Look for SQLite, a required dependency. @@ -164,6 +163,8 @@ # Look for libcurl, a required dependency. PKG_CHECK_MODULES([LIBCURL], [libcurl], [CXXFLAGS="$LIBCURL_CFLAGS $CXXFLAGS"]) +# Look for editline, a required dependency. +PKG_CHECK_MODULES([EDITLINE], [libeditline], [CXXFLAGS="$EDITLINE_CFLAGS $CXXFLAGS"]) # Look for libsodium, an optional dependency. PKG_CHECK_MODULES([SODIUM], [libsodium], @@ -179,13 +180,10 @@ [AC_DEFINE([HAVE_LZMA_MT], [1], [xz multithreaded compression support])]) -# Look for libbrotli{enc,dec}, optional dependencies -PKG_CHECK_MODULES([LIBBROTLI], [libbrotlienc libbrotlidec], - [AC_DEFINE([HAVE_BROTLI], [1], [Whether to use libbrotli.]) - CXXFLAGS="$LIBBROTLI_CFLAGS $CXXFLAGS"] - have_brotli=1], [have_brotli=]) -AC_SUBST(HAVE_BROTLI, [$have_brotli]) +# Look for libbrotli{enc,dec}. +PKG_CHECK_MODULES([LIBBROTLI], [libbrotlienc libbrotlidec], [CXXFLAGS="$LIBBROTLI_CFLAGS $CXXFLAGS"]) + # Look for libseccomp, required for Linux sandboxing. if test "$sys_name" = linux; then AC_ARG_ENABLE([seccomp-sandboxing], @@ -232,12 +230,6 @@ fi -AC_ARG_ENABLE(init-state, AC_HELP_STRING([--disable-init-state], - [do not initialise DB etc. in `make install']), - init_state=$enableval, init_state=yes) -#AM_CONDITIONAL(INIT_STATE, test "$init_state" = "yes") - - # documentation generation switch AC_ARG_ENABLE(doc-gen, AC_HELP_STRING([--disable-doc-gen], [disable documentation generation]), @@ -260,11 +252,6 @@ fi -# Figure out the extension of dynamic libraries. -eval dynlib_suffix=$shrext_cmds -AC_SUBST(dynlib_suffix) - - # Do we have GNU tar? AC_MSG_CHECKING([if you have a recent GNU tar]) if $tar --version 2> /dev/null | grep -q GNU && tar cvf /dev/null --warning=no-timestamp ./config.log > /dev/null; then @@ -280,6 +267,15 @@ [path of a statically-linked shell to use as /bin/sh in sandboxes]), sandbox_shell=$withval) AC_SUBST(sandbox_shell) + +AC_ARG_ENABLE(shared, AC_HELP_STRING([--enable-shared], + [Build shared libraries for Nix [default=yes]]), + shared=$enableval, shared=yes) +if test "$shared" = yes; then + AC_SUBST(BUILD_SHARED_LIBS, 1, [Whether to build shared libraries.]) +else + AC_SUBST(BUILD_SHARED_LIBS, 0, [Whether to build shared libraries.]) +fi # Expand all variables in config.status. diff --git a/data/nix/corepkgs/fetchurl.nix b/data/nix/corepkgs/fetchurl.nix --- a/data/nix/corepkgs/fetchurl.nix +++ b/data/nix/corepkgs/fetchurl.nix @@ -1,10 +1,14 @@ { system ? "" # obsolete , url +, hash ? "" # an SRI ash + +# Legacy hash specification , md5 ? "", sha1 ? "", sha256 ? "", sha512 ? "" , outputHash ? - if sha512 != "" then sha512 else if sha1 != "" then sha1 else if md5 != "" then md5 else sha256 + if hash != "" then hash else if sha512 != "" then sha512 else if sha1 != "" then sha1 else if md5 != "" then md5 else sha256 , outputHashAlgo ? - if sha512 != "" then "sha512" else if sha1 != "" then "sha1" else if md5 != "" then "md5" else "sha256" + 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) diff --git a/data/nix/local.mk b/data/nix/local.mk --- a/data/nix/local.mk +++ b/data/nix/local.mk @@ -6,7 +6,7 @@ clean-files += Makefile.config -GLOBAL_CXXFLAGS += -I . -I src -I src/libutil -I src/libstore -I src/libmain -I src/libexpr +GLOBAL_CXXFLAGS += -I . -I src -I src/libutil -I src/libstore -I src/libmain -I src/libexpr -I src/nix $(foreach i, config.h $(call rwildcard, src/lib*, *.hh), \ $(eval $(call install-file-in, $(i), $(includedir)/nix, 0644))) diff --git a/data/nix/maintainers/upload-release.pl b/data/nix/maintainers/upload-release.pl --- a/data/nix/maintainers/upload-release.pl +++ b/data/nix/maintainers/upload-release.pl @@ -76,16 +76,23 @@ write_file("$dstFile.sha256", $sha256_expected); + if (! -e "$dstFile.asc") { + system("gpg2 --detach-sign --armor $dstFile") == 0 or die "unable to sign $dstFile\n"; + } + return ($dstFile, $sha256_expected); } downloadFile("tarball", "2"); # .tar.bz2 my ($tarball, $tarballHash) = downloadFile("tarball", "3"); # .tar.xz -my ($tarball_i686_linux, $tarball_i686_linux_hash) = downloadFile("binaryTarball.i686-linux", "1"); -my ($tarball_x86_64_linux, $tarball_x86_64_linux_hash) = downloadFile("binaryTarball.x86_64-linux", "1"); -my ($tarball_aarch64_linux, $tarball_aarch64_linux_hash) = downloadFile("binaryTarball.aarch64-linux", "1"); -my ($tarball_x86_64_darwin, $tarball_x86_64_darwin_hash) = downloadFile("binaryTarball.x86_64-darwin", "1"); +downloadFile("binaryTarball.i686-linux", "1"); +downloadFile("binaryTarball.x86_64-linux", "1"); +downloadFile("binaryTarball.aarch64-linux", "1"); +downloadFile("binaryTarball.x86_64-darwin", "1"); +downloadFile("installerScript", "1"); +exit if $version =~ /pre/; + # Update Nixpkgs in a very hacky way. system("cd $nixpkgsDir && git pull") == 0 or die; my $oldName = `nix-instantiate --eval $nixpkgsDir -A nix.name`; chomp $oldName; @@ -144,17 +151,6 @@ write_file("$siteDir/nix-release.tt", "[%-\n" . "latestNixVersion = \"$version\"\n" . - "nix_hash_i686_linux = \"$tarball_i686_linux_hash\"\n" . - "nix_hash_x86_64_linux = \"$tarball_x86_64_linux_hash\"\n" . - "nix_hash_aarch64_linux = \"$tarball_aarch64_linux_hash\"\n" . - "nix_hash_x86_64_darwin = \"$tarball_x86_64_darwin_hash\"\n" . "-%]\n"); - -system("cd $siteDir && nix-shell --run 'make nix/install nix/install.sig'") == 0 or die; - -copy("$siteDir/nix/install", "$siteDir/nix/install-$version") or die; -copy("$siteDir/nix/install.sig", "$siteDir/nix/install-$version.sig") or die; - -system("cd $siteDir && git add nix/install-$version nix/install-$version.sig") == 0 or die; system("cd $siteDir && git commit -a -m 'Nix $version released'") == 0 or die; diff --git a/data/nix/mk/libraries.mk b/data/nix/mk/libraries.mk --- a/data/nix/mk/libraries.mk +++ b/data/nix/mk/libraries.mk @@ -125,7 +125,7 @@ $(1)_PATH := $$(_d)/$$($(1)_NAME).a $$($(1)_PATH): $$($(1)_OBJS) | $$(_d)/ - $(trace-ar) ar crs $$@ $$? + $(trace-ar) $(AR) crs $$@ $$? $(1)_LDFLAGS_USE += $$($(1)_PATH) $$($(1)_LDFLAGS) diff --git a/data/nix/nix.spec.in b/data/nix/nix.spec.in --- a/data/nix/nix.spec.in +++ b/data/nix/nix.spec.in @@ -3,33 +3,47 @@ %global nixbld_user "nix-builder-" %global nixbld_group "nixbld" +# NOTE: BUILD on EL7 requires +# - Centos / RHEL7 software collection repository +# yum install centos-release-scl +# +# - Recent boost backport +# curl https://copr.fedorainfracloud.org/coprs/whosthere/boost/repo/epel-7/whosthere-boost-epel-7.repo -o /etc/yum.repos.d/whosthere-boost-epel-7.repo +# + +# Disable documentation generation +# necessary on some platforms +%bcond_without docgen + Summary: The Nix software deployment system Name: nix Version: @PACKAGE_VERSION@ Release: 2%{?dist} License: LGPLv2+ -%if 0%{?rhel} && 0%{?rhel} < 7 Group: Applications/System -%endif URL: http://nixos.org/ Source0: %{name}-%{version}.tar.bz2 -%if 0%{?el5} -BuildRoot: %(mktemp -ud %{_tmppath}/%{name}-%{version}-%{release}-XXXXXX) -%endif + Requires: curl Requires: bzip2 Requires: gzip Requires: xz -Requires: libseccomp -Requires: boost-context +BuildRequires: bison +BuildRequires: boost-devel >= 1.60 BuildRequires: bzip2-devel -BuildRequires: sqlite-devel + +# for RHEL <= 7, we need software collections for a C++14 compatible compatible compiler +%if 0%{?rhel} +BuildRequires: devtoolset-7-gcc +BuildRequires: devtoolset-7-gcc-c++ +%endif + +BuildRequires: flex BuildRequires: libcurl-devel BuildRequires: libseccomp-devel -BuildRequires: boost-devel - -# Hack to make that shitty RPM scanning hack shut up. -Provides: perl(Nix::SSH) +BuildRequires: openssl-devel +BuildRequires: sqlite-devel +BuildRequires: xz-devel %description Nix is a purely functional package manager. It allows multiple @@ -41,9 +55,6 @@ %package devel Summary: Development files for %{name} -%if 0%{?rhel} && 0%{?rhel} < 7 -Group: Development/Libraries -%endif Requires: %{name}%{?_isa} = %{version}-%{release} %description devel @@ -53,9 +64,6 @@ %package doc Summary: Documentation files for %{name} -%if 0%{?rhel} && 0%{?rhel} < 7 -Group: Documentation -%endif BuildArch: noarch Requires: %{name} = %{version}-%{release} @@ -67,20 +75,25 @@ %build +%if 0%{?rhel} +source /opt/rh/devtoolset-7/enable +%endif extraFlags= # - override docdir so large documentation files are owned by the # -doc subpackage # - set localstatedir by hand to the preferred nix value %configure --localstatedir=/nix/var \ + %{!?without_docgen:--disable-doc-gen} \ --docdir=%{_defaultdocdir}/%{name}-doc-%{version} \ $extraFlags -make -j$NIX_BUILD_CORES -l$NIX_BUILD_CORES +make V=1 %{?_smp_mflags} %install -%if 0%{?el5} -rm -rf $RPM_BUILD_ROOT +%if 0%{?rhel} +source /opt/rh/devtoolset-7/enable %endif + make DESTDIR=$RPM_BUILD_ROOT install find $RPM_BUILD_ROOT -name '*.la' -exec rm -f {} ';' @@ -130,6 +143,7 @@ %endif %files +%license COPYING %{_bindir}/nix* %{_libdir}/*.so %{_prefix}/libexec/* @@ -138,9 +152,11 @@ %{_prefix}/lib/systemd/system/nix-daemon.service %endif %{_datadir}/nix -%{_mandir}/man1/*.1* -%{_mandir}/man5/*.5* -%{_mandir}/man8/*.8* +#%if ! %{without docgen} +#%{_mandir}/man1/*.1* +#%{_mandir}/man5/*.5* +#%{_mandir}/man8/*.8* +#%endif %config(noreplace) %{_sysconfdir}/profile.d/nix.sh %config(noreplace) %{_sysconfdir}/profile.d/nix-daemon.sh /nix @@ -149,6 +165,9 @@ %{_includedir}/nix %{_prefix}/lib/pkgconfig/*.pc -%files doc -%docdir %{_defaultdocdir}/%{name}-doc-%{version} -%{_defaultdocdir}/%{name}-doc-%{version} + +#%if ! %{without docgen} +#%files doc +#%docdir %{_defaultdocdir}/%{name}-doc-%{version} +#%{_defaultdocdir}/%{name}-doc-%{version} +#%endif diff --git a/data/nix/perl/lib/Nix/Store.xs b/data/nix/perl/lib/Nix/Store.xs --- a/data/nix/perl/lib/Nix/Store.xs +++ b/data/nix/perl/lib/Nix/Store.xs @@ -27,7 +27,7 @@ static std::shared_ptr _store; if (!_store) { try { - settings.loadConfFile(); + loadConfFile(); settings.lockCPU = false; _store = openStore(); } catch (Error & e) { diff --git a/data/nix/release-common.nix b/data/nix/release-common.nix --- a/data/nix/release-common.nix +++ b/data/nix/release-common.nix @@ -30,7 +30,7 @@ }); configureFlags = - [ "--disable-init-state" + [ "--enable-gc" ] ++ lib.optionals stdenv.isLinux [ "--with-sandbox-shell=${sh}/bin/busybox" @@ -49,7 +49,7 @@ buildDeps = [ curl - bzip2 xz brotli + bzip2 xz brotli editline openssl pkgconfig sqlite boehmgc boost @@ -57,13 +57,20 @@ git mercurial ] - ++ lib.optional stdenv.isLinux libseccomp + ++ lib.optionals stdenv.isLinux [libseccomp utillinuxMinimal] ++ lib.optional (stdenv.isLinux || stdenv.isDarwin) libsodium ++ lib.optional (stdenv.isLinux || stdenv.isDarwin) - (aws-sdk-cpp.override { - apis = ["s3"]; + ((aws-sdk-cpp.override { + apis = ["s3" "transfer"]; customMemoryManagement = false; - }); + }).overrideDerivation (args: { + /* + patches = args.patches or [] ++ [ (fetchpatch { + url = https://github.com/edolstra/aws-sdk-cpp/commit/3e07e1f1aae41b4c8b340735ff9e8c735f0c063f.patch; + sha256 = "1pij0v449p166f9l29x7ppzk8j7g9k9mp15ilh5qxp29c7fnvxy2"; + }) ]; + */ + })); perlDeps = [ perl diff --git a/data/nix/release.nix b/data/nix/release.nix --- a/data/nix/release.nix +++ b/data/nix/release.nix @@ -1,5 +1,5 @@ { nix ? builtins.fetchGit ./. -, nixpkgs ? builtins.fetchGit { url = https://github.com/NixOS/nixpkgs-channels.git; ref = "nixos-18.03"; } +, nixpkgs ? builtins.fetchGit { url = https://github.com/NixOS/nixpkgs-channels.git; ref = "nixos-18.09"; } , officialRelease ? false , systems ? [ "x86_64-linux" "i686-linux" "x86_64-darwin" "aarch64-linux" ] }: @@ -67,6 +67,14 @@ buildInputs = buildDeps; + preConfigure = + # Copy libboost_context so we don't get all of Boost in our closure. + # https://github.com/NixOS/nixpkgs/issues/45462 + '' + mkdir -p $out/lib + cp ${boost}/lib/libboost_context* $out/lib + ''; + configureFlags = configureFlags ++ [ "--sysconfdir=/etc" ]; @@ -74,8 +82,6 @@ makeFlags = "profiledir=$(out)/etc/profile.d"; - preBuild = "unset NIX_INDENT_MAKE"; - installFlags = "sysconfdir=$(out)/etc"; doInstallCheck = true; @@ -103,8 +109,6 @@ enableParallelBuilding = true; postUnpack = "sourceRoot=$sourceRoot/perl"; - - preBuild = "unset NIX_INDENT_MAKE"; }); @@ -189,10 +193,6 @@ buildInputs = buildDeps; - configureFlags = '' - --disable-init-state - ''; - dontInstall = false; doInstallCheck = true; @@ -206,14 +206,14 @@ }; - rpm_fedora27x86_64 = makeRPM_x86_64 (diskImageFunsFun: diskImageFunsFun.fedora27x86_64) [ ]; + #rpm_fedora27x86_64 = makeRPM_x86_64 (diskImageFunsFun: diskImageFunsFun.fedora27x86_64) [ ]; #deb_debian8i386 = makeDeb_i686 (diskImageFuns: diskImageFuns.debian8i386) [ "libsodium-dev" ] [ "libsodium13" ]; #deb_debian8x86_64 = makeDeb_x86_64 (diskImageFunsFun: diskImageFunsFun.debian8x86_64) [ "libsodium-dev" ] [ "libsodium13" ]; - deb_ubuntu1710i386 = makeDeb_i686 (diskImageFuns: diskImageFuns.ubuntu1710i386) [ ] [ "libsodium18" ]; - deb_ubuntu1710x86_64 = makeDeb_x86_64 (diskImageFuns: diskImageFuns.ubuntu1710x86_64) [ ] [ "libsodium18" "libboost-context1.62.0" ]; + #deb_ubuntu1710i386 = makeDeb_i686 (diskImageFuns: diskImageFuns.ubuntu1710i386) [ ] [ "libsodium18" ]; + #deb_ubuntu1710x86_64 = makeDeb_x86_64 (diskImageFuns: diskImageFuns.ubuntu1710x86_64) [ ] [ "libsodium18" "libboost-context1.62.0" ]; # System tests. @@ -241,6 +241,7 @@ { diskImage = vmTools.diskImages.ubuntu1204x86_64; } '' + set -x useradd -m alice su - alice -c 'tar xf ${binaryTarball.x86_64-linux}/*.tar.*' mkdir /dest-nix @@ -249,6 +250,17 @@ su - alice -c '_NIX_INSTALLER_TEST=1 ./nix-*/install' su - alice -c 'nix-store --verify' su - alice -c 'PAGER= nix-store -qR ${build.x86_64-linux}' + + # Check whether 'nix upgrade-nix' works. + cat > /tmp/paths.nix <> $out/nix-support/hydra-build-products + ''; + + # Aggregate job containing the release-critical jobs. release = pkgs.releaseTools.aggregate { name = "nix-${tarball.version}"; @@ -284,14 +313,17 @@ build.i686-linux build.x86_64-darwin build.x86_64-linux + build.aarch64-linux binaryTarball.i686-linux binaryTarball.x86_64-darwin binaryTarball.x86_64-linux + binaryTarball.aarch64-linux tests.remoteBuilds tests.nix-copy-closure tests.binaryTarball tests.evalNixpkgs tests.evalNixOS + installerScript ]; }; @@ -311,7 +343,7 @@ src = jobs.tarball; diskImage = (diskImageFun vmTools.diskImageFuns) { extraPackages = - [ "sqlite" "sqlite-devel" "bzip2-devel" "libcurl-devel" "openssl-devel" "xz-devel" "libseccomp-devel" "libsodium-devel" "boost-devel" ] + [ "sqlite" "sqlite-devel" "bzip2-devel" "libcurl-devel" "openssl-devel" "xz-devel" "libseccomp-devel" "libsodium-devel" "boost-devel" "bison" "flex" ] ++ extraPackages; }; # At most 2047MB can be simulated in qemu-system-i386 memSize = 2047; diff --git a/data/nix/scripts/install-multi-user.sh b/data/nix/scripts/install-multi-user.sh --- a/data/nix/scripts/install-multi-user.sh +++ b/data/nix/scripts/install-multi-user.sh @@ -674,9 +674,6 @@ EOF fi - _sudo "to initialize the Nix Database" \ - $NIX_INSTALLED_NIX/bin/nix-store --init - cat ./.reginfo \ | _sudo "to load data for the first time in to the Nix Database" \ "$NIX_INSTALLED_NIX/bin/nix-store" --load-db @@ -727,11 +724,17 @@ _sudo "to installing a bootstrapping Nix in to the default Profile" \ HOME="$ROOT_HOME" "$NIX_INSTALLED_NIX/bin/nix-env" -i "$NIX_INSTALLED_NIX" - _sudo "to installing a bootstrapping SSL certificate just for Nix in to the default Profile" \ - HOME="$ROOT_HOME" "$NIX_INSTALLED_NIX/bin/nix-env" -i "$NIX_INSTALLED_CACERT" + if [ -z "${NIX_SSL_CERT_FILE:-}" ] || ! [ -f "${NIX_SSL_CERT_FILE:-}" ]; then + _sudo "to installing a bootstrapping SSL certificate just for Nix in to the default Profile" \ + HOME="$ROOT_HOME" "$NIX_INSTALLED_NIX/bin/nix-env" -i "$NIX_INSTALLED_CACERT" + export NIX_SSL_CERT_FILE=/nix/var/nix/profiles/default/etc/ssl/certs/ca-bundle.crt + fi + # Have to explicitly pass NIX_SSL_CERT_FILE as part of the sudo call, + # otherwise it will be lost in environments where sudo doesn't pass + # all the environment variables by default. _sudo "to update the default channel in the default profile" \ - HOME="$ROOT_HOME" NIX_SSL_CERT_FILE=/nix/var/nix/profiles/default/etc/ssl/certs/ca-bundle.crt "$NIX_INSTALLED_NIX/bin/nix-channel" --update nixpkgs + HOME="$ROOT_HOME" NIX_SSL_CERT_FILE="$NIX_SSL_CERT_FILE" "$NIX_INSTALLED_NIX/bin/nix-channel" --update nixpkgs } diff --git a/data/nix/scripts/install-nix-from-closure.sh b/data/nix/scripts/install-nix-from-closure.sh --- a/data/nix/scripts/install-nix-from-closure.sh +++ b/data/nix/scripts/install-nix-from-closure.sh @@ -30,15 +30,14 @@ fi fi -# Determine if we should punt to the single-user installer or not +# Determine if we could use the multi-user installer or not if [ "$(uname -s)" = "Darwin" ]; then - INSTALL_MODE=daemon + echo "Note: a multi-user installation is possible. See https://nixos.org/nix/manual/#sect-multi-user-installation" >&2 elif [ "$(uname -s)" = "Linux" ] && [ -e /run/systemd/system ]; then - INSTALL_MODE=daemon -else - INSTALL_MODE=no-daemon + echo "Note: a multi-user installation is possible. See https://nixos.org/nix/manual/#sect-multi-user-installation" >&2 fi +INSTALL_MODE=no-daemon # Trivially handle the --daemon / --no-daemon options if [ "x${1:-}" = "x--no-daemon" ]; then INSTALL_MODE=no-daemon @@ -47,14 +46,18 @@ elif [ "x${1:-}" != "x" ]; then ( echo "Nix Installer [--daemon|--no-daemon]" + + echo "Choose installation method." echo "" - echo " --daemon: Force the installer to use the Daemon" - echo " based installer, even though it may not" - echo " work." + echo " --daemon: Installs and configures a background daemon that manages the store," + echo " providing multi-user support and better isolation for local builds." + echo " Both for security and reproducibility, this method is recommended if" + echo " supported on your platform." + echo " See https://nixos.org/nix/manual/#sect-multi-user-installation" echo "" - echo " --no-daemon: Force a no-daemon, single-user" - echo " installation even when the preferred" - echo " method is with the daemon." + echo " --no-daemon: Simple, single-user installation that does not require root and is" + echo " trivial to uninstall." + echo " (default)" echo "" ) >&2 exit @@ -105,12 +108,6 @@ fi done echo "" >&2 - -echo "initialising Nix database..." >&2 -if ! $nix/bin/nix-store --init; then - echo "$0: failed to initialize the Nix database" >&2 - exit 1 -fi if ! "$nix/bin/nix-store" --load-db < "$self/.reginfo"; then echo "$0: unable to register valid paths" >&2 diff --git a/data/nix/scripts/nix-profile-daemon.sh.in b/data/nix/scripts/nix-profile-daemon.sh.in --- a/data/nix/scripts/nix-profile-daemon.sh.in +++ b/data/nix/scripts/nix-profile-daemon.sh.in @@ -1,5 +1,5 @@ # Only execute this file once per shell. -if [ -n "$__ETC_PROFILE_NIX_SOURCED" ]; then return; fi +if [ -n "${__ETC_PROFILE_NIX_SOURCED:-}" ]; then return; fi __ETC_PROFILE_NIX_SOURCED=1 # Set up secure multi-user builds: non-root users build through the @@ -49,6 +49,26 @@ fi fi -export NIX_SSL_CERT_FILE="@localstatedir@/nix/profiles/default/etc/ssl/certs/ca-bundle.crt" -export NIX_PATH="@localstatedir@/nix/profiles/per-user/root/channels" -export PATH="$HOME/.nix-profile/bin:$HOME/.nix-profile/lib/kde4/libexec:@localstatedir@/nix/profiles/default/bin:@localstatedir@/nix/profiles/default:@localstatedir@/nix/profiles/default/lib/kde4/libexec:$PATH" + +# Set $NIX_SSL_CERT_FILE so that Nixpkgs applications like curl work. +if [ ! -z "${NIX_SSL_CERT_FILE:-}" ]; then + : # Allow users to override the NIX_SSL_CERT_FILE +elif [ -e /etc/ssl/certs/ca-certificates.crt ]; then # NixOS, Ubuntu, Debian, Gentoo, Arch + export NIX_SSL_CERT_FILE=/etc/ssl/certs/ca-certificates.crt +elif [ -e /etc/ssl/ca-bundle.pem ]; then # openSUSE Tumbleweed + export NIX_SSL_CERT_FILE=/etc/ssl/ca-bundle.pem +elif [ -e /etc/ssl/certs/ca-bundle.crt ]; then # Old NixOS + export NIX_SSL_CERT_FILE=/etc/ssl/certs/ca-bundle.crt +elif [ -e /etc/pki/tls/certs/ca-bundle.crt ]; then # Fedora, CentOS + export NIX_SSL_CERT_FILE=/etc/pki/tls/certs/ca-bundle.crt +else + # Fall back to what is in the nix profiles, favouring whatever is defined last. + for i in $NIX_PROFILES; do + if [ -e $i/etc/ssl/certs/ca-bundle.crt ]; then + export NIX_SSL_CERT_FILE=$i/etc/ssl/certs/ca-bundle.crt + fi + done +fi + +export NIX_PATH="nixpkgs=@localstatedir@/nix/profiles/per-user/root/channels/nixpkgs:@localstatedir@/nix/profiles/per-user/root/channels" +export PATH="$HOME/.nix-profile/bin:@localstatedir@/nix/profiles/default/bin:$PATH" diff --git a/data/nix/scripts/nix-profile.sh.in b/data/nix/scripts/nix-profile.sh.in --- a/data/nix/scripts/nix-profile.sh.in +++ b/data/nix/scripts/nix-profile.sh.in @@ -75,7 +75,7 @@ export NIX_SSL_CERT_FILE="$NIX_LINK/etc/ca-bundle.crt" fi - if [ -n "${MANPATH}" ]; then + if [ -n "${MANPATH-}" ]; then export MANPATH="$NIX_LINK/share/man:$MANPATH" fi diff --git a/data/nix/shell.nix b/data/nix/shell.nix --- a/data/nix/shell.nix +++ b/data/nix/shell.nix @@ -1,6 +1,6 @@ { useClang ? false }: -with import (builtins.fetchGit { url = https://github.com/NixOS/nixpkgs-channels.git; ref = "nixos-18.03"; }) {}; +with import (builtins.fetchGit { url = https://github.com/NixOS/nixpkgs-channels.git; ref = "nixos-18.09"; }) {}; with import ./release-common.nix { inherit pkgs; }; diff --git a/data/nix/tests/binary-cache.sh b/data/nix/tests/binary-cache.sh --- a/data/nix/tests/binary-cache.sh +++ b/data/nix/tests/binary-cache.sh @@ -52,9 +52,6 @@ basicTests -unset _NIX_FORCE_HTTP_BINARY_CACHE_STORE - - # Test whether Nix notices if the NAR doesn't match the hash in the NAR info. clearStore @@ -79,20 +76,31 @@ fi -# Test whether fallback works if we have cached info but the -# corresponding NAR has disappeared. +# Test whether fallback works if a NAR has disappeared. This does not require --fallback. clearStore -nix-build --substituters "file://$cacheDir" dependencies.nix --dry-run # get info +mv $cacheDir/nar $cacheDir/nar2 -mkdir $cacheDir/tmp -mv $cacheDir/*.nar* $cacheDir/tmp/ +nix-build --substituters "file://$cacheDir" --no-require-sigs dependencies.nix -o $TEST_ROOT/result -NIX_DEBUG_SUBST=1 nix-build --substituters "file://$cacheDir" dependencies.nix -o $TEST_ROOT/result --fallback +mv $cacheDir/nar2 $cacheDir/nar -mv $cacheDir/tmp/* $cacheDir/ +# Test whether fallback works if a NAR is corrupted. This does require --fallback. +clearStore +mv $cacheDir/nar $cacheDir/nar2 +mkdir $cacheDir/nar +for i in $(cd $cacheDir/nar2 && echo *); do touch $cacheDir/nar/$i; done + +(! nix-build --substituters "file://$cacheDir" --no-require-sigs dependencies.nix -o $TEST_ROOT/result) + +nix-build --substituters "file://$cacheDir" --no-require-sigs dependencies.nix -o $TEST_ROOT/result --fallback + +rm -rf $cacheDir/nar +mv $cacheDir/nar2 $cacheDir/nar + + # Test whether building works if the binary cache contains an # incomplete closure. clearStore @@ -107,6 +115,7 @@ # Create a signed binary cache. clearCache +clearCacheCache declare -a res=($(nix-store --generate-binary-cache-key test.nixos.org-1 $TEST_ROOT/sk1 $TEST_ROOT/pk1 )) publicKey="$(cat $TEST_ROOT/pk1)" @@ -117,7 +126,7 @@ res=($(nix-store --generate-binary-cache-key foo.nixos.org-1 $TEST_ROOT/sk3 $TEST_ROOT/pk3)) otherKey="$(cat $TEST_ROOT/pk3)" -nix copy --to file://$cacheDir?secret-key=$TEST_ROOT/sk1 $outPath +_NIX_FORCE_HTTP_BINARY_CACHE_STORE= nix copy --to file://$cacheDir?secret-key=$TEST_ROOT/sk1 $outPath # Downloading should fail if we don't provide a key. diff --git a/data/nix/tests/brotli.sh b/data/nix/tests/brotli.sh --- a/data/nix/tests/brotli.sh +++ b/data/nix/tests/brotli.sh @@ -1,10 +1,5 @@ source common.sh - -# Only test if we found brotli libraries -# (CLI tool is likely unavailable if libraries are missing) -if [ -n "$HAVE_BROTLI" ]; then - clearStore clearCache @@ -24,5 +19,3 @@ HASH2=$(nix hash-path $outPath) [[ $HASH = $HASH2 ]] - -fi # HAVE_BROTLI diff --git a/data/nix/tests/build-remote.sh b/data/nix/tests/build-remote.sh --- a/data/nix/tests/build-remote.sh +++ b/data/nix/tests/build-remote.sh @@ -11,7 +11,8 @@ nix build -f build-hook.nix -o $TEST_ROOT/result --max-jobs 0 \ --sandbox-paths /nix/store --sandbox-build-dir /build-tmp \ - --builders "$TEST_ROOT/store0; $TEST_ROOT/store1 - - 1 1 foo" + --builders "$TEST_ROOT/store0; $TEST_ROOT/store1 - - 1 1 foo" \ + --system-features foo outPath=$TEST_ROOT/result diff --git a/data/nix/tests/check-refs.sh b/data/nix/tests/check-refs.sh --- a/data/nix/tests/check-refs.sh +++ b/data/nix/tests/check-refs.sh @@ -1,5 +1,7 @@ source common.sh +clearStore + RESULT=$TEST_ROOT/result dep=$(nix-build -o $RESULT check-refs.nix -A dep) diff --git a/data/nix/tests/check-reqs.sh b/data/nix/tests/check-reqs.sh --- a/data/nix/tests/check-reqs.sh +++ b/data/nix/tests/check-reqs.sh @@ -1,5 +1,7 @@ source common.sh +clearStore + RESULT=$TEST_ROOT/result nix-build -o $RESULT check-reqs.nix -A test1 diff --git a/data/nix/tests/common.sh.in b/data/nix/tests/common.sh.in --- a/data/nix/tests/common.sh.in +++ b/data/nix/tests/common.sh.in @@ -31,7 +31,6 @@ export SHELL="@bash@" export PAGER=cat export HAVE_SODIUM="@HAVE_SODIUM@" -export HAVE_BROTLI="@HAVE_BROTLI@" export version=@PACKAGE_VERSION@ export system=@system@ @@ -86,19 +85,14 @@ trap "" EXIT } -canUseSandbox() { - if [[ $(uname) != Linux ]]; then return 1; fi +if [[ $(uname) == Linux ]] && [[ -L /proc/self/ns/user ]] && unshare --user true; then + _canUseSandbox=1 +fi - if [ ! -L /proc/self/ns/user ]; then - echo "Kernel doesn't support user namespaces, skipping this test..." +canUseSandbox() { + if [[ ! $_canUseSandbox ]]; then + echo "Sandboxing not supported, skipping this test..." return 1 - fi - - if [ -e /proc/sys/kernel/unprivileged_userns_clone ]; then - if [ "$(cat /proc/sys/kernel/unprivileged_userns_clone)" != 1 ]; then - echo "Unprivileged user namespaces disabled by sysctl, skipping this test..." - return 1 - fi fi return 0 diff --git a/data/nix/tests/fetchGit.sh b/data/nix/tests/fetchGit.sh --- a/data/nix/tests/fetchGit.sh +++ b/data/nix/tests/fetchGit.sh @@ -9,7 +9,7 @@ repo=$TEST_ROOT/git -rm -rf $repo ${repo}-tmp $TEST_HOME/.cache/nix/git +rm -rf $repo ${repo}-tmp $TEST_HOME/.cache/nix/gitv2 git init $repo git -C $repo config user.email "foobar@example.com" @@ -129,7 +129,7 @@ # Nuke the cache -rm -rf $TEST_HOME/.cache/nix/git +rm -rf $TEST_HOME/.cache/nix/gitv2 # Try again, but without 'git' on PATH NIX=$(command -v nix) diff --git a/data/nix/tests/fetchurl.sh b/data/nix/tests/fetchurl.sh --- a/data/nix/tests/fetchurl.sh +++ b/data/nix/tests/fetchurl.sh @@ -18,6 +18,17 @@ cmp $outPath fetchurl.sh +# Now using an SRI hash. +clearStore + +hash=$(nix hash-file ./fetchurl.sh) + +[[ $hash =~ ^sha256- ]] + +outPath=$(nix-build '' --argstr url file://$(pwd)/fetchurl.sh --argstr hash $hash --no-out-link --hashed-mirrors '') + +cmp $outPath fetchurl.sh + # Test the hashed mirror feature. clearStore diff --git a/data/nix/tests/hash.sh b/data/nix/tests/hash.sh --- a/data/nix/tests/hash.sh +++ b/data/nix/tests/hash.sh @@ -2,7 +2,7 @@ try () { printf "%s" "$2" > $TEST_ROOT/vector - hash=$(nix-hash $EXTRA --flat --type "$1" $TEST_ROOT/vector) + hash=$(nix hash-file --base16 $EXTRA --type "$1" $TEST_ROOT/vector) if test "$hash" != "$3"; then echo "hash $1, expected $3, got $hash" exit 1 @@ -33,6 +33,12 @@ try sha256 "abc" "1b8m03r63zqhnjf7l5wnldhh7c134ap5vpj0850ymkq1iyzicy5s" EXTRA= +EXTRA=--sri +try sha512 "" "sha512-z4PhNX7vuL3xVChQ1m2AB9Yg5AULVxXcg/SpIdNs6c5H0NE8XYXysP+DGNKHfuwvY7kxvUdBeoGlODJ6+SfaPg==" +try sha512 "abc" "sha512-3a81oZNherrMQXNJriBBMRLm+k6JqX6iCp7u5ktV05ohkpkqJ0/BqDa6PCOj/uu9RU1EI2Q86A4qmslPpUyknw==" +try sha512 "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" "sha512-IEqPxt2oLwoM7XvrjgikFlfBbvRosiioJ5vjMacDwzWW/RXBOxsH+aodO+pXeJygMa2Fx6cd1wNU7GMSOMo0RQ==" +try sha256 "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" "sha256-JI1qYdIGOLjlwCaTDD5gOaM85Flk/yFn9uzt1BnbBsE=" + try2 () { hash=$(nix-hash --type "$1" $TEST_ROOT/hash-path) if test "$hash" != "$2"; then @@ -65,11 +71,15 @@ try3() { h64=$(nix to-base64 --type "$1" "$2") [ "$h64" = "$4" ] + sri=$(nix to-sri --type "$1" "$2") + [ "$sri" = "$1-$4" ] h32=$(nix-hash --type "$1" --to-base32 "$2") [ "$h32" = "$3" ] h16=$(nix-hash --type "$1" --to-base16 "$h32") [ "$h16" = "$2" ] h16=$(nix to-base16 --type "$1" "$h64") + [ "$h16" = "$2" ] + h16=$(nix to-base16 "$sri") [ "$h16" = "$2" ] } try3 sha1 "800d59cfcd3c05e900cb4e214be48f6b886a08df" "vw46m23bizj4n8afrc0fj19wrp7mj3c0" "gA1Zz808BekAy04hS+SPa4hqCN8=" diff --git a/data/nix/tests/init.sh b/data/nix/tests/init.sh --- a/data/nix/tests/init.sh +++ b/data/nix/tests/init.sh @@ -16,6 +16,7 @@ cat > "$NIX_CONF_DIR"/nix.conf < settingSet{false, "setting-set", +struct MySettings : Config +{ + Setting settingSet{this, false, "setting-set", "Whether the plugin-defined setting was set"}; +}; -static RegisterSetting rs(&settingSet); +MySettings mySettings; +static GlobalConfig::Register rs(&mySettings); + static void prim_anotherNull (EvalState & state, const Pos & pos, Value ** args, Value & v) { - if (settingSet) + if (mySettings.settingSet) mkNull(v); else mkBool(v, false); diff --git a/data/nix/tests/remote-builds.nix b/data/nix/tests/remote-builds.nix --- a/data/nix/tests/remote-builds.nix +++ b/data/nix/tests/remote-builds.nix @@ -8,8 +8,8 @@ let - # The configuration of the build slaves. - slave = + # The configuration of the remote builders. + builder = { config, pkgs, ... }: { services.openssh.enable = true; virtualisation.writableStore = true; @@ -36,21 +36,21 @@ { nodes = - { slave1 = slave; - slave2 = slave; + { builder1 = builder; + builder2 = builder; client = { config, pkgs, ... }: { nix.maxJobs = 0; # force remote building nix.distributedBuilds = true; nix.buildMachines = - [ { hostName = "slave1"; + [ { hostName = "builder1"; sshUser = "root"; sshKey = "/root/.ssh/id_ed25519"; system = "i686-linux"; maxJobs = 1; } - { hostName = "slave2"; + { hostName = "builder2"; sshUser = "root"; sshKey = "/root/.ssh/id_ed25519"; system = "i686-linux"; @@ -75,33 +75,33 @@ $client->copyFileFromHost("key", "/root/.ssh/id_ed25519"); $client->succeed("chmod 600 /root/.ssh/id_ed25519"); - # Install the SSH key on the slaves. + # Install the SSH key on the builders. $client->waitForUnit("network.target"); - foreach my $slave ($slave1, $slave2) { - $slave->succeed("mkdir -p -m 700 /root/.ssh"); - $slave->copyFileFromHost("key.pub", "/root/.ssh/authorized_keys"); - $slave->waitForUnit("sshd"); - $client->succeed("ssh -o StrictHostKeyChecking=no " . $slave->name() . " 'echo hello world'"); + foreach my $builder ($builder1, $builder2) { + $builder->succeed("mkdir -p -m 700 /root/.ssh"); + $builder->copyFileFromHost("key.pub", "/root/.ssh/authorized_keys"); + $builder->waitForUnit("sshd"); + $client->succeed("ssh -o StrictHostKeyChecking=no " . $builder->name() . " 'echo hello world'"); } - # Perform a build and check that it was performed on the slave. + # Perform a build and check that it was performed on the builder. my $out = $client->succeed( "nix-build ${expr nodes.client.config 1} 2> build-output", "grep -q Hello build-output" ); - $slave1->succeed("test -e $out"); + $builder1->succeed("test -e $out"); # And a parallel build. my ($out1, $out2) = split /\s/, $client->succeed('nix-store -r $(nix-instantiate ${expr nodes.client.config 2})\!out $(nix-instantiate ${expr nodes.client.config 3})\!out'); - $slave1->succeed("test -e $out1 -o -e $out2"); - $slave2->succeed("test -e $out1 -o -e $out2"); + $builder1->succeed("test -e $out1 -o -e $out2"); + $builder2->succeed("test -e $out1 -o -e $out2"); # And a failing build. $client->fail("nix-build ${expr nodes.client.config 5}"); - # Test whether the build hook automatically skips unavailable slaves. - $slave1->block; + # Test whether the build hook automatically skips unavailable builders. + $builder1->block; $client->succeed("nix-build ${expr nodes.client.config 4}"); ''; diff --git a/data/nix/tests/restricted.sh b/data/nix/tests/restricted.sh --- a/data/nix/tests/restricted.sh +++ b/data/nix/tests/restricted.sh @@ -38,3 +38,14 @@ nix-instantiate --eval --restrict-eval $TEST_ROOT/restricted.nix -I $TEST_ROOT -I . [[ $(nix eval --raw --restrict-eval -I . '(builtins.readFile "${import ./simple.nix}/hello")') == 'Hello World!' ]] + +# Check whether we can leak symlink information through directory traversal. +traverseDir="$(pwd)/restricted-traverse-me" +ln -sfn "$(pwd)/restricted-secret" "$(pwd)/restricted-innocent" +mkdir -p "$traverseDir" +goUp="..$(echo "$traverseDir" | sed -e 's,[^/]\+,..,g')" +output="$(nix eval --raw --restrict-eval -I "$traverseDir" \ + "(builtins.readFile \"$traverseDir/$goUp$(pwd)/restricted-innocent\")" \ + 2>&1 || :)" +echo "$output" | grep "is forbidden" +! echo "$output" | grep -F restricted-secret diff --git a/data/nix/tests/search.sh b/data/nix/tests/search.sh --- a/data/nix/tests/search.sh +++ b/data/nix/tests/search.sh @@ -30,7 +30,7 @@ (( $(nix search nosuchpackageexists | wc -l) == 0 )) # Search for multiple arguments -(( $(nix search hello empty | wc -l) == 5 )) +(( $(nix search hello empty | wc -l) == 3 )) # Multiple arguments will not exist (( $(nix search hello broken | wc -l) == 0 )) diff --git a/data/nix/tests/signing.sh b/data/nix/tests/signing.sh --- a/data/nix/tests/signing.sh +++ b/data/nix/tests/signing.sh @@ -62,6 +62,10 @@ nix verify $outPathCA nix verify $outPathCA --sigs-needed 1000 +# Check that signing a content-addressed path doesn't overflow validSigs +nix sign-paths --key-file $TEST_ROOT/sk1 $outPathCA +nix verify -r $outPathCA --sigs-needed 1000 --trusted-public-keys $pk1 + # Copy to a binary cache. nix copy --to file://$cacheDir $outPath2 diff --git a/data/nix/version b/data/nix/version --- a/data/nix/version +++ b/data/nix/version @@ -1,1 +1,1 @@ -2.1 +2.3 diff --git a/hnix.cabal b/hnix.cabal --- a/hnix.cabal +++ b/hnix.cabal @@ -1,11 +1,5 @@ --- This file has been generated from package.yaml by hpack version 0.27.0. --- --- see: https://github.com/sol/hpack --- --- hash: ba0f61f8a049f6970ff03fd924cfed6fc1251eceb90547c1be8051226c453632 - name: hnix -version: 0.5.2 +version: 0.6.0 synopsis: Haskell implementation of the Nix language description: Haskell implementation of the Nix language. category: System, Data, Nix @@ -17,7 +11,6 @@ license-file: LICENSE build-type: Simple cabal-version: >= 1.10 - extra-source-files: data/let-comments-multiline.nix data/let-comments.nix @@ -401,12 +394,12 @@ data/simple-pretty.nix data/simple.nix LICENSE - package.yaml README.md tests/eval-compare/builtins.split-01.nix tests/eval-compare/builtins.split-02.nix tests/eval-compare/builtins.split-03.nix tests/eval-compare/builtins.split-04.nix + tests/eval-compare/builtins.string.store.nix tests/eval-compare/ind-string-01.nix tests/eval-compare/ind-string-02.nix tests/eval-compare/ind-string-03.nix @@ -439,17 +432,14 @@ manual: True default: False -flag tracing - description: Enable full debug tracing - manual: True - default: False - library exposed-modules: Nix Nix.Atoms Nix.Builtins Nix.Cache + Nix.Cited + Nix.Cited.Basic Nix.Context Nix.Convert Nix.Effects @@ -460,6 +450,9 @@ Nix.Expr.Types Nix.Expr.Types.Annotated Nix.Frames + Nix.Fresh + Nix.Fresh.Basic + Nix.Json Nix.Lint Nix.Normal Nix.Options @@ -469,15 +462,20 @@ Nix.Render Nix.Render.Frame Nix.Scope + Nix.String Nix.Strings Nix.TH Nix.Thunk + Nix.Thunk.Basic + Nix.Thunk.Standard Nix.Type.Assumption Nix.Type.Env Nix.Type.Infer Nix.Type.Type Nix.Utils Nix.Value + Nix.Value.Equal + Nix.Var Nix.XML other-modules: Paths_hnix @@ -486,30 +484,37 @@ ghc-options: -Wall build-depends: aeson - , ansi-wl-pprint , array >=0.4 && <0.6 , base >=4.9 && <5 , binary , bytestring + , comonad , containers , data-fix , deepseq >=1.4.2 && <1.5 + , dependent-sum , deriving-compat >=0.3 && <0.6 , directory , exceptions , filepath + , free , hashing + , hnix-store-core , http-client , http-client-tls , http-types , interpolate , lens-family-th , logict - , megaparsec >=6.5 && <7.0 + , megaparsec >=7.0 && <7.1 + , monad-control , monadlist , mtl , optparse-applicative + , parser-combinators + , prettyprinter , process + , ref-tf , regex-tdfa , regex-tdfa-text , scientific @@ -521,14 +526,13 @@ , these , time , transformers + , transformers-base , unix , unordered-containers >=0.2.9 && <0.3 , vector , xml if flag(optimize) ghc-options: -fexpose-all-unfoldings -fspecialise-aggressively -O2 - if flag(tracing) - cpp-options: -DENABLE_TRACING=1 if os(linux) && impl(ghc >= 8.2) && impl(ghc < 8.3) build-depends: compact @@ -548,9 +552,9 @@ build-depends: lens-family >=1.2.2 , lens-family-core >=1.2.2 - if impl(ghc < 8.4.0) && !flag(profiling) - build-depends: - ghc-datasize + -- if impl(ghc < 8.4.0) && !flag(profiling) + -- build-depends: + -- ghc-datasize if impl(ghcjs) build-depends: hashable >=1.2.4 && <1.3 @@ -570,12 +574,12 @@ Paths_hnix hs-source-dirs: main - ghc-options: -Wall + ghc-options: -Wall -rtsopts build-depends: aeson - , ansi-wl-pprint , base >=4.9 && <5 , bytestring + , comonad , containers , data-fix , deepseq >=1.4.2 && <1.5 @@ -587,6 +591,8 @@ , mtl , optparse-applicative , pretty-show + , prettyprinter + , ref-tf , repline , template-haskell , text @@ -595,8 +601,6 @@ , unordered-containers >=0.2.9 && <0.3 if flag(optimize) ghc-options: -fexpose-all-unfoldings -fspecialise-aggressively -O2 - if flag(tracing) - cpp-options: -DENABLE_TRACING=1 if os(linux) && impl(ghc >= 8.2) && impl(ghc < 8.3) build-depends: compact @@ -632,12 +636,12 @@ build-depends: Diff , Glob - , ansi-wl-pprint , base >=4.9 && <5 , bytestring , containers , data-fix , deepseq >=1.4.2 && <1.5 + , dependent-sum , directory , exceptions , filepath @@ -646,10 +650,11 @@ , hedgehog , hnix , interpolate - , megaparsec + , megaparsec >=7.0 && <7.1 , mtl , optparse-applicative , pretty-show + , prettyprinter , process , split , tasty @@ -665,8 +670,6 @@ , unordered-containers >=0.2.9 && <0.3 if flag(optimize) ghc-options: -fexpose-all-unfoldings -fspecialise-aggressively -O2 - if flag(tracing) - cpp-options: -DENABLE_TRACING=1 if os(linux) && impl(ghc >= 8.2) && impl(ghc < 8.3) build-depends: compact @@ -683,7 +686,6 @@ else buildable: True default-language: Haskell2010 - build-tool-depends: hspec-discover:hspec-discover == 2.* benchmark hnix-benchmarks type: exitcode-stdio-1.0 @@ -695,8 +697,7 @@ benchmarks ghc-options: -Wall build-depends: - ansi-wl-pprint - , base >=4.9 && <5 + base >=4.9 && <5 , bytestring , containers , criterion @@ -715,8 +716,6 @@ , unordered-containers >=0.2.9 && <0.3 if flag(optimize) ghc-options: -fexpose-all-unfoldings -fspecialise-aggressively -O2 - if flag(tracing) - cpp-options: -DENABLE_TRACING=1 if os(linux) && impl(ghc >= 8.2) && impl(ghc < 8.3) build-depends: compact diff --git a/main/Main.hs b/main/Main.hs --- a/main/Main.hs +++ b/main/Main.hs @@ -4,218 +4,223 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module Main where -import qualified Control.DeepSeq as Deep -import qualified Control.Exception as Exc +import Control.Comonad ( extract ) +import qualified Control.DeepSeq as Deep +import qualified Control.Exception as Exc import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class -- import Control.Monad.ST -import qualified Data.Aeson.Encoding as A -import qualified Data.Aeson.Text as A -import qualified Data.HashMap.Lazy as M -import qualified Data.Map as Map -import Data.List (sortOn) -import Data.Maybe (fromJust) +import qualified Data.Aeson.Text as A +import qualified Data.HashMap.Lazy as M +import qualified Data.Map as Map +import Data.List ( sortOn ) +import Data.Maybe ( fromJust ) import Data.Time -import qualified Data.Text as Text -import qualified Data.Text.IO as Text -import qualified Data.Text.Lazy.Encoding as TL -import qualified Data.Text.Lazy.IO as TL +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import qualified Data.Text.Lazy.IO as TL +import Data.Text.Prettyprint.Doc +import Data.Text.Prettyprint.Doc.Render.Text import Nix import Nix.Convert -import qualified Nix.Eval as Eval +import qualified Nix.Eval as Eval +import Nix.Json -- import Nix.Lint import Nix.Options.Parser -import qualified Nix.Type.Env as Env -import qualified Nix.Type.Infer as HM +import Nix.Thunk.Basic +import Nix.Thunk.Standard +import qualified Nix.Type.Env as Env +import qualified Nix.Type.Infer as HM import Nix.Utils -import Options.Applicative hiding (ParserResult(..)) +import Nix.Var +import Options.Applicative hiding ( ParserResult(..) ) import qualified Repl import System.FilePath import System.IO -import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) -import qualified Text.Show.Pretty as PS +import qualified Text.Show.Pretty as PS main :: IO () main = do - time <- liftIO getCurrentTime - opts <- execParser (nixOptionsInfo time) - runLazyM opts $ case readFrom opts of - Just path -> do - let file = addExtension (dropExtension path) "nix" - process opts (Just file) =<< liftIO (readCache path) - Nothing -> case expression opts of - Just s -> handleResult opts Nothing (parseNixTextLoc s) - Nothing -> case fromFile opts of - Just "-" -> - mapM_ (processFile opts) - =<< (lines <$> liftIO getContents) - Just path -> - mapM_ (processFile opts) - =<< (lines <$> liftIO (readFile path)) - Nothing -> case filePaths opts of - [] -> Repl.shell (pure ()) - ["-"] -> - handleResult opts Nothing . parseNixTextLoc - =<< liftIO Text.getContents - paths -> - mapM_ (processFile opts) paths - where - processFile opts path = do - eres <- parseNixFileLoc path - handleResult opts (Just path) eres - - handleResult opts mpath = \case - Failure err -> - (if ignoreErrors opts - then liftIO . hPutStrLn stderr - else errorWithoutStackTrace) $ "Parse failed: " ++ show err - - Success expr -> do - when (check opts) $ do - expr' <- liftIO (reduceExpr mpath expr) - case HM.inferTop Env.empty [("it", stripAnnotation expr')] of - Left err -> - errorWithoutStackTrace $ "Type error: " ++ PS.ppShow err - Right ty -> - liftIO $ putStrLn $ "Type of expression: " - ++ PS.ppShow (fromJust (Map.lookup "it" (Env.types ty))) - - -- liftIO $ putStrLn $ runST $ - -- runLintM opts . renderSymbolic =<< lint opts expr - - catch (process opts mpath expr) $ \case - NixException frames -> - errorWithoutStackTrace . show - =<< renderFrames @(NThunk (Lazy IO)) frames - - when (repl opts) $ Repl.shell (pure ()) - - process opts mpath expr - | evaluate opts, tracing opts = - evaluateExpression mpath - Nix.nixTracingEvalExprLoc printer expr - - | evaluate opts, Just path <- reduce opts = - evaluateExpression mpath (reduction path) printer expr - - | evaluate opts, not (null (arg opts) && null (argstr opts)) = - evaluateExpression mpath - Nix.nixEvalExprLoc printer expr - - | evaluate opts = - processResult printer =<< Nix.nixEvalExprLoc mpath expr + time <- getCurrentTime + opts <- execParser (nixOptionsInfo time) + runStandardIO opts $ case readFrom opts of + Just path -> do + let file = addExtension (dropExtension path) "nixc" + process opts (Just file) =<< liftIO (readCache path) + Nothing -> case expression opts of + Just s -> handleResult opts Nothing (parseNixTextLoc s) + Nothing -> case fromFile opts of + Just "-" -> mapM_ (processFile opts) =<< (lines <$> liftIO getContents) + Just path -> + mapM_ (processFile opts) =<< (lines <$> liftIO (readFile path)) + Nothing -> case filePaths opts of + [] -> withNixContext Nothing $ Repl.main + ["-"] -> + handleResult opts Nothing + . parseNixTextLoc + =<< liftIO Text.getContents + paths -> mapM_ (processFile opts) paths + where + processFile opts path = do + eres <- parseNixFileLoc path + handleResult opts (Just path) eres - | xml opts = - error "Rendering expression trees to XML is not yet implemented" + handleResult opts mpath = \case + Failure err -> + (if ignoreErrors opts + then liftIO . hPutStrLn stderr + else errorWithoutStackTrace + ) + $ "Parse failed: " + ++ show err - | json opts = - liftIO $ TL.putStrLn $ - A.encodeToLazyText (stripAnnotation expr) + Success expr -> do + when (check opts) $ do + expr' <- liftIO (reduceExpr mpath expr) + case HM.inferTop Env.empty [("it", stripAnnotation expr')] of + Left err -> errorWithoutStackTrace $ "Type error: " ++ PS.ppShow err + Right ty -> liftIO $ putStrLn $ "Type of expression: " ++ PS.ppShow + (fromJust (Map.lookup "it" (Env.types ty))) - | verbose opts >= DebugInfo = - liftIO $ putStr $ PS.ppShow $ stripAnnotation expr + -- liftIO $ putStrLn $ runST $ + -- runLintM opts . renderSymbolic =<< lint opts expr - | cache opts, Just path <- mpath = - liftIO $ writeCache (addExtension (dropExtension path) "nixc") expr + catch (process opts mpath expr) $ \case + NixException frames -> + errorWithoutStackTrace + . show + =<< renderFrames @(StandardValue IO) @(StandardThunk IO) frames - | parseOnly opts = - void $ liftIO $ Exc.evaluate $ Deep.force expr + when (repl opts) $ withNixContext Nothing $ Repl.main - | otherwise = - liftIO $ displayIO stdout - . renderPretty 0.4 80 - . prettyNix - . stripAnnotation $ expr - where - printer :: forall e m. (MonadNix e m, MonadIO m, Typeable m) - => NValue m -> m () - printer - | finder opts = - fromValue @(AttrSet (NThunk m)) >=> findAttrs - | xml opts = - liftIO . putStrLn . toXML <=< normalForm - | json opts = - liftIO . TL.putStrLn - . TL.decodeUtf8 - . A.encodingToLazyByteString - . toEncodingSorted - <=< fromNix - | strict opts = - liftIO . print . prettyNValueNF <=< normalForm - | values opts = - liftIO . print <=< prettyNValueProv - | otherwise = - liftIO . print <=< prettyNValue - where - findAttrs = go "" - where - go prefix s = do - xs <- forM (sortOn fst (M.toList s)) - $ \(k, nv@(NThunk _ t)) -> case t of - Value v -> pure (k, Just v) - Thunk _ _ ref -> do - let path = prefix ++ Text.unpack k - (_, descend) = filterEntry path k - val <- readVar ref - case val of - Computed _ -> pure (k, Nothing) - _ | descend -> (k,) <$> forceEntry path nv - | otherwise -> pure (k, Nothing) + process opts mpath expr + | evaluate opts + , tracing opts + = evaluateExpression mpath Nix.nixTracingEvalExprLoc printer expr + | evaluate opts + , Just path <- reduce opts + = evaluateExpression mpath (reduction path) printer expr + | evaluate opts + , not (null (arg opts) && null (argstr opts)) + = evaluateExpression mpath Nix.nixEvalExprLoc printer expr + | evaluate opts + = processResult printer =<< Nix.nixEvalExprLoc mpath expr + | xml opts + = error "Rendering expression trees to XML is not yet implemented" + | json opts + = liftIO $ TL.putStrLn $ A.encodeToLazyText (stripAnnotation expr) + | verbose opts >= DebugInfo + = liftIO $ putStr $ PS.ppShow $ stripAnnotation expr + | cache opts + , Just path <- mpath + = liftIO $ writeCache (addExtension (dropExtension path) "nixc") expr + | parseOnly opts + = void $ liftIO $ Exc.evaluate $ Deep.force expr + | otherwise + = liftIO + $ renderIO stdout + . layoutPretty (LayoutOptions $ AvailablePerLine 80 0.4) + . prettyNix + . stripAnnotation + $ expr + where + printer + | finder opts + = fromValue @(AttrSet (StandardThunk IO)) >=> findAttrs + | xml opts + = liftIO + . putStrLn + . Text.unpack + . principledStringIgnoreContext + . toXML + <=< normalForm + | json opts + = liftIO + . Text.putStrLn + . principledStringIgnoreContext + <=< nvalueToJSONNixString + | strict opts + = liftIO . print . prettyNValueNF <=< normalForm + | values opts + = liftIO . print <=< prettyNValueProv + | otherwise + = liftIO . print <=< prettyNValue + where + findAttrs = go "" + where + go prefix s = do + xs <- + forM (sortOn fst (M.toList s)) + $ \(k, nv@(StdThunk (extract -> t))) -> case t of + Value v -> pure (k, Just v) + Thunk _ _ ref -> do + let path = prefix ++ Text.unpack k + (_, descend) = filterEntry path k + val <- readVar @(StandardT IO) ref + case val of + Computed _ -> pure (k, Nothing) + _ | descend -> (k, ) <$> forceEntry path nv + | otherwise -> pure (k, Nothing) - forM_ xs $ \(k, mv) -> do - let path = prefix ++ Text.unpack k - (report, descend) = filterEntry path k - when report $ do - liftIO $ putStrLn path - when descend $ case mv of - Nothing -> return () - Just v -> case v of - NVSet s' _ -> go (path ++ ".") s' - _ -> return () - where - filterEntry path k = case (path, k) of - ("stdenv", "stdenv") -> (True, True) - (_, "stdenv") -> (False, False) - (_, "out") -> (True, False) - (_, "src") -> (True, False) - (_, "mirrorsFile") -> (True, False) - (_, "buildPhase") -> (True, False) - (_, "builder") -> (False, False) - (_, "drvPath") -> (False, False) - (_, "outPath") -> (False, False) - (_, "__impureHostDeps") -> (False, False) - (_, "__sandboxProfile") -> (False, False) - ("pkgs", "pkgs") -> (True, True) - (_, "pkgs") -> (False, False) - (_, "drvAttrs") -> (False, False) - _ -> (True, True) + forM_ xs $ \(k, mv) -> do + let path = prefix ++ Text.unpack k + (report, descend) = filterEntry path k + when report $ do + liftIO $ putStrLn path + when descend $ case mv of + Nothing -> return () + Just v -> case v of + NVSet s' _ -> go (path ++ ".") s' + _ -> return () + where + filterEntry path k = case (path, k) of + ("stdenv", "stdenv" ) -> (True, True) + (_ , "stdenv" ) -> (False, False) + (_ , "out" ) -> (True, False) + (_ , "src" ) -> (True, False) + (_ , "mirrorsFile" ) -> (True, False) + (_ , "buildPhase" ) -> (True, False) + (_ , "builder" ) -> (False, False) + (_ , "drvPath" ) -> (False, False) + (_ , "outPath" ) -> (False, False) + (_ , "__impureHostDeps") -> (False, False) + (_ , "__sandboxProfile") -> (False, False) + ("pkgs" , "pkgs" ) -> (True, True) + (_ , "pkgs" ) -> (False, False) + (_ , "drvAttrs" ) -> (False, False) + _ -> (True, True) - forceEntry k v = catch (Just <$> force v pure) - $ \(NixException frames) -> do - liftIO . putStrLn - . ("Exception forcing " ++) - . (k ++) - . (": " ++) . show - =<< renderFrames @(NThunk (Lazy IO)) frames - return Nothing + forceEntry k v = + catch (Just <$> force v pure) $ \(NixException frames) -> do + liftIO + . putStrLn + . ("Exception forcing " ++) + . (k ++) + . (": " ++) + . show + =<< renderFrames @(StandardValue IO) @(StandardThunk IO) frames + return Nothing - reduction path mp x = do - eres <- Nix.withNixContext mp $ - Nix.reducingEvalExpr (Eval.eval . annotated . getCompose) mp x - handleReduced path eres + reduction path mp x = do + eres <- Nix.withNixContext mp + $ Nix.reducingEvalExpr (Eval.eval . annotated . getCompose) mp x + handleReduced path eres - handleReduced :: (MonadThrow m, MonadIO m) - => FilePath - -> (NExprLoc, Either SomeException (NValue m)) - -> m (NValue m) - handleReduced path (expr', eres) = do - liftIO $ do - putStrLn $ "Wrote winnowed expression tree to " ++ path - writeFile path $ show $ prettyNix (stripAnnotation expr') - case eres of - Left err -> throwM err - Right v -> return v + handleReduced + :: (MonadThrow m, MonadIO m) + => FilePath + -> (NExprLoc, Either SomeException (NValue t f m)) + -> m (NValue t f m) + handleReduced path (expr', eres) = do + liftIO $ do + putStrLn $ "Wrote winnowed expression tree to " ++ path + writeFile path $ show $ prettyNix (stripAnnotation expr') + case eres of + Left err -> throwM err + Right v -> return v diff --git a/main/Repl.hs b/main/Repl.hs --- a/main/Repl.hs +++ b/main/Repl.hs @@ -11,6 +11,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -21,22 +22,33 @@ module Repl where -import Nix +import Nix hiding ( exec + , try + ) +import Nix.Cited import Nix.Convert import Nix.Eval import Nix.Scope -import qualified Nix.Type.Env as Env +import qualified Nix.Type.Env as Env import Nix.Type.Infer import Nix.Utils -import qualified Data.HashMap.Lazy as M -import Data.List (isPrefixOf, foldl') -import qualified Data.Map as Map +import Control.Comonad +import qualified Data.HashMap.Lazy as M +import Data.List ( isPrefixOf + , foldl' + ) +import qualified Data.Map as Map import Data.Monoid -import Data.Text (unpack, pack) -import qualified Data.Text as Text -import qualified Data.Text.IO as Text +import Data.Text ( unpack + , pack + ) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import Data.Version ( showVersion ) +import Paths_hnix ( version ) +import Control.Monad.Catch import Control.Monad.Identity import Control.Monad.Reader import Control.Monad.State.Strict @@ -46,23 +58,36 @@ import System.Environment import System.Exit + +main :: (MonadNix e t f m, MonadIO m, MonadException m) => m () +main = flip evalStateT initState +#if MIN_VERSION_repline(0, 2, 0) + $ evalRepl (return prefix) cmd options (Just ':') completer welcomeText +#else + $ evalRepl prefix cmd options completer welcomeText +#endif + where + prefix = "hnix> " + welcomeText = + liftIO + $ putStrLn + $ "Welcome to hnix " + <> showVersion version + <> ". For help type :help\n" + ------------------------------------------------------------------------------- -- Types ------------------------------------------------------------------------------- -data TermEnv - -data IState = IState - { -- tyctx :: Env.Env -- Type environment - -- , - tmctx :: TermEnv -- Value environment +newtype IState t f m = IState + { tmctx :: AttrSet (NValue t f m) -- Value environment } -initState :: IState -initState = IState {-Env.empty-} undefined +initState :: MonadIO m => IState t f m +initState = IState M.empty -type Repl e m a = HaskelineT (StateT IState m) a -hoistErr :: MonadIO m => Result a -> Repl e m a +type Repl e t f m = HaskelineT (StateT (IState t f m) m) +hoistErr :: MonadIO m => Result a -> Repl e t f m a hoistErr (Success val) = return val hoistErr (Failure err) = do liftIO $ print err @@ -72,75 +97,85 @@ -- Execution ------------------------------------------------------------------------------- -exec :: forall e m. (MonadNix e m, MonadIO m, MonadException m) - => Bool -> Text.Text -> Repl e m () +exec + :: forall e t f m + . (MonadNix e t f m, MonadIO m, MonadException m) + => Bool + -> Text.Text + -> Repl e t f m (NValue t f m) exec update source = do -- Get the current interpreter state - st <- get + st <- get -- Parser ( returns AST ) + -- TODO: parse = expr <- hoistErr $ parseNixTextLoc source -- Type Inference ( returns Typing Environment ) -- tyctx' <- hoistErr $ inferTop (tyctx st) expr - -- Create the new environment - let st' = st { tmctx = tmctx st -- foldl' evalDef (tmctx st) expr - -- , tyctx = tyctx' <> tyctx st - } + -- TODO: track scope with (tmctx st) + mVal <- lift $ lift $ try $ pushScope @t M.empty (evalExprLoc expr) - -- Update the interpreter state - when update (put st') + case mVal of + Left (NixException frames) -> do + lift $ lift $ liftIO . print =<< renderFrames @(NValue t f m) @t frames + abort + Right val -> do + -- Update the interpreter state + when update $ do + -- Create the new environment + put st { tmctx = tmctx st } -- TODO: M.insert key val (tmctx st) + return val - -- If a value is entered, print it. + +cmd + :: (MonadNix e t f m, MonadIO m, MonadException m) + => String + -> Repl e t f m () +cmd source = do + val <- exec True (Text.pack source) lift $ lift $ do - -- jww (2018-04-12): Once the user is able to establish definitions in - -- the repl, they should be passed here. - pushScope @(NThunk m) M.empty $ catch (go expr) $ \case - NixException frames -> do - liftIO . print =<< renderFrames @(NThunk m) frames - where - go expr = do - val <- evalExprLoc expr opts :: Nix.Options <- asks (view hasLens) - if | strict opts -> - liftIO . print . prettyNValueNF =<< normalForm val - | values opts -> - liftIO . print =<< prettyNValueProv val - | otherwise -> - liftIO . print =<< prettyNValue val - -cmd :: (MonadNix e m, MonadIO m, MonadException m) => String -> Repl e m () -cmd source = exec True (Text.pack source) - + if + | strict opts -> liftIO . print . prettyNValueNF =<< normalForm val + | values opts -> liftIO . print =<< prettyNValueProv val + | otherwise -> liftIO . print =<< prettyNValue val ------------------------------------------------------------------------------- -- Commands ------------------------------------------------------------------------------- -- :browse command -browse :: MonadNix e m => [String] -> Repl e m () +browse :: MonadNix e t f m => [String] -> Repl e t f m () browse _ = do st <- get undefined -- liftIO $ mapM_ putStrLn $ ppenv (tyctx st) -- :load command -load :: (MonadNix e m, MonadIO m, MonadException m) => [String] -> Repl e m () +load + :: (MonadNix e t f m, MonadIO m, MonadException m) + => [String] + -> Repl e t f m () load args = do contents <- liftIO $ Text.readFile (unwords args) - exec True contents + void $ exec True contents -- :type command --- typeof :: [String] -> Repl e m () --- typeof args = do --- st <- get --- let arg = unwords args --- case Env.lookup (pack arg) (tyctx st) of --- Just val -> liftIO $ putStrLn $ undefined -- ppsignature (arg, val) --- Nothing -> exec False (Text.pack arg) +typeof + :: (MonadNix e t f m, MonadException m, MonadIO m) + => [String] + -> Repl e t f m () +typeof args = do + st <- get + val <- case M.lookup line (tmctx st) of + Just val -> return val + Nothing -> exec False line + liftIO $ putStrLn $ describeValue . valueType . extract . _nValue $ val + where line = Text.pack (unwords args) -- :quit command -quit :: (MonadNix e m, MonadIO m) => a -> Repl e m () +quit :: (MonadNix e t f m, MonadIO m) => a -> Repl e t f m () quit _ = liftIO exitSuccess ------------------------------------------------------------------------------- @@ -149,48 +184,46 @@ -- Prefix tab completer defaultMatcher :: MonadIO m => [(String, CompletionFunc m)] -defaultMatcher = [ - (":load" , fileCompleter) +defaultMatcher = + [(":load", fileCompleter) --, (":type" , values) - ] + ] -- Default tab completer -comp :: (Monad m, MonadState IState m) => WordCompleter m +comp :: Monad m => WordCompleter m comp n = do let cmds = [":load", ":type", ":browse", ":quit"] -- Env.TypeEnv ctx <- gets tyctx -- let defs = map unpack $ Map.keys ctx - return $ filter (isPrefixOf n) (cmds {-++ defs-}) + return $ filter (isPrefixOf n) (cmds {-++ defs-} + ) -options :: (MonadNix e m, MonadIO m, MonadException m) - => [(String, [String] -> Repl e m ())] -options = [ - ("load" , load) - , ("browse" , browse) - , ("quit" , quit) - -- , ("type" , Repl.typeof) +options + :: (MonadNix e t f m, MonadIO m, MonadException m) + => [(String, [String] -> Repl e t f m ())] +options = + [ ( "load" + , load + ) + --, ("browse" , browse) + , ("quit", quit) + , ("type", typeof) + , ("help", help) ] -------------------------------------------------------------------------------- --- Entry Point -------------------------------------------------------------------------------- +help + :: forall e t f m + . (MonadNix e t f m, MonadIO m, MonadException m) + => [String] + -> Repl e t f m () +help _ = liftIO $ do + putStrLn "Available commands:\n" + mapM_ putStrLn $ map (\o -> ":" ++ (fst o)) (options @e @t @f @m) -completer :: (MonadNix e m, MonadIO m) => CompleterStyle (StateT IState m) +completer + :: (MonadNix e t f m, MonadIO m) + => CompleterStyle (StateT (IState t f m) m) completer = Prefix (wordCompleter comp) defaultMatcher -shell :: (MonadNix e m, MonadIO m, MonadException m) => Repl e m a -> m () -shell pre = flip evalStateT initState $ - evalRepl "hnix> " cmd options completer pre -------------------------------------------------------------------------------- --- Toplevel -------------------------------------------------------------------------------- --- main :: IO () --- main = do --- args <- getArgs --- case args of --- [] -> shell (return ()) --- [fname] -> shell (load [fname]) --- ["test", fname] -> shell (load [fname] >> browse [] >> quit ()) --- _ -> putStrLn "invalid arguments" diff --git a/package.yaml b/package.yaml deleted file mode 100644 --- a/package.yaml +++ /dev/null @@ -1,214 +0,0 @@ -name: hnix -version: 0.5.2 -synopsis: Haskell implementation of the Nix language -github: haskell-nix/hnix -author: John Wiegley -maintainer: johnw@newartisans.com -category: System, Data, Nix -license: BSD3 - -description: - Haskell implementation of the Nix language. - -extra-source-files: - - LICENSE - - README.md - - package.yaml - - data/* - - data/nix/* - - data/nix/corepkgs/* - - data/nix/config/* - - data/nix/perl/* - - data/nix/perl/lib/Nix/* - - data/nix/tests/* - - data/nix/tests/plugins/* - - data/nix/tests/lang/* - - data/nix/tests/lang/readDir/* - - data/nix/tests/lang/readDir/foo/* - - data/nix/tests/lang/dir2/* - - data/nix/tests/lang/dir4/* - - data/nix/tests/lang/dir3/* - - data/nix/tests/lang/dir1/* - - data/nix/maintainers/* - - data/nix/mk/* - - data/nix/scripts/* - - tests/eval-compare/* - -flags: - tracing: - description: Enable full debug tracing - manual: True - default: False - - profiling: - description: Enable profiling - manual: True - default: False - - optimize: - description: Enable all optimization flags - manual: True - default: False - -ghc-options: - - -Wall - -dependencies: - - base >= 4.9 && < 5 - - ansi-wl-pprint - - bytestring - - containers - - data-fix - - deepseq >= 1.4.2 && < 1.5 - - exceptions - - filepath - - hashing - - mtl - - optparse-applicative - - template-haskell - - text - - time - - transformers - - unordered-containers >= 0.2.9 && < 0.3 - -when: - - condition: flag(optimize) - ghc-options: - - -fexpose-all-unfoldings - - -fspecialise-aggressively - - -O2 - - - condition: flag(tracing) - cpp-options: -DENABLE_TRACING=1 - - - condition: "os(linux) && impl(ghc >= 8.2) && impl(ghc < 8.3)" - dependencies: - - compact - - - condition: "!impl(ghcjs)" - dependencies: - - base16-bytestring - - cryptohash-md5 - - cryptohash-sha1 - - cryptohash-sha256 - - cryptohash-sha512 - - serialise - -library: - source-dirs: src - dependencies: - - aeson - - ansi-wl-pprint - - array >= 0.4 && < 0.6 - - binary - - deriving-compat >= 0.3 && < 0.6 - - directory - - http-types - - http-client - - http-client-tls - - interpolate - - lens-family-th - - logict - - megaparsec >= 6.5 && < 7.0 - - monadlist - - process - - regex-tdfa - - regex-tdfa-text - - scientific - - semigroups >= 0.18 && < 0.19 - - split - - syb - - these - - unix - - vector - - xml - when: - - condition: "impl(ghc < 8.1)" - then: - dependencies: - - lens-family == 1.2.1 - - lens-family-core == 1.2.1 - else: - dependencies: - - lens-family >= 1.2.2 - - lens-family-core >= 1.2.2 - - - condition: "impl(ghc < 8.4.0) && !flag(profiling)" - dependencies: - - ghc-datasize - - - condition: "impl(ghcjs)" - then: - dependencies: - - hashable >= 1.2.4 && < 1.3 - else: - exposed-modules: - - Nix.Options.Parser - dependencies: - - hashable >= 1.2.5 && < 1.3 - - haskeline - - pretty-show - -executables: - hnix: - source-dirs: main - main: Main.hs - dependencies: - - hnix - - aeson - - pretty-show - - repline - - haskeline - when: - - condition: "impl(ghcjs)" - then: - buildable: false - else: - buildable: true - -tests: - hnix-tests: - source-dirs: tests - main: Main.hs - ghc-options: -threaded - verbatim: - build-tool-depends: - hspec-discover:hspec-discover == 2.* - dependencies: - - hnix - - Glob - - directory - - interpolate - - process - - split - - tasty - - tasty-hedgehog - - tasty-hunit - - tasty-th - - unix - - hedgehog - - generic-random - - Diff - - megaparsec - - tasty-quickcheck - - pretty-show - when: - - condition: "impl(ghcjs)" - then: - buildable: false - else: - buildable: true - -benchmarks: - hnix-benchmarks: - source-dirs: benchmarks - main: Main.hs - dependencies: - - hnix - - criterion - when: - - condition: "impl(ghcjs)" - then: - buildable: false - else: - buildable: true diff --git a/src/Nix.hs b/src/Nix.hs --- a/src/Nix.hs +++ b/src/Nix.hs @@ -4,83 +4,86 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} -module Nix (module Nix.Cache, - module Nix.Exec, - module Nix.Expr, - module Nix.Frames, - module Nix.Render.Frame, - module Nix.Normal, - module Nix.Options, - module Nix.Parser, - module Nix.Pretty, - module Nix.Reduce, - module Nix.Thunk, - module Nix.Value, - module Nix.XML, - withNixContext, - nixEvalExpr, nixEvalExprLoc, nixTracingEvalExprLoc, - evaluateExpression, processResult) where +module Nix + ( module Nix.Cache + , module Nix.Exec + , module Nix.Expr + , module Nix.Frames + , module Nix.Render.Frame + , module Nix.Normal + , module Nix.Options + , module Nix.String + , module Nix.Parser + , module Nix.Pretty + , module Nix.Reduce + , module Nix.Thunk + , module Nix.Value + , module Nix.XML + , withNixContext + , nixEvalExpr + , nixEvalExprLoc + , nixTracingEvalExprLoc + , evaluateExpression + , processResult + ) +where import Control.Applicative -import Control.Arrow (second) +import Control.Arrow ( second ) import Control.Monad.Reader import Data.Fix -import qualified Data.HashMap.Lazy as M -import qualified Data.Text as Text -import qualified Data.Text.Read as Text +import qualified Data.HashMap.Lazy as M +import qualified Data.Text as Text +import qualified Data.Text.Read as Text import Nix.Builtins import Nix.Cache -import qualified Nix.Eval as Eval +import qualified Nix.Eval as Eval import Nix.Exec import Nix.Expr import Nix.Frames +import Nix.String import Nix.Normal import Nix.Options import Nix.Parser import Nix.Pretty import Nix.Reduce import Nix.Render.Frame -import Nix.Scope import Nix.Thunk import Nix.Utils import Nix.Value import Nix.XML --- | Evaluate a nix expression in the default context -withNixContext :: forall e m r. (MonadNix e m, Has e Options) - => Maybe FilePath -> m r -> m r -withNixContext mpath action = do - base <- builtins - opts :: Options <- asks (view hasLens) - let i = value @(NValue m) @(NThunk m) @m $ nvList $ - map (value @(NValue m) @(NThunk m) @m - . flip nvStr mempty . Text.pack) (include opts) - pushScope (M.singleton "__includes" i) $ - pushScopes base $ case mpath of - Nothing -> action - Just path -> do - traceM $ "Setting __cur_file = " ++ show path - let ref = value @(NValue m) @(NThunk m) @m $ nvPath path - pushScope (M.singleton "__cur_file" ref) action - -- | This is the entry point for all evaluations, whatever the expression tree -- type. It sets up the common Nix environment and applies the -- transformations, allowing them to be easily composed. -nixEval :: (MonadNix e m, Has e Options, Functor f) - => Maybe FilePath -> Transform f (m a) -> Alg f (m a) -> Fix f -> m a +nixEval + :: (MonadNix e t f m, Has e Options, Functor g) + => Maybe FilePath + -> Transform g (m a) + -> Alg g (m a) + -> Fix g + -> m a nixEval mpath xform alg = withNixContext mpath . adi alg xform -- | Evaluate a nix expression in the default context -nixEvalExpr :: forall e m. (MonadNix e m, Has e Options) - => Maybe FilePath -> NExpr -> m (NValue m) +nixEvalExpr + :: (MonadNix e t f m, Has e Options) + => Maybe FilePath + -> NExpr + -> m (NValue t f m) nixEvalExpr mpath = nixEval mpath id Eval.eval -- | Evaluate a nix expression in the default context -nixEvalExprLoc :: forall e m. (MonadNix e m, Has e Options) - => Maybe FilePath -> NExprLoc -> m (NValue m) -nixEvalExprLoc mpath = - nixEval mpath (Eval.addStackFrames @(NThunk m) . Eval.addSourcePositions) - (Eval.eval . annotated . getCompose) +nixEvalExprLoc + :: forall e t f m + . (MonadNix e t f m, Has e Options) + => Maybe FilePath + -> NExprLoc + -> m (NValue t f m) +nixEvalExprLoc mpath = nixEval + mpath + (Eval.addStackFrames @t . Eval.addSourcePositions) + (Eval.eval . annotated . getCompose) -- | Evaluate a nix expression with tracing in the default context. Note that -- this function doesn't do any tracing itself, but 'evalExprLoc' will be @@ -88,64 +91,78 @@ -- 'MonadNix'). All this function does is provide the right type class -- context. nixTracingEvalExprLoc - :: forall e m. (MonadNix e m, Has e Options, MonadIO m, Alternative m) - => Maybe FilePath -> NExprLoc -> m (NValue m) + :: (MonadNix e t f m, Has e Options, MonadIO m, Alternative m) + => Maybe FilePath + -> NExprLoc + -> m (NValue t f m) nixTracingEvalExprLoc mpath = withNixContext mpath . evalExprLoc evaluateExpression - :: (MonadNix e m, Has e Options) - => Maybe FilePath - -> (Maybe FilePath -> NExprLoc -> m (NValue m)) - -> (NValue m -> m a) - -> NExprLoc - -> m a + :: (MonadNix e t f m, Has e Options) + => Maybe FilePath + -> (Maybe FilePath -> 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 <- traverse (traverse eval') $ - map (second parseArg) (arg opts) ++ - map (second mkStr) (argstr opts) - compute evaluator expr (argmap args) handler - where - parseArg s = case parseNixText s of - Success x -> x - Failure err -> errorWithoutStackTrace (show err) + opts :: Options <- asks (view hasLens) + args <- traverse (traverse eval') $ map (second parseArg) (arg opts) ++ map + (second mkStr) + (argstr opts) + compute evaluator expr (argmap args) handler + where + parseArg s = case parseNixText s of + Success x -> x + Failure err -> errorWithoutStackTrace (show err) - eval' = (normalForm =<<) . nixEvalExpr mpath + eval' = (normalForm =<<) . nixEvalExpr mpath - argmap args = embed $ Fix $ NVSetF (M.fromList args) mempty + argmap args = pure $ nvSet (M.fromList args') mempty + where args' = map (fmap (wrapValue . nValueFromNF)) args - compute ev x args p = do - f <- ev mpath x - processResult p =<< case f of - NVClosure _ g -> g args - _ -> pure f + compute ev x args p = do + f :: NValue t f m <- ev mpath x + processResult p =<< case f of + NVClosure _ g -> force ?? pure =<< g args + _ -> pure f -processResult :: forall e m a. (MonadNix e m, Has e Options) - => (NValue m -> m a) -> NValue m -> m a +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) - case attr opts of - Nothing -> h val - Just (Text.splitOn "." -> keys) -> go keys val - where - go :: [Text.Text] -> NValue m -> m a - go [] v = h v - go ((Text.decimal -> Right (n,"")):ks) v = case v of - NVList xs -> case ks of - [] -> force @(NValue m) @(NThunk m) (xs !! n) h - _ -> force (xs !! n) (go ks) - _ -> errorWithoutStackTrace $ - "Expected a list for selector '" ++ show n - ++ "', but got: " ++ show v - go (k:ks) v = case v of - NVSet xs _ -> case M.lookup k xs of - Nothing -> - errorWithoutStackTrace $ - "Set does not contain key '" - ++ Text.unpack k ++ "'" - Just v' -> case ks of - [] -> force v' h - _ -> force v' (go ks) - _ -> errorWithoutStackTrace $ - "Expected a set for selector '" ++ Text.unpack k - ++ "', but got: " ++ show v + opts :: Options <- asks (view hasLens) + case attr opts of + Nothing -> h val + Just (Text.splitOn "." -> keys) -> go keys val + where + go :: [Text.Text] -> NValue t f m -> m a + go [] v = h v + go ((Text.decimal -> Right (n,"")) : ks) v = case v of + NVList xs -> case ks of + [] -> force @t @m @(NValue t f m) (xs !! n) h + _ -> force (xs !! n) (go ks) + _ -> + errorWithoutStackTrace + $ "Expected a list for selector '" + ++ show n + ++ "', but got: " + ++ show v + go (k : ks) v = case v of + NVSet xs _ -> case M.lookup k xs of + Nothing -> + errorWithoutStackTrace + $ "Set does not contain key '" + ++ Text.unpack k + ++ "'" + Just v' -> case ks of + [] -> force v' h + _ -> force v' (go ks) + _ -> + errorWithoutStackTrace + $ "Expected a set for selector '" + ++ Text.unpack k + ++ "', but got: " + ++ show v diff --git a/src/Nix/Atoms.hs b/src/Nix/Atoms.hs --- a/src/Nix/Atoms.hs +++ b/src/Nix/Atoms.hs @@ -9,11 +9,13 @@ #ifdef MIN_VERSION_serialise import Codec.Serialise #endif -import Control.DeepSeq -import Data.Data -import Data.Hashable -import Data.Text (Text, pack) -import GHC.Generics +import Control.DeepSeq +import Data.Data +import Data.Hashable +import Data.Text ( Text + , pack + ) +import GHC.Generics -- | Atoms are values that evaluate to themselves. This means that -- they appear in both the parsed AST (in the form of literals) and @@ -37,7 +39,15 @@ -- | Translate an atom into its nix representation. atomText :: NAtom -> Text -atomText (NInt i) = pack (show i) +atomText (NInt i) = pack (show i) atomText (NFloat f) = pack (show f) -atomText (NBool b) = if b then "true" else "false" +atomText (NBool b) = if b then "true" else "false" atomText NNull = "null" + + + + + + + + diff --git a/src/Nix/Builtins.hs b/src/Nix/Builtins.hs --- a/src/Nix/Builtins.hs +++ b/src/Nix/Builtins.hs @@ -21,1028 +21,1517 @@ {-# OPTIONS_GHC -Wno-missing-signatures #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -module Nix.Builtins (builtins) where - -import Control.Monad -import Control.Monad.Catch -import Control.Monad.ListM (sortByM) -import Control.Monad.Reader (asks) - --- Using package imports here because there is a bug in cabal2nix that forces --- us to put the hashing package in the unconditional dependency list. --- See https://github.com/NixOS/cabal2nix/issues/348 for more info -#if MIN_VERSION_hashing(0, 1, 0) -import 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 -#else -import Data.ByteString.Base16 as Base16 -import qualified "cryptohash-md5" Crypto.Hash.MD5 as MD5 -import qualified "cryptohash-sha1" Crypto.Hash.SHA1 as SHA1 -import qualified "cryptohash-sha256" Crypto.Hash.SHA256 as SHA256 -import qualified "cryptohash-sha512" Crypto.Hash.SHA512 as SHA512 -#endif - -import qualified Data.Aeson as A -import qualified Data.Aeson.Encoding as A -import Data.Align (alignWith) -import Data.Array -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as LBS -import Data.Char (isDigit) -import Data.Coerce -import Data.Fix -import Data.Foldable (foldrM) -import qualified Data.HashMap.Lazy as M -import Data.List -import Data.Maybe -import Data.Semigroup -import Data.Set (Set) -import qualified Data.Set as S -import Data.String.Interpolate.IsString -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Text.Encoding -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 Data.Traversable (mapM) -import Nix.Atoms -import Nix.Convert -import Nix.Effects -import qualified Nix.Eval as Eval -import Nix.Exec -import Nix.Expr.Types -import Nix.Expr.Types.Annotated -import Nix.Frames -import Nix.Normal -import Nix.Options -import Nix.Parser -import Nix.Render -import Nix.Scope -import Nix.Thunk -import Nix.Utils -import Nix.Value -import Nix.XML -import System.FilePath -import System.Posix.Files -import Text.Regex.TDFA - -builtins :: (MonadNix e m, Scoped e (NThunk m) m) - => m (Scopes m (NThunk m)) -builtins = do - ref <- thunk $ flip nvSet M.empty <$> buildMap - lst <- ([("builtins", ref)] ++) <$> topLevelBuiltins - pushScope (M.fromList lst) currentScopes - where - buildMap = M.fromList . map mapping <$> builtinsList - topLevelBuiltins = map mapping <$> fullBuiltinsList - - fullBuiltinsList = map go <$> builtinsList - where - go b@(Builtin TopLevel _) = b - go (Builtin Normal (name, builtin)) = - Builtin TopLevel ("__" <> name, builtin) - -data BuiltinType = Normal | TopLevel -data Builtin m = Builtin - { _kind :: BuiltinType - , mapping :: (Text, NThunk m) - } - -valueThunk :: forall e m. MonadNix e m => NValue m -> NThunk m -valueThunk = value @_ @_ @m - -force' :: forall e m. MonadNix e m => NThunk m -> m (NValue m) -force' = force ?? pure - -builtinsList :: forall e m. MonadNix e m => m [ Builtin m ] -builtinsList = sequence [ - do version <- toValue ("2.0" :: Text) - pure $ Builtin Normal ("nixVersion", version) - - , do version <- toValue (5 :: Int) - pure $ Builtin Normal ("langVersion", version) - - , add0 Normal "nixPath" nixPath - , add TopLevel "abort" throw_ -- for now - , add2 Normal "add" add_ - , add2 Normal "all" all_ - , add2 Normal "any" any_ - , add Normal "attrNames" attrNames - , add Normal "attrValues" attrValues - , add TopLevel "baseNameOf" baseNameOf - , add2 Normal "catAttrs" catAttrs - , add2 Normal "compareVersions" compareVersions_ - , add Normal "concatLists" concatLists - , add' Normal "concatStringsSep" (arity2 Text.intercalate) - , add0 Normal "currentSystem" currentSystem - , add0 Normal "currentTime" currentTime_ - , add2 Normal "deepSeq" deepSeq - - , add0 TopLevel "derivation" $(do - -- This is compiled in so that we only parse and evaluate it once, - -- at compile-time. - let Success expr = parseNixText [i| - /* This is the implementation of the ‘derivation’ builtin function. - It's actually a wrapper around the ‘derivationStrict’ primop. */ - - drvAttrs @ { outputs ? [ "out" ], ... }: - - let - - strict = derivationStrict drvAttrs; - - commonAttrs = drvAttrs // (builtins.listToAttrs outputsList) // - { all = map (x: x.value) outputsList; - inherit drvAttrs; - }; - - outputToAttrListElement = outputName: - { name = outputName; - value = commonAttrs // { - outPath = builtins.getAttr outputName strict; - drvPath = strict.drvPath; - type = "derivation"; - inherit outputName; - }; - }; - - outputsList = map outputToAttrListElement outputs; - - in (builtins.head outputsList).value|] - [| cata Eval.eval expr |] - ) - - , add TopLevel "derivationStrict" derivationStrict_ - , add TopLevel "dirOf" dirOf - , add2 Normal "div" div_ - , add2 Normal "elem" elem_ - , add2 Normal "elemAt" elemAt_ - , add Normal "exec" exec_ - , add0 Normal "false" (return $ nvConstant $ NBool False) - , add Normal "fetchTarball" fetchTarball - , add Normal "fetchurl" fetchurl - , add2 Normal "filter" filter_ - , add3 Normal "foldl'" foldl'_ - , add Normal "fromJSON" fromJSON - , add Normal "functionArgs" functionArgs - , add2 Normal "genList" genList - , add Normal "genericClosure" genericClosure - , add2 Normal "getAttr" getAttr - , add Normal "getEnv" getEnv_ - , add2 Normal "hasAttr" hasAttr - , add Normal "hasContext" hasContext - , add' Normal "hashString" hashString - , add Normal "head" head_ - , add TopLevel "import" import_ - , add2 Normal "intersectAttrs" intersectAttrs - , add Normal "isAttrs" isAttrs - , add Normal "isBool" isBool - , add Normal "isFloat" isFloat - , add Normal "isFunction" isFunction - , add Normal "isInt" isInt - , add Normal "isList" isList - , add TopLevel "isNull" isNull - , add Normal "isString" isString - , add Normal "length" length_ - , add2 Normal "lessThan" lessThan - , add Normal "listToAttrs" listToAttrs - , add2 TopLevel "map" map_ - , add2 Normal "match" match_ - , add2 Normal "mul" mul_ - , add0 Normal "null" (return $ nvConstant NNull) - , add Normal "parseDrvName" parseDrvName - , add2 Normal "partition" partition_ - , add Normal "pathExists" pathExists_ - , add TopLevel "placeholder" placeHolder - , add Normal "readDir" readDir_ - , add Normal "readFile" readFile_ - , add2 Normal "findFile" findFile_ - , add2 TopLevel "removeAttrs" removeAttrs - , add3 Normal "replaceStrings" replaceStrings - , add2 TopLevel "scopedImport" scopedImport - , add2 Normal "seq" seq_ - , add2 Normal "sort" sort_ - , add2 Normal "split" split_ - , add Normal "splitVersion" splitVersion_ - , add0 Normal "storeDir" (return $ nvPath "/nix/store") - , add' Normal "stringLength" (arity1 Text.length) - , add' Normal "sub" (arity2 ((-) @Integer)) - , add' Normal "substring" substring - , add Normal "tail" tail_ - , add0 Normal "true" (return $ nvConstant $ NBool True) - , add TopLevel "throw" throw_ - , add' Normal "toJSON" - (arity1 $ decodeUtf8 . LBS.toStrict . A.encodingToLazyByteString - . toEncodingSorted) - , add2 Normal "toFile" toFile - , add Normal "toPath" toPath - , add TopLevel "toString" toString - , add Normal "toXML" toXML_ - , add2 TopLevel "trace" trace_ - , add Normal "tryEval" tryEval - , add Normal "typeOf" typeOf - , add Normal "unsafeDiscardStringContext" unsafeDiscardStringContext - , add2 Normal "unsafeGetAttrPos" unsafeGetAttrPos - , add Normal "valueSize" getRecursiveSize - ] - where - wrap t n f = Builtin t (n, f) - - arity1 f = Prim . pure . f - arity2 f = ((Prim . pure) .) . f - - mkThunk n = thunk . withFrame Info - (ErrorCall $ "While calling builtin " ++ Text.unpack n ++ "\n") - - add0 t n v = wrap t n <$> mkThunk n v - add t n v = wrap t n <$> mkThunk n (builtin (Text.unpack n) v) - add2 t n v = wrap t n <$> mkThunk n (builtin2 (Text.unpack n) v) - add3 t n v = wrap t n <$> mkThunk n (builtin3 (Text.unpack n) v) - - add' :: ToBuiltin m a => BuiltinType -> Text -> a -> m (Builtin m) - add' t n v = wrap t n <$> mkThunk n (toBuiltin (Text.unpack n) v) - --- Primops - -foldNixPath :: forall e m r. MonadNix e m - => (FilePath -> Maybe String -> r -> m r) -> r -> m r -foldNixPath f z = do - mres <- lookupVar @_ @(NThunk m) "__includes" - dirs <- case mres of - Nothing -> return [] - Just v -> fromNix @[Text] v - menv <- getEnvVar "NIX_PATH" - foldrM go z $ dirs ++ case menv of - Nothing -> [] - Just str -> Text.splitOn ":" (Text.pack str) - where - go x rest = case Text.splitOn "=" x of - [p] -> f (Text.unpack p) Nothing rest - [n, p] -> f (Text.unpack p) (Just (Text.unpack n)) rest - _ -> throwError $ ErrorCall $ "Unexpected entry in NIX_PATH: " ++ show x - -nixPath :: MonadNix e m => m (NValue m) -nixPath = fmap nvList $ flip foldNixPath [] $ \p mn rest -> - pure $ valueThunk - (flip nvSet mempty $ M.fromList - [ ("path", valueThunk $ nvPath p) - , ("prefix", valueThunk $ - nvStr (Text.pack (fromMaybe "" mn)) mempty) ]) : rest - -toString :: MonadNix e m => m (NValue m) -> m (NValue m) -toString str = str >>= coerceToString False >>= toNix . Text.pack - -hasAttr :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m) -hasAttr x y = - fromValue @Text x >>= \key -> - fromValue @(AttrSet (NThunk m), AttrSet SourcePos) y >>= \(aset, _) -> - toNix $ M.member key aset - -attrsetGet :: MonadNix e m => Text -> AttrSet t -> m t -attrsetGet k s = case M.lookup k s of - Just v -> pure v - Nothing -> - throwError $ ErrorCall $ "Attribute '" ++ Text.unpack k ++ "' required" - -hasContext :: MonadNix e m => m (NValue m) -> m (NValue m) -hasContext = - toNix . not . null . (appEndo ?? []) . snd <=< fromValue @(Text, DList Text) - -getAttr :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m) -getAttr x y = - fromValue @Text x >>= \key -> - fromValue @(AttrSet (NThunk m), AttrSet SourcePos) y >>= \(aset, _) -> - attrsetGet key aset >>= force' - -unsafeGetAttrPos :: forall e m. MonadNix e m - => m (NValue m) -> m (NValue m) -> m (NValue m) -unsafeGetAttrPos x y = x >>= \x' -> y >>= \y' -> case (x', y') of - (NVStr key _, NVSet _ apos) -> case M.lookup key apos of - Nothing -> pure $ nvConstant NNull - Just delta -> toValue delta - (x, y) -> throwError $ ErrorCall $ "Invalid types for builtins.unsafeGetAttrPos: " - ++ show (x, y) - --- This function is a bit special in that it doesn't care about the contents --- of the list. -length_ :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -length_ = toValue . (length :: [NThunk m] -> Int) <=< fromValue - -add_ :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m) -add_ x y = x >>= \x' -> y >>= \y' -> case (x', y') of - (NVConstant (NInt x), NVConstant (NInt y)) -> - toNix ( x + y :: Integer) - (NVConstant (NFloat x), NVConstant (NInt y)) -> toNix (x + fromInteger y) - (NVConstant (NInt x), NVConstant (NFloat y)) -> toNix (fromInteger x + y) - (NVConstant (NFloat x), NVConstant (NFloat y)) -> toNix (x + y) - (_, _) -> - throwError $ Addition x' y' - -mul_ :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m) -mul_ x y = x >>= \x' -> y >>= \y' -> case (x', y') of - (NVConstant (NInt x), NVConstant (NInt y)) -> - toNix ( x * y :: Integer) - (NVConstant (NFloat x), NVConstant (NInt y)) -> toNix (x * fromInteger y) - (NVConstant (NInt x), NVConstant (NFloat y)) -> toNix (fromInteger x * y) - (NVConstant (NFloat x), NVConstant (NFloat y)) -> toNix (x * y) - (_, _) -> - throwError $ Multiplication x' y' - -div_ :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m) -div_ x y = x >>= \x' -> y >>= \y' -> case (x', y') of - (NVConstant (NInt x), NVConstant (NInt y)) | y /= 0 -> - toNix (floor (fromInteger x / fromInteger y :: Double) :: Integer) - (NVConstant (NFloat x), NVConstant (NInt y)) | y /= 0 -> - toNix (x / fromInteger y) - (NVConstant (NInt x), NVConstant (NFloat y)) | y /= 0 -> - toNix (fromInteger x / y) - (NVConstant (NFloat x), NVConstant (NFloat y)) | y /= 0 -> - toNix (x / y) - (_, _) -> - throwError $ Division x' y' - -anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool -anyM _ [] = return False -anyM p (x:xs) = do - q <- p x - if q then return True - else anyM p xs - -any_ :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m) -any_ fun xs = fun >>= \f -> - toNix <=< anyM fromValue <=< mapM ((f `callFunc`) . force') - <=< fromValue $ xs - -allM :: Monad m => (a -> m Bool) -> [a] -> m Bool -allM _ [] = return True -allM p (x:xs) = do - q <- p x - if q then allM p xs - else return False - -all_ :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m) -all_ fun xs = fun >>= \f -> - toNix <=< allM fromValue <=< mapM ((f `callFunc`) . force') - <=< fromValue $ xs - -foldl'_ :: forall e m. MonadNix e m - => m (NValue m) -> m (NValue m) -> m (NValue m) -> m (NValue m) -foldl'_ fun z xs = - fun >>= \f -> fromValue @[NThunk m] xs >>= foldl' (go f) z - where - go f b a = f `callFunc` b >>= (`callFunc` force' a) - -head_ :: MonadNix e m => m (NValue m) -> m (NValue m) -head_ = fromValue >=> \case - [] -> throwError $ ErrorCall "builtins.head: empty list" - h:_ -> force' h - -tail_ :: MonadNix e m => m (NValue m) -> m (NValue m) -tail_ = fromValue >=> \case - [] -> throwError $ ErrorCall "builtins.tail: empty list" - _:t -> return $ nvList t - -data VersionComponent - = VersionComponent_Pre -- ^ The string "pre" - | VersionComponent_String Text -- ^ A string other than "pre" - | VersionComponent_Number Integer -- ^ A number - deriving (Show, Read, Eq, Ord) - -versionComponentToString :: VersionComponent -> Text -versionComponentToString = \case - VersionComponent_Pre -> "pre" - VersionComponent_String s -> s - VersionComponent_Number n -> Text.pack $ 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 -> [] - Just (h, t) - | h `elem` versionComponentSeparators -> splitVersion t - | isDigit h -> - let (digits, rest) = Text.span isDigit s - in VersionComponent_Number (read $ Text.unpack digits) : splitVersion rest - | otherwise -> - let (chars, rest) = Text.span (\c -> not $ isDigit c || c `elem` versionComponentSeparators) s - thisComponent = case chars of - "pre" -> VersionComponent_Pre - x -> VersionComponent_String x - in thisComponent : splitVersion rest - -splitVersion_ :: MonadNix e m => m (NValue m) -> m (NValue m) -splitVersion_ = fromValue >=> \s -> do - let vals = flip map (splitVersion s) $ \c -> - valueThunk $ nvStr (versionComponentToString c) mempty - return $ nvList vals - -compareVersions :: Text -> Text -> Ordering -compareVersions s1 s2 = - mconcat $ alignWith f (splitVersion s1) (splitVersion s2) - where - z = VersionComponent_String "" - f = uncurry compare . fromThese z z - -compareVersions_ :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m) -compareVersions_ t1 t2 = - fromValue t1 >>= \s1 -> - fromValue t2 >>= \s2 -> - return $ nvConstant $ NInt $ case compareVersions s1 s2 of - LT -> -1 - EQ -> 0 - GT -> 1 - -splitDrvName :: Text -> (Text, Text) -splitDrvName s = - let sep = "-" - pieces = Text.splitOn sep s - isFirstVersionPiece p = case Text.uncons p of - Just (h, _) | isDigit h -> True - _ -> False - -- Like 'break', but always puts the first item into the first result - -- list - breakAfterFirstItem :: (a -> Bool) -> [a] -> ([a], [a]) - breakAfterFirstItem f = \case - 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) - -parseDrvName :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -parseDrvName = fromValue >=> \(s :: Text) -> do - let (name :: Text, version :: Text) = splitDrvName s - -- jww (2018-04-15): There should be an easier way to write this. - (toValue =<<) $ sequence $ M.fromList - [ ("name" :: Text, thunk (toValue @_ @_ @(NValue m) name)) - , ("version", thunk (toValue version)) ] - -match_ :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m) -match_ pat str = - fromValue pat >>= \p -> - fromValue str >>= \s -> do - let re = makeRegex (encodeUtf8 p) :: Regex - case matchOnceText re (encodeUtf8 s) of - Just ("", sarr, "") -> do - let s = map fst (elems sarr) - nvList <$> traverse (toValue . decodeUtf8) - (if length s > 1 then tail s else s) - _ -> pure $ nvConstant NNull - -split_ :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m) -split_ pat str = - fromValue pat >>= \p -> - fromValue str >>= \s -> do - let re = makeRegex (encodeUtf8 p) :: Regex - haystack = encodeUtf8 s - return $ nvList $ - splitMatches 0 (map elems $ matchAllText re haystack) haystack - -splitMatches - :: forall e m. MonadNix e m - => Int - -> [[(ByteString, (Int, Int))]] - -> ByteString - -> [NThunk m] -splitMatches _ [] haystack = [thunkStr haystack] -splitMatches _ ([]:_) _ = error "Error 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 = valueThunk $ nvList (map f captures) - f (a,(s,_)) = if s < 0 then valueThunk (nvConstant NNull) else thunkStr a - -thunkStr s = valueThunk (nvStr (decodeUtf8 s) mempty) - -substring :: MonadNix e m => Int -> Int -> Text -> Prim m Text -substring start len str = Prim $ - if start < 0 --NOTE: negative values of 'len' are OK - then throwError $ ErrorCall $ "builtins.substring: negative start position: " ++ show start - else pure $ Text.take len $ Text.drop start str - -attrNames :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -attrNames = fromValue @(ValueSet m) >=> toNix . sort . M.keys - -attrValues :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -attrValues = fromValue @(ValueSet m) >=> - toValue . fmap snd . sortOn (fst @Text @(NThunk m)) . M.toList - -map_ :: forall e m. MonadNix e m - => m (NValue m) -> m (NValue m) -> m (NValue m) -map_ fun xs = fun >>= \f -> - toNix <=< traverse (thunk . withFrame Debug - (ErrorCall "While applying f in map:\n") - . (f `callFunc`) . force') - <=< fromValue @[NThunk m] $ xs - -filter_ :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m) -filter_ fun xs = fun >>= \f -> - toNix <=< filterM (fromValue <=< callFunc f . force') - <=< fromValue @[NThunk m] $ xs - -catAttrs :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m) -catAttrs attrName xs = - fromValue @Text attrName >>= \n -> - fromValue @[NThunk m] xs >>= \l -> - fmap (nvList . catMaybes) $ - forM l $ fmap (M.lookup n) . fromValue - -baseNameOf :: MonadNix e m => m (NValue m) -> m (NValue m) -baseNameOf x = x >>= \case - NVStr path ctx -> pure $ nvStr (Text.pack $ takeFileName $ Text.unpack path) ctx - NVPath path -> pure $ nvPath $ takeFileName path - v -> throwError $ ErrorCall $ "dirOf: expected string or path, got " ++ show v - -dirOf :: MonadNix e m => m (NValue m) -> m (NValue m) -dirOf x = x >>= \case - NVStr path ctx -> pure $ nvStr (Text.pack $ takeDirectory $ Text.unpack path) ctx - 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? -unsafeDiscardStringContext :: MonadNix e m => m (NValue m) -> m (NValue m) -unsafeDiscardStringContext = fromValue @Text >=> toNix - -seq_ :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m) -seq_ a b = a >> b - -deepSeq :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m) -deepSeq a b = do - -- We evaluate 'a' only for its effects, so data cycles are ignored. - _ <- normalFormBy (forceEffects . coerce . _baseThunk) 0 =<< a - - -- Then we evaluate the other argument to deepseq, thus this function - -- should always produce a result (unlike applying 'deepseq' on infinitely - -- recursive data structures in Haskell). - b - -elem_ :: forall e m. MonadNix e m - => m (NValue m) -> m (NValue m) -> m (NValue m) -elem_ x xs = x >>= \x' -> - toValue <=< anyM (valueEq x' <=< force') <=< fromValue @[NThunk m] $ xs - -elemAt :: [a] -> Int -> Maybe a -elemAt ls i = case drop i ls of - [] -> Nothing - a:_ -> Just a - -elemAt_ :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m) -elemAt_ xs n = fromValue n >>= \n' -> fromValue xs >>= \xs' -> - case elemAt xs' n' of - Just a -> force' a - Nothing -> throwError $ ErrorCall $ "builtins.elem: Index " ++ show n' - ++ " too large for list of length " ++ show (length xs') - -genList :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m) -genList generator = fromValue @Integer >=> \n -> - if n >= 0 - then generator >>= \f -> - toNix =<< forM [0 .. n - 1] (\i -> thunk $ f `callFunc` toNix i) - else throwError $ ErrorCall $ "builtins.genList: Expected a non-negative number, got " - ++ show n - -genericClosure :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -genericClosure = fromValue @(AttrSet (NThunk m)) >=> \s -> - 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) -> - fromValue @[NThunk m] startSet >>= \ss -> - force operator $ \op -> - toValue @[NThunk m] =<< snd <$> go op ss S.empty - where - go :: NValue m -> [NThunk m] -> Set (NValue m) - -> m (Set (NValue m), [NThunk m]) - go _ [] ks = pure (ks, []) - go op (t:ts) ks = - force t $ \v -> fromValue @(AttrSet (NThunk m)) t >>= \s -> - case M.lookup "key" s of - Nothing -> - throwError $ ErrorCall $ - "builtins.genericClosure: Attribute 'key' required" - Just k -> force k $ \k' -> - if S.member k' ks - then go op ts ks - else do - ys <- fromValue @[NThunk m] =<< (op `callFunc` pure v) - case S.toList ks of - [] -> checkComparable k' k' - j:_ -> checkComparable k' j - fmap (t:) <$> go op (ts ++ ys) (S.insert k' ks) - -replaceStrings :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m) -> m (NValue m) -replaceStrings tfrom tto ts = - fromNix tfrom >>= \(from :: [Text]) -> - fromNix tto >>= \(to :: [Text]) -> - fromValue ts >>= \(s :: Text) -> do - when (length from /= length to) $ - throwError $ ErrorCall $ - "'from' and 'to' arguments to 'replaceStrings'" - ++ " have different lengths" - let lookupPrefix s = do - (prefix, replacement) <- - find ((`Text.isPrefixOf` s) . fst) $ zip from to - let rest = Text.drop (Text.length prefix) s - return (prefix, replacement, rest) - finish = LazyText.toStrict . Builder.toLazyText - go orig result = case lookupPrefix orig of - Nothing -> case Text.uncons orig of - Nothing -> finish result - Just (h, t) -> go t $ result <> Builder.singleton h - Just (prefix, replacement, rest) -> case prefix of - "" -> case Text.uncons rest of - Nothing -> finish $ result <> Builder.fromText replacement - Just (h, t) -> go t $ mconcat - [ result - , Builder.fromText replacement - , Builder.singleton h - ] - _ -> go rest $ result <> Builder.fromText replacement - toNix $ go s mempty - -removeAttrs :: forall e m. MonadNix e m - => m (NValue m) -> m (NValue m) -> m (NValue m) -removeAttrs set = fromNix >=> \(toRemove :: [Text]) -> - fromValue @(AttrSet (NThunk m), - AttrSet SourcePos) set >>= \(m, p) -> - toNix (go m toRemove, go p toRemove) - where - go = foldl' (flip M.delete) - -intersectAttrs :: forall e m. MonadNix e m - => m (NValue m) -> m (NValue m) -> m (NValue m) -intersectAttrs set1 set2 = - fromValue @(AttrSet (NThunk m), - AttrSet SourcePos) set1 >>= \(s1, p1) -> - fromValue @(AttrSet (NThunk m), - AttrSet SourcePos) set2 >>= \(s2, p2) -> - return $ nvSet (s2 `M.intersection` s1) (p2 `M.intersection` p1) - -functionArgs :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -functionArgs fun = fun >>= \case - NVClosure p _ -> toValue @(AttrSet (NThunk m)) $ - valueThunk . nvConstant . NBool <$> - case p of - Param name -> M.singleton name False - ParamSet s _ _ -> isJust <$> M.fromList s - v -> throwError $ ErrorCall $ - "builtins.functionArgs: expected function, got " ++ show v - -toFile :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m) -toFile name s = do - name' <- fromValue name - s' <- fromValue s - mres <- toFile_ (Text.unpack name') (Text.unpack s') - toNix $ Text.pack $ unStorePath mres - -toPath :: MonadNix e m => m (NValue m) -> m (NValue m) -toPath = fromValue @Path >=> toNix @Path - -pathExists_ :: MonadNix e m => m (NValue m) -> m (NValue m) -pathExists_ path = path >>= \case - NVPath p -> toNix =<< pathExists p - NVStr s _ -> toNix =<< pathExists (Text.unpack s) - v -> throwError $ ErrorCall $ - "builtins.pathExists: expected path, got " ++ show v - -hasKind :: forall a e m. (MonadNix e m, FromValue a m (NValue m)) - => m (NValue m) -> m (NValue m) -hasKind = fromValueMay >=> toNix . \case Just (_ :: a) -> True; _ -> False - -isAttrs :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -isAttrs = hasKind @(ValueSet m) - -isList :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -isList = hasKind @[NThunk m] - -isString :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -isString = hasKind @Text - -isInt :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -isInt = hasKind @Int - -isFloat :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -isFloat = hasKind @Float - -isBool :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -isBool = hasKind @Bool - -isNull :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -isNull = hasKind @() - -isFunction :: MonadNix e m => m (NValue m) -> m (NValue m) -isFunction func = func >>= \case - NVClosure {} -> toValue True - _ -> toValue False - -throw_ :: MonadNix e m => m (NValue m) -> m (NValue m) -throw_ = fromValue >=> throwError . ErrorCall . Text.unpack - -import_ :: MonadNix e m => m (NValue m) -> m (NValue m) -import_ = fromValue >=> importPath M.empty . getPath - -scopedImport :: forall e m. MonadNix e m - => m (NValue m) -> m (NValue m) -> m (NValue m) -scopedImport aset path = - fromValue aset >>= \s -> - fromValue path >>= \p -> importPath @m s (getPath p) - -getEnv_ :: MonadNix e m => m (NValue m) -> m (NValue m) -getEnv_ = fromValue >=> \s -> do - mres <- getEnvVar (Text.unpack s) - toNix $ case mres of - Nothing -> "" - Just v -> Text.pack v - -sort_ :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m) -sort_ comparator xs = comparator >>= \comp -> - fromValue xs >>= sortByM (cmp comp) >>= toValue - where - cmp f a b = do - isLessThan <- f `callFunc` force' a >>= (`callFunc` force' b) - fromValue isLessThan >>= \case - True -> pure LT - False -> do - isGreaterThan <- f `callFunc` force' b >>= (`callFunc` force' a) - fromValue isGreaterThan <&> \case - True -> GT - False -> EQ - -lessThan :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m) -lessThan ta tb = ta >>= \va -> tb >>= \vb -> do - let badType = throwError $ ErrorCall $ - "builtins.lessThan: expected two numbers or two strings, " - ++ "got " ++ show va ++ " and " ++ show vb - nvConstant . NBool <$> case (va, vb) of - (NVConstant ca, NVConstant cb) -> case (ca, cb) of - (NInt a, NInt b) -> pure $ a < b - (NFloat a, NInt b) -> pure $ a < fromInteger b - (NInt a, NFloat b) -> pure $ fromInteger a < b - (NFloat a, NFloat b) -> pure $ a < b - _ -> badType - (NVStr a _, NVStr b _) -> pure $ a < b - _ -> badType - -concatLists :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -concatLists = fromValue @[NThunk m] - >=> mapM (fromValue @[NThunk m] >=> pure) - >=> toValue . concat - -listToAttrs :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -listToAttrs = fromValue @[NThunk m] >=> \l -> - fmap (flip nvSet M.empty . M.fromList . reverse) $ - forM l $ fromValue @(AttrSet (NThunk m)) >=> \s -> do - name <- attrsetGet "name" s - val <- attrsetGet "value" s - fromValue name <&> (, val) - -hashString :: MonadNix e m => Text -> Text -> Prim m Text -hashString algo s = Prim $ do - case algo of - "md5" -> pure $ -#if MIN_VERSION_hashing(0, 1, 0) - Text.pack $ show (hash (encodeUtf8 s) :: MD5.MD5) -#else - decodeUtf8 $ Base16.encode $ MD5.hash $ encodeUtf8 s -#endif - "sha1" -> pure $ -#if MIN_VERSION_hashing(0, 1, 0) - Text.pack $ show (hash (encodeUtf8 s) :: SHA1.SHA1) -#else - decodeUtf8 $ Base16.encode $ SHA1.hash $ encodeUtf8 s -#endif - "sha256" -> pure $ -#if MIN_VERSION_hashing(0, 1, 0) - Text.pack $ show (hash (encodeUtf8 s) :: SHA256.SHA256) -#else - decodeUtf8 $ Base16.encode $ SHA256.hash $ encodeUtf8 s -#endif - "sha512" -> pure $ -#if MIN_VERSION_hashing(0, 1, 0) - Text.pack $ show (hash (encodeUtf8 s) :: SHA512.SHA512) -#else - decodeUtf8 $ Base16.encode $ SHA512.hash $ encodeUtf8 s -#endif - _ -> throwError $ ErrorCall $ "builtins.hashString: " - ++ "expected \"md5\", \"sha1\", \"sha256\", or \"sha512\", got " ++ show algo - -placeHolder :: MonadNix e m => m (NValue m) -> m (NValue m) -placeHolder = fromValue @Text >=> \_ -> do - h <- runPrim (hashString "sha256" "fdasdfas") - toNix h - -absolutePathFromValue :: MonadNix e m => NValue m -> m FilePath -absolutePathFromValue = \case - NVStr pathText _ -> do - let path = Text.unpack pathText - 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 - -readFile_ :: MonadNix e m => m (NValue m) -> m (NValue m) -readFile_ path = - path >>= absolutePathFromValue >>= Nix.Render.readFile >>= toNix - -findFile_ :: forall e m. MonadNix e m - => m (NValue m) -> m (NValue m) -> m (NValue m) -findFile_ aset filePath = - aset >>= \aset' -> - filePath >>= \filePath' -> - case (aset', filePath') of - (NVList x, NVStr name _) -> do - mres <- findPath x (Text.unpack name) - pure $ nvPath mres - (NVList _, y) -> throwError $ ErrorCall $ "expected a string, got " ++ show y - (x, NVStr _ _) -> throwError $ ErrorCall $ "expected a list, got " ++ show x - (x, y) -> throwError $ ErrorCall $ "Invalid types for builtins.findFile: " ++ show (x, y) - -data FileType - = FileTypeRegular - | FileTypeDirectory - | FileTypeSymlink - | FileTypeUnknown - deriving (Show, Read, Eq, Ord) - -instance Applicative m => ToNix FileType m (NValue m) where - toNix = toNix . \case - FileTypeRegular -> "regular" :: Text - FileTypeDirectory -> "directory" - FileTypeSymlink -> "symlink" - FileTypeUnknown -> "unknown" - -readDir_ :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -readDir_ pathThunk = do - path <- absolutePathFromValue =<< pathThunk - items <- listDirectory path - itemsWithTypes <- forM items $ \item -> do - s <- Nix.Effects.getSymbolicLinkStatus $ path item - let t = if - | isRegularFile s -> FileTypeRegular - | isDirectory s -> FileTypeDirectory - | isSymbolicLink s -> FileTypeSymlink - | otherwise -> FileTypeUnknown - pure (Text.pack item, t) - toNix (M.fromList itemsWithTypes) - -fromJSON :: MonadNix e m => m (NValue m) -> m (NValue m) -fromJSON = fromValue >=> \encoded -> - case A.eitherDecodeStrict' @A.Value $ encodeUtf8 encoded of - Left jsonError -> - throwError $ ErrorCall $ "builtins.fromJSON: " ++ jsonError - Right v -> toValue v - -toXML_ :: MonadNix e m => m (NValue m) -> m (NValue m) -toXML_ v = v >>= normalForm >>= \x -> - pure $ nvStr (Text.pack (toXML x)) mempty - -typeOf :: MonadNix e m => m (NValue m) -> m (NValue m) -typeOf v = v >>= toNix @Text . \case - NVConstant a -> case a of - 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" - -tryEval :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -tryEval e = catch (onSuccess <$> e) (pure . onError) - where - onSuccess v = flip nvSet M.empty $ M.fromList - [ ("success", valueThunk (nvConstant (NBool True))) - , ("value", valueThunk v) - ] - - onError :: SomeException -> NValue m - onError _ = flip nvSet M.empty $ M.fromList - [ ("success", valueThunk (nvConstant (NBool False))) - , ("value", valueThunk (nvConstant (NBool False))) - ] - -trace_ :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m) -trace_ msg action = do - traceEffect . Text.unpack =<< fromValue @Text msg - action - -exec_ :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -exec_ xs = do - ls <- fromValue @[NThunk m] xs - xs <- traverse (fromValue @Text . force') ls - exec (map Text.unpack xs) - -fetchTarball :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -fetchTarball v = v >>= \case - NVSet s _ -> case M.lookup "url" s of - Nothing -> throwError $ ErrorCall - "builtins.fetchTarball: Missing url attribute" - Just url -> force url $ go (M.lookup "sha256" s) - v@NVStr {} -> go Nothing v - v -> throwError $ ErrorCall $ - "builtins.fetchTarball: Expected URI or set, got " ++ show v - where - go :: Maybe (NThunk m) -> NValue m -> m (NValue m) - go msha = \case - NVStr uri _ -> fetch uri 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 m) - fetch uri msha = case takeExtension (Text.unpack uri) of - ".tgz" -> undefined - ".gz" -> undefined - ".bz2" -> undefined - ".xz" -> undefined - ".tar" -> undefined - ext -> throwError $ ErrorCall $ "builtins.fetchTarball: Unsupported extension '" - ++ ext ++ "'" --} - - fetch :: Text -> Maybe (NThunk m) -> m (NValue m) - fetch uri Nothing = - nixInstantiateExpr $ "builtins.fetchTarball \"" ++ - Text.unpack uri ++ "\"" - fetch url (Just m) = fromValue m >>= \sha -> - nixInstantiateExpr $ "builtins.fetchTarball { " - ++ "url = \"" ++ Text.unpack url ++ "\"; " - ++ "sha256 = \"" ++ Text.unpack sha ++ "\"; }" - -fetchurl :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -fetchurl v = v >>= \case - NVSet s _ -> attrsetGet "url" s >>= force ?? (go (M.lookup "sha256" s)) - v@NVStr {} -> go Nothing v - v -> throwError $ ErrorCall $ "builtins.fetchurl: Expected URI or set, got " - ++ show v - where - go :: Maybe (NThunk m) -> NValue m -> m (NValue m) - go _msha = \case - NVStr uri _ -> getURL uri -- msha - v -> throwError $ ErrorCall $ - "builtins.fetchurl: Expected URI or string, got " ++ show v - -partition_ :: forall e m. MonadNix e m - => m (NValue m) -> m (NValue m) -> m (NValue m) -partition_ fun xs = fun >>= \f -> - fromValue @[NThunk m] xs >>= \l -> do - let match t = f `callFunc` force' t >>= fmap (, t) . fromValue - selection <- traverse match l - let (right, wrong) = partition fst selection - let makeSide = valueThunk . nvList . map snd - toValue @(AttrSet (NThunk m)) $ - M.fromList [("right", makeSide right), ("wrong", makeSide wrong)] - -currentSystem :: MonadNix e m => m (NValue m) -currentSystem = do - os <- getCurrentSystemOS - arch <- getCurrentSystemArch - return $ nvStr (arch <> "-" <> os) mempty - -currentTime_ :: MonadNix e m => m (NValue m) -currentTime_ = do - opts :: Options <- asks (view hasLens) - toNix @Integer $ round $ Time.utcTimeToPOSIXSeconds (currentTime opts) - -derivationStrict_ :: MonadNix e m => m (NValue m) -> m (NValue m) -derivationStrict_ = (>>= derivationStrict) - -newtype Prim m a = Prim { runPrim :: m a } - --- | Types that support conversion to nix in a particular monad -class ToBuiltin m a | a -> m where - toBuiltin :: String -> a -> m (NValue m) - -instance (MonadNix e m, ToNix a m (NValue m)) - => ToBuiltin m (Prim m a) where - toBuiltin _ p = toNix =<< runPrim p - -instance (MonadNix e m, FromNix a m (NValue m), ToBuiltin m b) - => ToBuiltin m (a -> b) where - toBuiltin name f = return $ nvBuiltin name (fromNix >=> toBuiltin name . f) +module Nix.Builtins (withNixContext, builtins) where + +import Control.Comonad +import Control.Monad +import Control.Monad.Catch +import Control.Monad.ListM ( sortByM ) +import Control.Monad.Reader ( asks ) + +-- Using package imports here because there is a bug in cabal2nix that forces +-- us to put the hashing package in the unconditional dependency list. +-- See https://github.com/NixOS/cabal2nix/issues/348 for more info +#if MIN_VERSION_hashing(0, 1, 0) +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 +#else +import qualified "cryptohash-md5" Crypto.Hash.MD5 as MD5 +import qualified "cryptohash-sha1" Crypto.Hash.SHA1 as SHA1 +import qualified "cryptohash-sha256" Crypto.Hash.SHA256 as SHA256 +import qualified "cryptohash-sha512" Crypto.Hash.SHA512 as SHA512 +#endif + +import qualified Data.Aeson as A +import Data.Align ( alignWith ) +import Data.Array +import Data.Bits +import Data.ByteString ( ByteString ) +import qualified Data.ByteString as B +import Data.ByteString.Base16 as Base16 +import Data.Char ( isDigit ) +import Data.Fix +import Data.Foldable ( foldrM ) +import qualified Data.HashMap.Lazy as M +import Data.List +import Data.Maybe +import Data.Scientific +import Data.Set ( Set ) +import qualified Data.Set as S +import Data.String.Interpolate.IsString +import Data.Text ( Text ) +import qualified Data.Text as Text +import Data.Text.Encoding +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 Data.Traversable ( for + , mapM + ) +import qualified Data.Vector as V +import Nix.Atoms +import Nix.Convert +import Nix.Effects +import qualified Nix.Eval as Eval +import Nix.Exec +import Nix.Expr.Types +import Nix.Expr.Types.Annotated +import Nix.Frames +import Nix.Json +import Nix.Normal +import Nix.Options +import Nix.Parser hiding ( nixPath ) +import Nix.Render +import Nix.Scope +import Nix.String +import Nix.Thunk +import Nix.Utils +import Nix.Value +import Nix.Value.Equal +import Nix.XML +import System.Nix.Internal.Hash ( printHashBytes32 ) +import System.FilePath +import System.Posix.Files ( isRegularFile + , isDirectory + , isSymbolicLink + ) +import Text.Read +import Text.Regex.TDFA + +-- | Evaluate a nix expression in the default context +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 = wrapValue @t @m @(NValue t f m) $ nvList $ map + ( wrapValue @t @m @(NValue t f m) + . nvStr + . hackyMakeNixStringWithoutContext + . Text.pack + ) + (include opts) + pushScope (M.singleton "__includes" i) $ pushScopes base $ case mpath of + Nothing -> action + Just path -> do + traceM $ "Setting __cur_file = " ++ show path + let ref = wrapValue @t @m @(NValue t f m) $ nvPath path + pushScope (M.singleton "__cur_file" ref) action + +builtins :: (MonadNix e t f m, Scoped t m) => m (Scopes m t) +builtins = do + ref <- thunk $ flip nvSet M.empty <$> buildMap + lst <- ([("builtins", ref)] ++) <$> topLevelBuiltins + pushScope (M.fromList lst) currentScopes + where + buildMap = M.fromList . map mapping <$> builtinsList + topLevelBuiltins = map mapping <$> fullBuiltinsList + + fullBuiltinsList = map go <$> builtinsList + where + go b@(Builtin TopLevel _) = b + go (Builtin Normal (name, builtin)) = + Builtin TopLevel ("__" <> name, builtin) + +data BuiltinType = Normal | TopLevel +data Builtin t = Builtin + { _kind :: BuiltinType + , mapping :: (Text, t) + } + +valueThunk :: forall e t f m . MonadNix e t f m => NValue t f m -> t +valueThunk = wrapValue @_ @m + +force' :: forall e t f m . MonadNix e t f m => t -> m (NValue t f m) +force' = force ?? pure + +builtinsList :: forall e t f m . MonadNix e t f m => m [Builtin t] +builtinsList = sequence + [ do + version <- toValue (principledMakeNixStringWithoutContext "2.0") + pure $ Builtin Normal ("nixVersion", wrapValue version) + , do + version <- toValue (5 :: Int) + pure $ Builtin Normal ("langVersion", wrapValue version) + + , add0 Normal "nixPath" nixPath + , add TopLevel "abort" throw_ -- for now + , add2 Normal "add" add_ + , add2 Normal "addErrorContext" addErrorContext + , add2 Normal "all" all_ + , add2 Normal "any" any_ + , add Normal "attrNames" attrNames + , add Normal "attrValues" attrValues + , add TopLevel "baseNameOf" baseNameOf + , add2 Normal "bitAnd" bitAnd + , add2 Normal "bitOr" bitOr + , add2 Normal "bitXor" bitXor + , add2 Normal "catAttrs" catAttrs + , add2 Normal "compareVersions" compareVersions_ + , add Normal "concatLists" concatLists + , add' Normal "concatStringsSep" (arity2 principledIntercalateNixString) + , add0 Normal "currentSystem" currentSystem + , add0 Normal "currentTime" currentTime_ + , add2 Normal "deepSeq" deepSeq + + -- This is compiled in so that we only parse and evaluate it once, at + -- compile-time. + , add0 TopLevel "derivation" $(do + let Success expr = parseNixText [i| + drvAttrs @ { outputs ? [ "out" ], ... }: + + let + + strict = derivationStrict drvAttrs; + + commonAttrs = drvAttrs // (builtins.listToAttrs outputsList) // + { all = map (x: x.value) outputsList; + inherit drvAttrs; + }; + + outputToAttrListElement = outputName: + { name = outputName; + value = commonAttrs // { + outPath = builtins.getAttr outputName strict; + drvPath = strict.drvPath; + type = "derivation"; + inherit outputName; + }; + }; + + outputsList = map outputToAttrListElement outputs; + + in (builtins.head outputsList).value|] + [| cata Eval.eval expr |] + ) + + , add TopLevel "derivationStrict" derivationStrict_ + , add TopLevel "dirOf" dirOf + , add2 Normal "div" div_ + , add2 Normal "elem" elem_ + , add2 Normal "elemAt" elemAt_ + , add Normal "exec" exec_ + , add0 Normal "false" (return $ nvConstant $ NBool False) + , add Normal "fetchTarball" fetchTarball + , add Normal "fetchurl" fetchurl + , add2 Normal "filter" filter_ + , add3 Normal "foldl'" foldl'_ + , add Normal "fromJSON" fromJSON + , add Normal "functionArgs" functionArgs + , add2 Normal "genList" genList + , add Normal "genericClosure" genericClosure + , add2 Normal "getAttr" getAttr + , add Normal "getEnv" getEnv_ + , add2 Normal "hasAttr" hasAttr + , add Normal "hasContext" hasContext + , add' Normal "hashString" hashString + , add Normal "head" head_ + , add TopLevel "import" import_ + , add2 Normal "intersectAttrs" intersectAttrs + , add Normal "isAttrs" isAttrs + , add Normal "isBool" isBool + , add Normal "isFloat" isFloat + , add Normal "isFunction" isFunction + , add Normal "isInt" isInt + , add Normal "isList" isList + , add TopLevel "isNull" isNull + , add Normal "isString" isString + , add Normal "length" length_ + , add2 Normal "lessThan" lessThan + , add Normal "listToAttrs" listToAttrs + , add2 TopLevel "map" map_ + , add2 TopLevel "mapAttrs" mapAttrs_ + , add2 Normal "match" match_ + , add2 Normal "mul" mul_ + , add0 Normal "null" (return $ nvConstant NNull) + , add Normal "parseDrvName" parseDrvName + , add2 Normal "partition" partition_ + , add Normal "pathExists" pathExists_ + , add TopLevel "placeholder" placeHolder + , add Normal "readDir" readDir_ + , add Normal "readFile" readFile_ + , add2 Normal "findFile" findFile_ + , add2 TopLevel "removeAttrs" removeAttrs + , add3 Normal "replaceStrings" replaceStrings + , add2 TopLevel "scopedImport" scopedImport + , add2 Normal "seq" seq_ + , add2 Normal "sort" sort_ + , add2 Normal "split" split_ + , add Normal "splitVersion" splitVersion_ + , add0 Normal "storeDir" (return $ nvStr $ principledMakeNixStringWithoutContext "/nix/store") + , add' Normal "stringLength" (arity1 $ Text.length . principledStringIgnoreContext) + , add' Normal "sub" (arity2 ((-) @Integer)) + , add' Normal "substring" substring + , add Normal "tail" tail_ + , add0 Normal "true" (return $ nvConstant $ NBool True) + , add TopLevel "throw" throw_ + , add Normal "toJSON" prim_toJSON + , add2 Normal "toFile" toFile + , add Normal "toPath" toPath + , add TopLevel "toString" toString + , add Normal "toXML" toXML_ + , add2 TopLevel "trace" trace_ + , add Normal "tryEval" tryEval + , add Normal "typeOf" typeOf + , add Normal "valueSize" getRecursiveSize + , add Normal "getContext" getContext + , add2 Normal "appendContext" appendContext + + , add2 Normal "unsafeGetAttrPos" unsafeGetAttrPos + , add Normal "unsafeDiscardStringContext" unsafeDiscardStringContext + ] + where + wrap t n f = Builtin t (n, f) + + arity1 f = Prim . pure . f + arity2 f = ((Prim . pure) .) . f + + mkThunk n = thunk . withFrame + Info + (ErrorCall $ "While calling builtin " ++ Text.unpack n ++ "\n") + + add0 t n v = wrap t n <$> mkThunk n v + add t n v = wrap t n <$> mkThunk n (builtin (Text.unpack n) v) + add2 t n v = wrap t n <$> mkThunk n (builtin2 (Text.unpack n) v) + add3 t n v = wrap t n <$> mkThunk n (builtin3 (Text.unpack n) v) + + add' :: ToBuiltin t f m a => BuiltinType -> Text -> a -> m (Builtin t) + add' t n v = wrap t n <$> mkThunk n (toBuiltin (Text.unpack n) v) + +-- Primops + +foldNixPath + :: forall e t f m r + . MonadNix e t f m + => (FilePath -> Maybe String -> NixPathEntryType -> r -> m r) + -> r + -> m r +foldNixPath f z = do + mres <- lookupVar "__includes" + dirs <- case mres of + Nothing -> return [] + Just v -> force v fromNix + menv <- getEnvVar "NIX_PATH" + foldrM go z + $ map (fromInclude . principledStringIgnoreContext) dirs + ++ case menv of + Nothing -> [] + Just str -> uriAwareSplit (Text.pack str) + where + fromInclude x | "://" `Text.isInfixOf` x = (x, PathEntryURI) + | otherwise = (x, PathEntryPath) + go (x, ty) rest = case Text.splitOn "=" x of + [p] -> f (Text.unpack p) Nothing ty rest + [n, p] -> f (Text.unpack p) (Just (Text.unpack n)) ty rest + _ -> throwError $ ErrorCall $ "Unexpected entry in NIX_PATH: " ++ show x + +nixPath :: MonadNix e t f m => m (NValue t f m) +nixPath = fmap nvList $ flip foldNixPath [] $ \p mn ty rest -> + pure + $ valueThunk + (flip nvSet mempty $ M.fromList + [ case ty of + PathEntryPath -> ("path", valueThunk $ nvPath p) + PathEntryURI -> + ( "uri" + , valueThunk + $ nvStr (hackyMakeNixStringWithoutContext (Text.pack p)) + ) + , ( "prefix" + , valueThunk $ nvStr + (hackyMakeNixStringWithoutContext $ Text.pack (fromMaybe "" mn)) + ) + ] + ) + : rest + +toString :: MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +toString str = str >>= coerceToString DontCopyToStore CoerceAny >>= toNix + +hasAttr + :: forall e t f m + . MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +hasAttr x y = fromValue x >>= fromStringNoContext >>= \key -> + fromValue @(AttrSet t, AttrSet SourcePos) y + >>= \(aset, _) -> toNix $ M.member key aset + +attrsetGet :: MonadNix e t f m => Text -> AttrSet t -> m t +attrsetGet k s = case M.lookup k s of + Just v -> pure v + Nothing -> + throwError $ ErrorCall $ "Attribute '" ++ Text.unpack k ++ "' required" + +hasContext :: MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +hasContext = toNix . stringHasContext <=< fromValue + +getAttr + :: forall e t f m + . MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +getAttr x y = fromValue x >>= fromStringNoContext >>= \key -> + fromValue @(AttrSet t, AttrSet SourcePos) y + >>= \(aset, _) -> attrsetGet key aset >>= force' + +unsafeGetAttrPos + :: forall e t f m + . MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +unsafeGetAttrPos x y = x >>= \x' -> y >>= \y' -> case (x', y') of + (NVStr ns, NVSet _ apos) -> + case M.lookup (hackyStringIgnoreContext ns) apos of + Nothing -> pure $ nvConstant NNull + Just delta -> toValue delta + (x, y) -> + throwError + $ ErrorCall + $ "Invalid types for builtins.unsafeGetAttrPos: " + ++ show (x, y) + +-- This function is a bit special in that it doesn't care about the contents +-- of the list. +length_ + :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +length_ = toValue . (length :: [t] -> Int) <=< fromValue + +add_ + :: MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +add_ x y = x >>= \x' -> y >>= \y' -> case (x', y') of + (NVConstant (NInt x), NVConstant (NInt y) ) -> toNix (x + y :: Integer) + (NVConstant (NFloat x), NVConstant (NInt y) ) -> toNix (x + fromInteger y) + (NVConstant (NInt x), NVConstant (NFloat y)) -> toNix (fromInteger x + y) + (NVConstant (NFloat x), NVConstant (NFloat y)) -> toNix (x + y) + (_ , _ ) -> throwError $ Addition x' y' + +mul_ + :: MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +mul_ x y = x >>= \x' -> y >>= \y' -> case (x', y') of + (NVConstant (NInt x), NVConstant (NInt y) ) -> toNix (x * y :: Integer) + (NVConstant (NFloat x), NVConstant (NInt y) ) -> toNix (x * fromInteger y) + (NVConstant (NInt x), NVConstant (NFloat y)) -> toNix (fromInteger x * y) + (NVConstant (NFloat x), NVConstant (NFloat y)) -> toNix (x * y) + (_, _) -> throwError $ Multiplication x' y' + +div_ + :: MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +div_ x y = x >>= \x' -> y >>= \y' -> case (x', y') of + (NVConstant (NInt x), NVConstant (NInt y)) | y /= 0 -> + toNix (floor (fromInteger x / fromInteger y :: Double) :: Integer) + (NVConstant (NFloat x), NVConstant (NInt y)) | y /= 0 -> + toNix (x / fromInteger y) + (NVConstant (NInt x), NVConstant (NFloat y)) | y /= 0 -> + toNix (fromInteger x / y) + (NVConstant (NFloat x), NVConstant (NFloat y)) | y /= 0 -> toNix (x / y) + (_, _) -> throwError $ Division x' y' + +anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool +anyM _ [] = return False +anyM p (x : xs) = do + q <- p x + if q then return True else anyM p xs + +any_ + :: MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +any_ fun xs = fun >>= \f -> + toNix <=< anyM fromValue <=< mapM ((f `callFunc`) . force') <=< fromValue $ xs + +allM :: Monad m => (a -> m Bool) -> [a] -> m Bool +allM _ [] = return True +allM p (x : xs) = do + q <- p x + if q then allM p xs else return False + +all_ + :: MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +all_ fun xs = fun >>= \f -> + toNix <=< allM fromValue <=< mapM ((f `callFunc`) . force') <=< fromValue $ xs + +foldl'_ + :: forall e t f m + . MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +foldl'_ fun z xs = fun >>= \f -> fromValue @[t] xs >>= foldl' (go f) z + where go f b a = f `callFunc` b >>= (`callFunc` force' a) + +head_ :: MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +head_ = fromValue >=> \case + [] -> throwError $ ErrorCall "builtins.head: empty list" + h : _ -> force' h + +tail_ :: MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +tail_ = fromValue >=> \case + [] -> throwError $ ErrorCall "builtins.tail: empty list" + _ : t -> return $ nvList t + +data VersionComponent + = VersionComponent_Pre -- ^ The string "pre" + | VersionComponent_String Text -- ^ A string other than "pre" + | VersionComponent_Number Integer -- ^ A number + deriving (Show, Read, Eq, Ord) + +versionComponentToString :: VersionComponent -> Text +versionComponentToString = \case + VersionComponent_Pre -> "pre" + VersionComponent_String s -> s + VersionComponent_Number n -> Text.pack $ 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 -> [] + Just (h, t) + | h `elem` versionComponentSeparators + -> splitVersion t + | isDigit h + -> let (digits, rest) = Text.span isDigit s + in + VersionComponent_Number + (fromMaybe (error $ "splitVersion: couldn't parse " <> show digits) + $ readMaybe + $ Text.unpack digits + ) + : splitVersion rest + | otherwise + -> let (chars, rest) = Text.span + (\c -> not $ isDigit c || c `elem` versionComponentSeparators) + s + thisComponent = case chars of + "pre" -> VersionComponent_Pre + x -> VersionComponent_String x + in thisComponent : splitVersion rest + +splitVersion_ :: MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +splitVersion_ = fromValue >=> fromStringNoContext >=> \s -> + return + $ nvList + $ flip map (splitVersion s) + $ valueThunk + . nvStr + . principledMakeNixStringWithoutContext + . versionComponentToString + +compareVersions :: Text -> Text -> Ordering +compareVersions s1 s2 = mconcat + $ alignWith f (splitVersion s1) (splitVersion s2) + where + z = VersionComponent_String "" + f = uncurry compare . fromThese z z + +compareVersions_ + :: MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +compareVersions_ t1 t2 = fromValue t1 >>= fromStringNoContext >>= \s1 -> + fromValue t2 >>= fromStringNoContext >>= \s2 -> + return $ nvConstant $ NInt $ case compareVersions s1 s2 of + LT -> -1 + EQ -> 0 + GT -> 1 + +splitDrvName :: Text -> (Text, Text) +splitDrvName s = + let + sep = "-" + pieces = Text.splitOn sep s + isFirstVersionPiece p = case Text.uncons p of + Just (h, _) | isDigit h -> True + _ -> False + -- Like 'break', but always puts the first item into the first result + -- list + breakAfterFirstItem :: (a -> Bool) -> [a] -> ([a], [a]) + breakAfterFirstItem f = \case + 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) + +parseDrvName + :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +parseDrvName = fromValue >=> fromStringNoContext >=> \s -> do + let (name :: Text, version :: Text) = splitDrvName s + -- jww (2018-04-15): There should be an easier way to write this. + (toValue =<<) $ sequence $ M.fromList + [ ( "name" :: Text + , thunk @t (toValue $ principledMakeNixStringWithoutContext name) + ) + , ( "version" + , thunk @t (toValue $ principledMakeNixStringWithoutContext version) + ) + ] + +match_ + :: forall e t f m + . MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +match_ pat str = fromValue pat >>= fromStringNoContext >>= \p -> + fromValue str >>= \ns -> do + -- NOTE: 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 = principledStringIgnoreContext ns + + let re = makeRegex (encodeUtf8 p) :: Regex + let mkMatch t + | Text.null t = toValue () + | -- Shorthand for Null + otherwise = toValue $ principledMakeNixStringWithoutContext t + case matchOnceText re (encodeUtf8 s) of + Just ("", sarr, "") -> do + let s = map fst (elems sarr) + nvList <$> traverse (fmap wrapValue . mkMatch . decodeUtf8) + (if length s > 1 then tail s else s) + _ -> pure $ nvConstant NNull + +split_ + :: forall e t f m + . MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +split_ pat str = fromValue pat >>= fromStringNoContext >>= \p -> + fromValue str >>= \ns -> do + -- 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 = principledStringIgnoreContext ns + let re = makeRegex (encodeUtf8 p) :: Regex + haystack = encodeUtf8 s + return $ nvList $ splitMatches 0 + (map elems $ matchAllText re haystack) + haystack + +splitMatches + :: forall e t f m + . MonadNix e t f m + => Int + -> [[(ByteString, (Int, Int))]] + -> ByteString + -> [t] +splitMatches _ [] haystack = [thunkStr haystack] +splitMatches _ ([] : _) _ = + error "Error 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 = valueThunk $ nvList (map f captures) + f (a, (s, _)) = if s < 0 then valueThunk (nvConstant NNull) else thunkStr a + +thunkStr s = + valueThunk (nvStr (hackyMakeNixStringWithoutContext (decodeUtf8 s))) + +substring :: MonadNix e t f m => Int -> Int -> NixString -> Prim m NixString +substring start len str = Prim $ if start < 0 --NOTE: negative values of 'len' are OK + then + throwError + $ ErrorCall + $ "builtins.substring: negative start position: " + ++ show start + else pure $ principledModifyNixContents (Text.take len . Text.drop start) str + +attrNames + :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +attrNames = + fromValue @(AttrSet t) + >=> toNix + . map principledMakeNixStringWithoutContext + . sort + . M.keys + +attrValues + :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +attrValues = + fromValue @(AttrSet t) + >=> toValue + . fmap snd + . sortOn (fst @Text @t) + . M.toList + +map_ + :: forall e t f m + . MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +map_ fun xs = fun >>= \f -> + toValue + <=< traverse + ( thunk @t + . withFrame Debug (ErrorCall "While applying f in map:\n") + . (f `callFunc`) + . force' + ) + <=< fromValue @[t] + $ xs + +mapAttrs_ + :: forall e t f m + . MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +mapAttrs_ fun xs = fun >>= \f -> fromValue @(AttrSet t) xs >>= \aset -> do + let pairs = M.toList aset + values <- for pairs $ \(key, value) -> + thunk @t + $ withFrame Debug (ErrorCall "While applying f in mapAttrs:\n") + $ callFunc + ?? force' value + =<< callFunc f (pure (nvStr (principledMakeNixStringWithoutContext key))) + toValue . M.fromList . zip (map fst pairs) $ values + +filter_ + :: forall e t f m + . MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +filter_ fun xs = fun >>= \f -> + toValue + <=< filterM (fromValue <=< callFunc f . force') + <=< fromValue @[t] + $ xs + +catAttrs + :: forall e t f m + . MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +catAttrs attrName xs = fromValue attrName >>= fromStringNoContext >>= \n -> + fromValue @[t] xs >>= \l -> + fmap (nvList . catMaybes) + $ forM l + $ fmap (M.lookup n) + . flip force fromValue + +baseNameOf :: MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +baseNameOf x = do + ns <- coerceToString DontCopyToStore CoerceStringy =<< x + pure $ nvStr + (principledModifyNixContents (Text.pack . takeFileName . Text.unpack) ns) + +bitAnd + :: forall e t f m + . MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +bitAnd x y = + fromValue @Integer x >>= \a -> fromValue @Integer y >>= \b -> toNix (a .&. b) + +bitOr + :: forall e t f m + . MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +bitOr x y = + fromValue @Integer x >>= \a -> fromValue @Integer y >>= \b -> toNix (a .|. b) + +bitXor + :: forall e t f m + . MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +bitXor x y = fromValue @Integer x + >>= \a -> fromValue @Integer y >>= \b -> toNix (a `xor` b) + +dirOf :: MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +dirOf x = x >>= \case + NVStr ns -> pure $ nvStr + (principledModifyNixContents (Text.pack . takeDirectory . Text.unpack) 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? +unsafeDiscardStringContext + :: MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +unsafeDiscardStringContext mnv = do + ns <- fromValue mnv + toNix $ principledMakeNixStringWithoutContext $ principledStringIgnoreContext + ns + +seq_ + :: MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +seq_ a b = a >> b + +deepSeq + :: MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +deepSeq a b = do + -- We evaluate 'a' only for its effects, so data cycles are ignored. + normalForm_ =<< a + + -- Then we evaluate the other argument to deepseq, thus this function + -- should always produce a result (unlike applying 'deepseq' on infinitely + -- recursive data structures in Haskell). + b + +elem_ + :: forall e t f m + . MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +elem_ x xs = x >>= \x' -> + toValue <=< anyM (valueEqM x' <=< force') <=< fromValue @[t] $ xs + +elemAt :: [a] -> Int -> Maybe a +elemAt ls i = case drop i ls of + [] -> Nothing + a : _ -> Just a + +elemAt_ + :: MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +elemAt_ xs n = fromValue n >>= \n' -> fromValue xs >>= \xs' -> + case elemAt xs' n' of + Just a -> force' a + Nothing -> + throwError + $ ErrorCall + $ "builtins.elem: Index " + ++ show n' + ++ " too large for list of length " + ++ show (length xs') + +genList + :: forall e t f m + . MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +genList generator = fromValue @Integer >=> \n -> if n >= 0 + then generator >>= \f -> + toValue =<< forM [0 .. n - 1] (\i -> thunk @t $ f `callFunc` toNix i) + else + throwError + $ ErrorCall + $ "builtins.genList: Expected a non-negative number, got " + ++ show n + +-- We wrap values solely to provide an Ord instance for genericClosure +newtype WValue t f m a = WValue (NValue' t f m a) + +instance Comonad f => Eq (WValue t f m a) 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) = + hackyStringIgnoreContext x == hackyStringIgnoreContext y + _ == _ = False + +instance Comonad f => Ord (WValue t f m a) 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) = + hackyStringIgnoreContext x <= hackyStringIgnoreContext y + _ <= _ = False + +genericClosure + :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +genericClosure = fromValue @(AttrSet t) >=> \s -> + 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) -> + force startSet $ fromValue @[t] >=> \ss -> + force operator $ \op -> toValue @[t] =<< snd <$> go op ss S.empty + where + go + :: NValue t f m + -> [t] + -> Set (WValue t f m t) + -> m (Set (WValue t f m t), [t]) + go _ [] ks = pure (ks, []) + go op (t : ts) ks = force t $ \v -> fromValue @(AttrSet t) v >>= \s -> do + k <- attrsetGet "key" s + force k $ \k' -> do + if S.member (WValue k') ks + then go op ts ks + else do + ys <- fromValue @[t] =<< (op `callFunc` pure v) + case S.toList ks of + [] -> checkComparable k' k' + WValue j : _ -> checkComparable k' j + fmap (t :) <$> go op (ts ++ ys) (S.insert (WValue k') ks) + +replaceStrings + :: MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +replaceStrings tfrom tto ts = fromNix tfrom >>= \(nsFrom :: [NixString]) -> + fromNix tto >>= \(nsTo :: [NixString]) -> + fromValue ts >>= \(ns :: NixString) -> do + let from = map principledStringIgnoreContext nsFrom + when (length nsFrom /= length nsTo) + $ throwError + $ ErrorCall + $ "'from' and 'to' arguments to 'replaceStrings'" + ++ " have different lengths" + let + lookupPrefix s = do + (prefix, replacement) <- find ((`Text.isPrefixOf` s) . fst) + $ zip from nsTo + let rest = Text.drop (Text.length prefix) s + return (prefix, replacement, rest) + finish b = + principledMakeNixString (LazyText.toStrict $ Builder.toLazyText b) + go orig result ctx = case lookupPrefix orig of + Nothing -> case Text.uncons orig of + Nothing -> finish result ctx + Just (h, t) -> go t (result <> Builder.singleton h) ctx + Just (prefix, replacementNS, rest) -> + let replacement = principledStringIgnoreContext replacementNS + newCtx = principledGetContext replacementNS + in case prefix of + "" -> case Text.uncons rest of + Nothing -> finish + (result <> Builder.fromText replacement) + (ctx <> newCtx) + Just (h, t) -> go + t + (mconcat + [ result + , Builder.fromText replacement + , Builder.singleton h + ] + ) + (ctx <> newCtx) + _ -> go rest + (result <> Builder.fromText replacement) + (ctx <> newCtx) + toNix + $ go (principledStringIgnoreContext ns) mempty + $ principledGetContext ns + +removeAttrs + :: forall e t f m + . MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +removeAttrs set = fromNix >=> \(nsToRemove :: [NixString]) -> + fromValue @(AttrSet t, AttrSet SourcePos) set >>= \(m, p) -> do + toRemove <- mapM fromStringNoContext nsToRemove + toNix (go m toRemove, go p toRemove) + where go = foldl' (flip M.delete) + +intersectAttrs + :: forall e t f m + . MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +intersectAttrs set1 set2 = + fromValue @(AttrSet t, AttrSet SourcePos) set1 >>= \(s1, p1) -> + fromValue @(AttrSet t, AttrSet SourcePos) set2 >>= \(s2, p2) -> + return $ nvSet (s2 `M.intersection` s1) (p2 `M.intersection` p1) + +functionArgs + :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +functionArgs fun = fun >>= \case + NVClosure p _ -> + toValue @(AttrSet t) $ valueThunk . nvConstant . NBool <$> case p of + Param name -> M.singleton name False + ParamSet s _ _ -> isJust <$> M.fromList s + v -> + throwError + $ ErrorCall + $ "builtins.functionArgs: expected function, got " + ++ show v + +toFile + :: MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +toFile name s = do + name' <- fromStringNoContext =<< fromValue name + s' <- fromValue s + -- TODO Using hacky here because we still need to turn the context into + -- runtime references of the resulting file. + -- See prim_toFile in nix/src/libexpr/primops.cc + mres <- toFile_ (Text.unpack name') + (Text.unpack $ hackyStringIgnoreContext s') + let t = Text.pack $ unStorePath mres + sc = StringContext t DirectPath + toNix $ principledMakeNixStringWithSingletonContext t sc + +toPath :: MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +toPath = fromValue @Path >=> toNix @Path + +pathExists_ :: MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +pathExists_ path = path >>= \case + NVPath p -> toNix =<< pathExists p + NVStr ns -> toNix =<< pathExists (Text.unpack (hackyStringIgnoreContext ns)) + v -> + throwError + $ ErrorCall + $ "builtins.pathExists: expected path, got " + ++ show v + +hasKind + :: forall a e t f m + . (MonadNix e t f m, FromValue a m (NValue t f m)) + => m (NValue t f m) + -> m (NValue t f m) +hasKind = fromValueMay >=> toNix . \case + Just (_ :: a) -> True + _ -> False + +isAttrs + :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +isAttrs = hasKind @(AttrSet t) + +isList + :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +isList = hasKind @[t] + +isString + :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +isString = hasKind @NixString + +isInt + :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +isInt = hasKind @Int + +isFloat + :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +isFloat = hasKind @Float + +isBool + :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +isBool = hasKind @Bool + +isNull + :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +isNull = hasKind @() + +isFunction :: MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +isFunction func = func >>= \case + NVClosure{} -> toValue True + _ -> toValue False + +throw_ :: MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +throw_ mnv = do + ns <- coerceToString CopyToStore CoerceStringy =<< mnv + throwError . ErrorCall . Text.unpack $ principledStringIgnoreContext ns + +import_ + :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +import_ = scopedImport (pure (nvSet M.empty M.empty)) + +scopedImport + :: forall e t f m + . MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +scopedImport asetArg pathArg = fromValue @(AttrSet t) asetArg >>= \s -> + fromValue pathArg >>= \(Path p) -> do + path <- pathToDefaultNix @t @f @m p + mres <- lookupVar "__cur_file" + path' <- case mres of + Nothing -> do + traceM "No known current directory" + return path + Just p -> force p $ fromValue >=> \(Path p') -> do + traceM $ "Current file being evaluated is: " ++ show p' + return $ takeDirectory p' path + clearScopes @t + $ withNixContext (Just path') + $ pushScope s + $ importPath @t @f @m path' + +getEnv_ :: MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +getEnv_ = fromValue >=> fromStringNoContext >=> \s -> do + mres <- getEnvVar (Text.unpack s) + toNix $ principledMakeNixStringWithoutContext $ case mres of + Nothing -> "" + Just v -> Text.pack v + +sort_ + :: MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +sort_ comparator xs = comparator + >>= \comp -> fromValue xs >>= sortByM (cmp comp) >>= toValue + where + cmp f a b = do + isLessThan <- f `callFunc` force' a >>= (`callFunc` force' b) + fromValue isLessThan >>= \case + True -> pure LT + False -> do + isGreaterThan <- f `callFunc` force' b >>= (`callFunc` force' a) + fromValue isGreaterThan <&> \case + True -> GT + False -> EQ + +lessThan + :: MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +lessThan ta tb = ta >>= \va -> tb >>= \vb -> do + let badType = + throwError + $ ErrorCall + $ "builtins.lessThan: expected two numbers or two strings, " + ++ "got " + ++ show va + ++ " and " + ++ show vb + nvConstant . NBool <$> case (va, vb) of + (NVConstant ca, NVConstant cb) -> case (ca, cb) of + (NInt a, NInt b ) -> pure $ a < b + (NFloat a, NInt b ) -> pure $ a < fromInteger b + (NInt a, NFloat b) -> pure $ fromInteger a < b + (NFloat a, NFloat b) -> pure $ a < b + _ -> badType + (NVStr a, NVStr b) -> + pure $ principledStringIgnoreContext a < principledStringIgnoreContext b + _ -> badType + +concatLists + :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +concatLists = + fromValue @[t] + >=> mapM (flip force $ fromValue @[t] >=> pure) + >=> toValue + . concat + +listToAttrs + :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +listToAttrs = fromValue @[t] >=> \l -> + fmap (flip nvSet M.empty . M.fromList . reverse) + $ forM l + $ flip force + $ fromValue @(AttrSet t) + >=> \s -> do + t <- attrsetGet "name" s + force t $ fromValue >=> \n -> do + name <- fromStringNoContext n + val <- attrsetGet "value" s + pure (name, val) + +-- prim_hashString from nix/src/libexpr/primops.cc +-- fail if context in the algo arg +-- propagate context from the s arg +hashString + :: MonadNix e t f m => NixString -> NixString -> Prim m NixString +hashString nsAlgo ns = Prim $ do + algo <- fromStringNoContext nsAlgo + let f g = pure $ principledModifyNixContents g ns + case algo of + "md5" -> + f $ \s -> +#if MIN_VERSION_hashing(0, 1, 0) + Text.pack $ show (hash (encodeUtf8 s) :: MD5.MD5) +#else + decodeUtf8 $ Base16.encode $ MD5.hash $ encodeUtf8 s +#endif + "sha1" -> + f $ \s -> +#if MIN_VERSION_hashing(0, 1, 0) + Text.pack $ show (hash (encodeUtf8 s) :: SHA1.SHA1) +#else + decodeUtf8 $ Base16.encode $ SHA1.hash $ encodeUtf8 s +#endif + "sha256" -> + f $ \s -> +#if MIN_VERSION_hashing(0, 1, 0) + Text.pack $ show (hash (encodeUtf8 s) :: SHA256.SHA256) +#else + decodeUtf8 $ Base16.encode $ SHA256.hash $ encodeUtf8 s +#endif + "sha512" -> + f $ \s -> +#if MIN_VERSION_hashing(0, 1, 0) + Text.pack $ show (hash (encodeUtf8 s) :: SHA512.SHA512) +#else + decodeUtf8 $ Base16.encode $ SHA512.hash $ encodeUtf8 s +#endif + _ -> + throwError + $ ErrorCall + $ "builtins.hashString: " + ++ "expected \"md5\", \"sha1\", \"sha256\", or \"sha512\", got " + ++ show algo + +placeHolder :: MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +placeHolder = fromValue >=> fromStringNoContext >=> \t -> do + h <- runPrim + (hashString (principledMakeNixStringWithoutContext "sha256") + (principledMakeNixStringWithoutContext ("nix-output:" <> t)) + ) + toNix + $ principledMakeNixStringWithoutContext + $ Text.cons '/' + $ printHashBytes32 + $ fst -- The result coming out of hashString is base16 encoded + $ Base16.decode + $ encodeUtf8 + $ principledStringIgnoreContext h + +absolutePathFromValue :: MonadNix e t f m => NValue t f m -> m FilePath +absolutePathFromValue = \case + NVStr ns -> do + let path = Text.unpack $ hackyStringIgnoreContext 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 + +readFile_ :: MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +readFile_ path = + path >>= absolutePathFromValue >>= Nix.Render.readFile >>= toNix + +findFile_ + :: forall e t f m + . MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +findFile_ aset filePath = aset >>= \aset' -> filePath >>= \filePath' -> + case (aset', filePath') of + (NVList x, NVStr ns) -> do + mres <- findPath @t @f @m x (Text.unpack (hackyStringIgnoreContext 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) + +data FileType + = FileTypeRegular + | FileTypeDirectory + | FileTypeSymlink + | FileTypeUnknown + deriving (Show, Read, Eq, Ord) + +instance Convertible e t f m => ToNix FileType m (NValue t f m) where + toNix = toNix . principledMakeNixStringWithoutContext . \case + FileTypeRegular -> "regular" :: Text + FileTypeDirectory -> "directory" + FileTypeSymlink -> "symlink" + FileTypeUnknown -> "unknown" + +readDir_ + :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +readDir_ pathThunk = do + path <- absolutePathFromValue =<< pathThunk + items <- listDirectory path + itemsWithTypes <- forM items $ \item -> do + s <- getSymbolicLinkStatus $ path item + let t = if + | isRegularFile s -> FileTypeRegular + | isDirectory s -> FileTypeDirectory + | isSymbolicLink s -> FileTypeSymlink + | otherwise -> FileTypeUnknown + pure (Text.pack item, t) + toNix (M.fromList itemsWithTypes) + +fromJSON + :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +fromJSON = fromValue >=> fromStringNoContext >=> \encoded -> + case A.eitherDecodeStrict' @A.Value $ encodeUtf8 encoded of + Left jsonError -> + throwError $ ErrorCall $ "builtins.fromJSON: " ++ jsonError + Right v -> jsonToNValue v + where + jsonToNValue = \case + A.Object m -> flip nvSet M.empty <$> traverse (thunk . jsonToNValue) m + A.Array l -> nvList <$> traverse + (\x -> + thunk @t @m @(NValue t f m) + . whileForcingThunk @t @f (CoercionFromJson @t @f @m x) + . jsonToNValue + $ x + ) + (V.toList l) + A.String s -> pure $ nvStr $ hackyMakeNixStringWithoutContext s + A.Number n -> pure $ nvConstant $ case floatingOrInteger n of + Left r -> NFloat r + Right i -> NInt i + A.Bool b -> pure $ nvConstant $ NBool b + A.Null -> pure $ nvConstant NNull + +prim_toJSON :: MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +prim_toJSON x = x >>= nvalueToJSONNixString >>= pure . nvStr + +toXML_ :: MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +toXML_ v = v >>= normalForm >>= pure . nvStr . toXML + +typeOf :: MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +typeOf v = v >>= toNix . principledMakeNixStringWithoutContext . \case + NVConstant a -> case a of + 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" + +tryEval + :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +tryEval e = catch (onSuccess <$> e) (pure . onError) + where + onSuccess v = flip nvSet M.empty $ M.fromList + [("success", valueThunk (nvConstant (NBool True))), ("value", valueThunk v)] + + onError :: SomeException -> NValue t f m + onError _ = flip nvSet M.empty $ M.fromList + [ ("success", valueThunk (nvConstant (NBool False))) + , ("value" , valueThunk (nvConstant (NBool False))) + ] + +trace_ + :: forall e t f m + . MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +trace_ msg action = do + traceEffect @t @f @m + . Text.unpack + . principledStringIgnoreContext + =<< fromValue msg + action + +-- TODO: remember error context +addErrorContext + :: forall e t f m + . MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +addErrorContext _ action = action + +exec_ + :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +exec_ xs = do + ls <- fromValue @[t] xs + xs <- traverse (coerceToString DontCopyToStore CoerceStringy <=< force') ls + -- TODO 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 (map (Text.unpack . hackyStringIgnoreContext) xs) + +fetchurl + :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +fetchurl v = v >>= \case + NVSet s _ -> attrsetGet "url" s >>= force ?? (go (M.lookup "sha256" s)) + v@NVStr{} -> go Nothing v + v -> + throwError + $ ErrorCall + $ "builtins.fetchurl: Expected URI or set, got " + ++ show v + where + go :: Maybe t -> NValue t f m -> m (NValue t f m) + go _msha = \case + NVStr ns -> noContextAttrs ns >>= getURL >>= \case -- msha + Left e -> throwError e + Right p -> toValue p + v -> + throwError + $ ErrorCall + $ "builtins.fetchurl: Expected URI or string, got " + ++ show v + + noContextAttrs ns = case principledGetStringNoContext ns of + Nothing -> + throwError $ ErrorCall $ "builtins.fetchurl: unsupported arguments to url" + Just t -> pure t + +partition_ + :: forall e t f m + . MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +partition_ fun xs = fun >>= \f -> fromValue @[t] xs >>= \l -> do + let match t = f `callFunc` force' t >>= fmap (, t) . fromValue + selection <- traverse match l + let (right, wrong) = partition fst selection + let makeSide = valueThunk . nvList . map snd + toValue @(AttrSet t) + $ M.fromList [("right", makeSide right), ("wrong", makeSide wrong)] + +currentSystem :: MonadNix e t f m => m (NValue t f m) +currentSystem = do + os <- getCurrentSystemOS + arch <- getCurrentSystemArch + return $ nvStr $ principledMakeNixStringWithoutContext (arch <> "-" <> os) + +currentTime_ :: MonadNix e t f m => m (NValue t f m) +currentTime_ = do + opts :: Options <- asks (view hasLens) + toNix @Integer $ round $ Time.utcTimeToPOSIXSeconds (currentTime opts) + +derivationStrict_ :: MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +derivationStrict_ = (>>= derivationStrict) + +getContext + :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +getContext x = x >>= \x' -> case x' of + (NVStr ns) -> do + let context = + getNixLikeContext $ toNixLikeContext $ principledGetContext ns + valued :: M.HashMap Text (NValue t f m) <- sequenceA $ M.map toValue context + pure $ flip nvSet M.empty $ M.map wrapValue valued + x -> + throwError $ ErrorCall $ "Invalid type for builtins.getContext: " ++ show x + +appendContext + :: forall e t f m + . MonadNix e t f m + => m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) +appendContext x y = x >>= \x' -> y >>= \y' -> case (x', y') of + (NVStr ns, NVSet attrs _) -> do + newContextValues <- forM attrs $ force' >=> \case + NVSet attrs _ -> do + -- TODO: Fail for unexpected keys. + path <- maybe (return False) (force ?? fromValue) + $ M.lookup "path" attrs + allOutputs <- maybe (return False) (force ?? fromValue) + $ M.lookup "allOutputs" attrs + outputs <- case M.lookup "outputs" attrs of + Nothing -> return [] + Just os -> force' os >>= \case + NVList vs -> + forM vs $ fmap principledStringIgnoreContext . fromNix . force' + x -> + throwError + $ ErrorCall + $ "Invalid types for context value outputs in builtins.appendContext: " + ++ show x + return $ NixLikeContextValue path allOutputs outputs + x -> + throwError + $ ErrorCall + $ "Invalid types for context value in builtins.appendContext: " + ++ show x + toValue + $ principledMakeNixString (principledStringIgnoreContext ns) + $ fromNixLikeContext + $ NixLikeContext + $ M.unionWith (<>) newContextValues + $ getNixLikeContext + $ toNixLikeContext + $ principledGetContext ns + (x, y) -> + throwError + $ ErrorCall + $ "Invalid types for builtins.appendContext: " + ++ show (x, y) + +newtype Prim m a = Prim { runPrim :: m a } + +-- | Types that support conversion to nix in a particular monad +class ToBuiltin t f m a | a -> m where + toBuiltin :: String -> a -> m (NValue t f m) + +instance (MonadNix e t f m, ToNix a m (NValue t f m)) + => ToBuiltin t f m (Prim m a) where + toBuiltin _ p = toNix =<< runPrim p + +instance ( MonadNix e t f m + , FromNix a m (NValue t f m) + , ToBuiltin t f m b) + => ToBuiltin t f m (a -> b) where + toBuiltin name f = + return $ nvBuiltin name (fromNix >=> fmap wrapValue . toBuiltin name . f) diff --git a/src/Nix/Cache.hs b/src/Nix/Cache.hs --- a/src/Nix/Cache.hs +++ b/src/Nix/Cache.hs @@ -2,7 +2,7 @@ module Nix.Cache where -import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Lazy as BS import Nix.Expr.Types.Annotated #if defined (__linux__) && MIN_VERSION_base(4, 10, 0) @@ -14,7 +14,7 @@ import qualified Data.Compact.Serialize as C #endif #ifdef MIN_VERSION_serialise -import qualified Codec.Serialise as S +import qualified Codec.Serialise as S #endif readCache :: FilePath -> IO NExprLoc @@ -26,10 +26,10 @@ Right expr -> return $ C.getCompact expr #else #ifdef MIN_VERSION_serialise - eres <- S.deserialiseOrFail <$> BS.readFile path - case eres of - Left err -> error $ "Error reading cache file: " ++ show err - Right expr -> return expr + eres <- S.deserialiseOrFail <$> BS.readFile path + case eres of + Left err -> error $ "Error reading cache file: " ++ show err + Right expr -> return expr #else error "readCache not implemented for this platform" #endif @@ -41,7 +41,7 @@ C.writeCompact path =<< C.compact expr #else #ifdef MIN_VERSION_serialise - BS.writeFile path (S.serialise expr) + BS.writeFile path (S.serialise expr) #else error "writeCache not implemented for this platform" #endif diff --git a/src/Nix/Cited.hs b/src/Nix/Cited.hs new file mode 100644 --- /dev/null +++ b/src/Nix/Cited.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} + +{-# OPTIONS_GHC -Wno-missing-signatures #-} + +module Nix.Cited where + +import Control.Comonad +import Control.Comonad.Env +import Data.Typeable ( Typeable ) +import GHC.Generics +import Lens.Family2.TH + +import Nix.Expr.Types.Annotated +import Nix.Scope + +data Provenance t m v = Provenance + { _lexicalScope :: Scopes m t + , _originExpr :: 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 + -- result of the call, but what was called and with what arguments. + } + deriving (Generic, Typeable, Show) + +data NCited t m v a = NCited + { _provenance :: [Provenance t m v] + , _cited :: a + } + deriving (Generic, Typeable, Functor, Foldable, Traversable, Show) + +instance Applicative (NCited t m v) where + pure = NCited [] + NCited xs f <*> NCited ys x = NCited (xs <> ys) (f x) + +instance Comonad (NCited t m v) where + duplicate p = NCited (_provenance p) p + extract = _cited + +instance ComonadEnv [Provenance t m v] (NCited t m v) where + ask = _provenance + +$(makeLenses ''Provenance) +$(makeLenses ''NCited) + +class HasCitations t m v a where + citations :: a -> [Provenance t m v] + addProvenance :: Provenance t m v -> a -> a + +instance HasCitations t m v (NCited t m v a) where + citations = _provenance + addProvenance x (NCited p v) = (NCited (x : p) v) + +class HasCitations1 t m v f where + citations1 :: f a -> [Provenance t m v] + addProvenance1 :: Provenance t m v -> f a -> f a diff --git a/src/Nix/Cited/Basic.hs b/src/Nix/Cited/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Nix/Cited/Basic.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +module Nix.Cited.Basic where + +import Control.Comonad ( Comonad ) +import Control.Comonad.Env ( ComonadEnv ) +import Control.Monad.Catch hiding ( catchJust ) +import Control.Monad.Reader +import Data.Fix +import GHC.Generics +import Nix.Cited +import Nix.Eval as Eval +import Nix.Exec +import Nix.Expr +import Nix.Frames +import Nix.Options +import Nix.Thunk +import Nix.Utils +import Nix.Value + +newtype Cited t f m a = Cited { getCited :: NCited t m (NValue t f m) a } + deriving + ( Generic + , Typeable + , Functor + , Applicative + , Foldable + , Traversable + , Comonad + , ComonadEnv [Provenance t m (NValue t f m)] + ) + +instance HasCitations1 t m (NValue t f m) (Cited t f m) where + citations1 (Cited c) = citations c + addProvenance1 x (Cited c) = Cited (addProvenance x c) + +instance ( Has e Options + , Framed e m + , MonadThunk t m v + , Typeable m + , Typeable u + , MonadCatch m + ) + => MonadThunk (Cited u f m t) m v where + thunk mv = do + opts :: Options <- asks (view hasLens) + + if thunks opts + then do + frames :: Frames <- asks (view hasLens) + + -- Gather the current evaluation context at the time of thunk + -- creation, and record it along with the thunk. + let go (fromException -> + Just (EvaluatingExpr scope + (Fix (Compose (Ann s e))))) = + let e' = Compose (Ann s (Nothing <$ e)) + in [Provenance scope e'] + go _ = [] + ps = concatMap (go . frame) frames + + fmap (Cited . NCited ps) . thunk $ mv + else fmap (Cited . NCited []) . thunk $ mv + + thunkId (Cited (NCited _ t)) = thunkId @_ @m t + + query (Cited (NCited _ t)) = query t + queryM (Cited (NCited _ t)) = queryM t + + -- | The ThunkLoop exception is thrown as an exception with MonadThrow, + -- which does not capture the current stack frame information to provide + -- it in a NixException, so we catch and re-throw it here using + -- 'throwError' from Frames.hs. + force (Cited (NCited ps t)) f = + catch go (throwError @ThunkLoop) + where + go = case ps of + [] -> force t f + Provenance scope e@(Compose (Ann s _)) : _ -> + withFrame Info (ForcingExpr scope (wrapExprLoc s e)) (force t f) + + forceEff (Cited (NCited ps t)) f = catch + go + (throwError @ThunkLoop) + where + go = case ps of + [] -> forceEff t f + Provenance scope e@(Compose (Ann s _)) : _ -> + withFrame Info (ForcingExpr scope (wrapExprLoc s e)) (forceEff t f) + + wrapValue = Cited . NCited [] . wrapValue + getValue (Cited (NCited _ v)) = getValue v diff --git a/src/Nix/Context.hs b/src/Nix/Context.hs --- a/src/Nix/Context.hs +++ b/src/Nix/Context.hs @@ -4,30 +4,32 @@ module Nix.Context where -import Nix.Options -import Nix.Scope -import Nix.Frames -import Nix.Utils -import Nix.Expr.Types.Annotated (SrcSpan, nullSpan) +import Nix.Options +import Nix.Scope +import Nix.Frames +import Nix.Utils +import Nix.Expr.Types.Annotated ( SrcSpan + , nullSpan + ) -data Context m v = Context - { scopes :: Scopes m v +data Context m t = Context + { scopes :: Scopes m t , source :: SrcSpan , frames :: Frames , options :: Options } -instance Has (Context m v) (Scopes m v) where - hasLens f (Context x y z w) = (\x' -> Context x' y z w) <$> f x +instance Has (Context m t) (Scopes m t) where + hasLens f (Context x y z w) = (\x' -> Context x' y z w) <$> f x -instance Has (Context m v) SrcSpan where - hasLens f (Context x y z w) = (\y' -> Context x y' z w) <$> f y +instance Has (Context m t) SrcSpan where + hasLens f (Context x y z w) = (\y' -> Context x y' z w) <$> f y -instance Has (Context m v) Frames where - hasLens f (Context x y z w) = (\z' -> Context x y z' w) <$> f z +instance Has (Context m t) Frames where + hasLens f (Context x y z w) = (\z' -> Context x y z' w) <$> f z -instance Has (Context m v) Options where - hasLens f (Context x y z w) = (\w' -> Context x y z w') <$> f w +instance Has (Context m t) Options where + hasLens f (Context x y z w) = (\w' -> Context x y z w') <$> f w -newContext :: Options -> Context m v +newContext :: Options -> Context m t newContext = Context emptyScopes nullSpan [] diff --git a/src/Nix/Convert.hs b/src/Nix/Convert.hs --- a/src/Nix/Convert.hs +++ b/src/Nix/Convert.hs @@ -11,6 +11,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} @@ -26,432 +28,392 @@ module Nix.Convert where import Control.Monad -import Data.Aeson (toJSON) -import qualified Data.Aeson as A +import Control.Monad.Catch import Data.ByteString -import Data.Fix -import Data.HashMap.Lazy (HashMap) -import qualified Data.HashMap.Lazy as M -import Data.Scientific -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Text.Encoding (encodeUtf8, decodeUtf8) -import qualified Data.Vector as V +import Data.HashMap.Lazy ( HashMap ) +import qualified Data.HashMap.Lazy as M +import Data.Maybe +import Data.Text ( Text ) +import qualified Data.Text as Text +import Data.Text.Encoding ( encodeUtf8 + , decodeUtf8 + ) import Nix.Atoms import Nix.Effects import Nix.Expr.Types import Nix.Expr.Types.Annotated import Nix.Frames -import Nix.Normal +import Nix.String import Nix.Thunk -import Nix.Utils import Nix.Value +{- + +IMPORTANT NOTE + +We used to have Text instances of FromValue, ToValue, FromNix, and ToNix. +However, we're removing these instances because they are dangerous due to the +fact that they hide the way string contexts are handled. It's better to have to +explicitly handle string context in a way that is appropriate for the situation. + +Do not add these instances back! + +-} + class FromValue a m v where fromValue :: v -> m a fromValueMay :: v -> m (Maybe a) -type Convertible e m = (Framed e m, MonadVar m, Typeable m) - -instance Convertible e m => FromValue () m (NValueNF m) where - fromValueMay = \case - Fix (NVConstantF NNull) -> pure $ Just () - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ ExpectationNF TNull v - -instance Convertible e m - => FromValue () m (NValue m) where - fromValueMay = \case - NVConstant NNull -> pure $ Just () - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ Expectation TNull v +type Convertible e t f m + = (Framed e m, MonadThunk t m (NValue t f m), MonadDataErrorContext t f m) -instance Convertible e m - => FromValue Bool m (NValueNF m) where - fromValueMay = \case - Fix (NVConstantF (NBool b)) -> pure $ Just b - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ ExpectationNF TBool v +instance Convertible e t f m => FromValue () m (NValueNF t f m) where + fromValueMay = \case + NVConstantNF NNull -> pure $ Just () + _ -> pure Nothing + fromValue v = fromValueMay v >>= \case + Just b -> pure b + _ -> throwError $ ExpectationNF TNull v -instance Convertible e m - => FromValue Bool m (NValue m) where - fromValueMay = \case - NVConstant (NBool b) -> pure $ Just b - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ Expectation TBool v +instance Convertible e t f m => FromValue () m (NValue t f m) where + fromValueMay = \case + NVConstant NNull -> pure $ Just () + _ -> pure Nothing + fromValue v = fromValueMay v >>= \case + Just b -> pure b + _ -> throwError $ Expectation TNull v -instance Convertible e m - => FromValue Int m (NValueNF m) where - fromValueMay = \case - Fix (NVConstantF (NInt b)) -> pure $ Just (fromInteger b) - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ ExpectationNF TInt v +instance Convertible e t f m => FromValue Bool m (NValueNF t f m) where + fromValueMay = \case + NVConstantNF (NBool b) -> pure $ Just b + _ -> pure Nothing + fromValue v = fromValueMay v >>= \case + Just b -> pure b + _ -> throwError $ ExpectationNF TBool v -instance Convertible e m - => FromValue Int m (NValue m) where - fromValueMay = \case - NVConstant (NInt b) -> pure $ Just (fromInteger b) - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ Expectation TInt v +instance Convertible e t f m => FromValue Bool m (NValue t f m) where + fromValueMay = \case + NVConstant (NBool b) -> pure $ Just b + _ -> pure Nothing + fromValue v = fromValueMay v >>= \case + Just b -> pure b + _ -> throwError $ Expectation TBool v -instance Convertible e m - => FromValue Integer m (NValueNF m) where - fromValueMay = \case - Fix (NVConstantF (NInt b)) -> pure $ Just b - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ ExpectationNF TInt v +instance Convertible e t f m => FromValue Int m (NValueNF t f m) where + fromValueMay = \case + NVConstantNF (NInt b) -> pure $ Just (fromInteger b) + _ -> pure Nothing + fromValue v = fromValueMay v >>= \case + Just b -> pure b + _ -> throwError $ ExpectationNF TInt v -instance Convertible e m - => FromValue Integer m (NValue m) where - fromValueMay = \case - NVConstant (NInt b) -> pure $ Just b - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ Expectation TInt v +instance Convertible e t f m => FromValue Int m (NValue t f m) where + fromValueMay = \case + NVConstant (NInt b) -> pure $ Just (fromInteger b) + _ -> pure Nothing + fromValue v = fromValueMay v >>= \case + Just b -> pure b + _ -> throwError $ Expectation TInt v -instance Convertible e m - => FromValue Float m (NValueNF m) where - fromValueMay = \case - Fix (NVConstantF (NFloat b)) -> pure $ Just b - Fix (NVConstantF (NInt i)) -> pure $ Just (fromInteger i) - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ ExpectationNF TFloat v +instance Convertible e t f m => FromValue Integer m (NValueNF t f m) where + fromValueMay = \case + NVConstantNF (NInt b) -> pure $ Just b + _ -> pure Nothing + fromValue v = fromValueMay v >>= \case + Just b -> pure b + _ -> throwError $ ExpectationNF TInt v -instance Convertible e m - => FromValue Float m (NValue m) where - fromValueMay = \case - NVConstant (NFloat b) -> pure $ Just b - NVConstant (NInt i) -> pure $ Just (fromInteger i) - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ Expectation TFloat v +instance Convertible e t f m => FromValue Integer m (NValue t f m) where + fromValueMay = \case + NVConstant (NInt b) -> pure $ Just b + _ -> pure Nothing + fromValue v = fromValueMay v >>= \case + Just b -> pure b + _ -> throwError $ Expectation TInt v -instance (Convertible e m, MonadEffects m) - => FromValue Text m (NValueNF m) where - fromValueMay = \case - Fix (NVStrF t _) -> pure $ Just t - Fix (NVPathF p) -> Just . Text.pack . unStorePath <$> addPath p - Fix (NVSetF s _) -> case M.lookup "outPath" s of - Nothing -> pure Nothing - Just p -> fromValueMay @Text p - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ ExpectationNF TString v +instance Convertible e t f m => FromValue Float m (NValueNF t f m) where + fromValueMay = \case + NVConstantNF (NFloat b) -> pure $ Just b + NVConstantNF (NInt i) -> pure $ Just (fromInteger i) + _ -> pure Nothing + fromValue v = fromValueMay v >>= \case + Just b -> pure b + _ -> throwError $ ExpectationNF TFloat v -instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m, MonadEffects m) - => FromValue Text m (NValue m) where - fromValueMay = \case - NVStr t _ -> pure $ Just t - NVPath p -> Just . Text.pack . unStorePath <$> addPath p - NVSet s _ -> case M.lookup "outPath" s of - Nothing -> pure Nothing - Just p -> fromValueMay @Text p - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ Expectation TString v +instance Convertible e t f m => FromValue Float m (NValue t f m) where + fromValueMay = \case + NVConstant (NFloat b) -> pure $ Just b + NVConstant (NInt i) -> pure $ Just (fromInteger i) + _ -> pure Nothing + fromValue v = fromValueMay v >>= \case + Just b -> pure b + _ -> throwError $ Expectation TFloat v -instance (Convertible e m, MonadEffects m) - => FromValue (Text, DList Text) m (NValueNF m) where - fromValueMay = \case - Fix (NVStrF t d) -> pure $ Just (t, d) - Fix (NVPathF p) -> Just . (,mempty) . Text.pack . unStorePath <$> addPath p - Fix (NVSetF s _) -> case M.lookup "outPath" s of - Nothing -> pure Nothing - Just p -> fmap (,mempty) <$> fromValueMay @Text p - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ ExpectationNF TString v +instance (Convertible e t f m, MonadEffects t f m) + => FromValue NixString m (NValueNF t f m) where + fromValueMay = \case + NVStrNF ns -> pure $ Just ns + NVPathNF p -> + Just + . hackyMakeNixStringWithoutContext + . Text.pack + . unStorePath + <$> addPath p + NVSetNF s _ -> case M.lookup "outPath" s of + Nothing -> pure Nothing + Just p -> fromValueMay p + _ -> pure Nothing + fromValue v = fromValueMay v >>= \case + Just b -> pure b + _ -> throwError $ ExpectationNF (TString NoContext) v -instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m, MonadEffects m) - => FromValue (Text, DList Text) m (NValue m) where - fromValueMay = \case - NVStr t d -> pure $ Just (t, d) - NVPath p -> Just . (,mempty) . Text.pack . unStorePath <$> addPath p - NVSet s _ -> case M.lookup "outPath" s of - Nothing -> pure Nothing - Just p -> fmap (,mempty) <$> fromValueMay @Text p - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ Expectation TString v +instance (Convertible e t f m, MonadEffects t f m) + => FromValue NixString m (NValue t f m) where + fromValueMay = \case + NVStr ns -> pure $ Just ns + NVPath p -> + Just + . hackyMakeNixStringWithoutContext + . Text.pack + . unStorePath + <$> addPath p + NVSet s _ -> case M.lookup "outPath" s of + Nothing -> pure Nothing + Just p -> force p fromValueMay + _ -> pure Nothing + fromValue v = fromValueMay v >>= \case + Just b -> pure b + _ -> throwError $ Expectation (TString NoContext) v -instance Convertible e m - => FromValue ByteString m (NValueNF m) where - fromValueMay = \case - Fix (NVStrF t _) -> pure $ Just (encodeUtf8 t) - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ ExpectationNF TString v +instance Convertible e t f m + => FromValue ByteString m (NValueNF t f m) where + fromValueMay = \case + NVStrNF ns -> pure $ encodeUtf8 <$> hackyGetStringNoContext ns + _ -> pure Nothing + fromValue v = fromValueMay v >>= \case + Just b -> pure b + _ -> throwError $ ExpectationNF (TString NoContext) v -instance Convertible e m - => FromValue ByteString m (NValue m) where - fromValueMay = \case - NVStr t _ -> pure $ Just (encodeUtf8 t) - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ Expectation TString v +instance Convertible e t f m + => FromValue ByteString m (NValue t f m) where + fromValueMay = \case + NVStr ns -> pure $ encodeUtf8 <$> hackyGetStringNoContext ns + _ -> pure Nothing + fromValue v = fromValueMay v >>= \case + Just b -> pure b + _ -> throwError $ Expectation (TString NoContext) v newtype Path = Path { getPath :: FilePath } deriving Show -instance Convertible e m => FromValue Path m (NValueNF m) where - fromValueMay = \case - Fix (NVPathF p) -> pure $ Just (Path p) - Fix (NVStrF s _) -> pure $ Just (Path (Text.unpack s)) - Fix (NVSetF s _) -> case M.lookup "outPath" s of - Nothing -> pure Nothing - Just p -> fromValueMay @Path p - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ ExpectationNF TPath v - -instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m) - => FromValue Path m (NValue m) where - fromValueMay = \case - NVPath p -> pure $ Just (Path p) - NVStr s _ -> pure $ Just (Path (Text.unpack s)) - NVSet s _ -> case M.lookup "outPath" s of - Nothing -> pure Nothing - Just p -> fromValueMay @Path p - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ Expectation TPath v +instance Convertible e t f m => FromValue Path m (NValueNF t f m) where + fromValueMay = \case + NVPathNF p -> pure $ Just (Path p) + NVStrNF ns -> pure $ Path . Text.unpack <$> hackyGetStringNoContext ns + NVSetNF s _ -> case M.lookup "outPath" s of + Nothing -> pure Nothing + Just p -> fromValueMay @Path p + _ -> pure Nothing + fromValue v = fromValueMay v >>= \case + Just b -> pure b + _ -> throwError $ ExpectationNF TPath v -instance (Convertible e m, FromValue a m (NValueNF m), Show a) - => FromValue [a] m (NValueNF m) where - fromValueMay = \case - Fix (NVListF l) -> sequence <$> traverse fromValueMay l - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ ExpectationNF TList v +instance Convertible e t f m => FromValue Path m (NValue t f m) where + fromValueMay = \case + NVPath p -> pure $ Just (Path p) + NVStr ns -> pure $ Path . Text.unpack <$> hackyGetStringNoContext ns + NVSet s _ -> case M.lookup "outPath" s of + Nothing -> pure Nothing + Just p -> force p $ fromValueMay @Path + _ -> pure Nothing + fromValue v = fromValueMay v >>= \case + Just b -> pure b + _ -> throwError $ Expectation TPath v -instance Convertible e m => FromValue [NThunk m] m (NValue m) where - fromValueMay = \case - NVList l -> pure $ Just l - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ Expectation TList v +instance (Convertible e t f m, FromValue a m (NValueNF t f m), Show a) + => FromValue [a] m (NValueNF t f m) where + fromValueMay = \case + NVListNF l -> sequence <$> traverse fromValueMay l + _ -> pure Nothing + fromValue v = fromValueMay v >>= \case + Just b -> pure b + _ -> throwError $ ExpectationNF TList v -instance Convertible e m - => FromValue (HashMap Text (NValueNF m)) m (NValueNF m) where - fromValueMay = \case - Fix (NVSetF s _) -> pure $ Just s - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ ExpectationNF TSet v +instance Convertible e t f m => FromValue [t] m (NValue t f m) where + fromValueMay = \case + NVList l -> pure $ Just l + _ -> pure Nothing + fromValue v = fromValueMay v >>= \case + Just b -> pure b + _ -> throwError $ Expectation TList v -instance Convertible e m - => FromValue (HashMap Text (NThunk m)) m (NValue m) where - fromValueMay = \case - NVSet s _ -> pure $ Just s - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ Expectation TSet v +instance Convertible e t f m + => FromValue (HashMap Text (NValueNF t f m)) m (NValueNF t f m) where + fromValueMay = \case + NVSetNF s _ -> pure $ Just s + _ -> pure Nothing + fromValue v = fromValueMay v >>= \case + Just b -> pure b + _ -> throwError $ ExpectationNF TSet v -instance Convertible e m - => FromValue (HashMap Text (NValueNF m), - HashMap Text SourcePos) m (NValueNF m) where - fromValueMay = \case - Fix (NVSetF s p) -> pure $ Just (s, p) - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ ExpectationNF TSet v +instance Convertible e t f m + => FromValue (HashMap Text t) m (NValue t f m) where + fromValueMay = \case + NVSet s _ -> pure $ Just s + _ -> pure Nothing + fromValue v = fromValueMay v >>= \case + Just b -> pure b + _ -> throwError $ Expectation TSet v -instance Convertible e m - => FromValue (HashMap Text (NThunk m), - HashMap Text SourcePos) m (NValue m) where - fromValueMay = \case - NVSet s p -> pure $ Just (s, p) - _ -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ Expectation TSet v +instance Convertible e t f m + => FromValue (HashMap Text (NValueNF t f m), + HashMap Text SourcePos) m (NValueNF t f m) where + fromValueMay = \case + NVSetNF s p -> pure $ Just (s, p) + _ -> pure Nothing + fromValue v = fromValueMay v >>= \case + Just b -> pure b + _ -> throwError $ ExpectationNF TSet v -instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m) - => FromValue (NThunk m) m (NValue m) where - fromValueMay = pure . Just . value @_ @_ @m - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> error "Impossible, see fromValueMay" +instance Convertible e t f m + => FromValue (HashMap Text t, + HashMap Text SourcePos) m (NValue t f m) where + fromValueMay = \case + NVSet s p -> pure $ Just (s, p) + _ -> pure Nothing + fromValue v = fromValueMay v >>= \case + Just b -> pure b + _ -> throwError $ Expectation TSet v instance (Monad m, FromValue a m v) => FromValue a m (m v) where - fromValueMay = (>>= fromValueMay) - fromValue = (>>= fromValue) - -instance (MonadThunk (NValue m) (NThunk m) m, FromValue a m (NValue m)) - => FromValue a m (NThunk m) where - fromValueMay = force ?? fromValueMay - fromValue = force ?? fromValue - -instance (Convertible e m, MonadEffects m) - => FromValue A.Value m (NValueNF m) where - fromValueMay = \case - Fix (NVConstantF a) -> pure $ Just $ case a of - NInt n -> toJSON n - NFloat n -> toJSON n - NBool b -> toJSON b - NNull -> A.Null - Fix (NVStrF s _) -> pure $ Just $ toJSON s - Fix (NVListF l) -> fmap (A.Array . V.fromList) . sequence - <$> traverse fromValueMay l - Fix (NVSetF m _) -> fmap A.Object . sequence <$> traverse fromValueMay m - Fix NVClosureF {} -> pure Nothing - Fix (NVPathF p) -> Just . toJSON . unStorePath <$> addPath p - Fix (NVBuiltinF _ _) -> pure Nothing - fromValue v = fromValueMay v >>= \case - Just b -> pure b - _ -> throwError $ CoercionToJsonNF v + fromValueMay = (>>= fromValueMay) + fromValue = (>>= fromValue) class ToValue a m v where toValue :: a -> m v -instance Applicative m => ToValue () m (NValueNF m) where - toValue _ = pure . Fix . NVConstantF $ NNull +instance Convertible e t f m => ToValue () m (NValueNF t f m) where + toValue _ = pure . nvConstantNF $ NNull -instance Applicative m => ToValue () m (NValue m) where - toValue _ = pure . nvConstant $ NNull +instance Convertible e t f m => ToValue () m (NValue t f m) where + toValue _ = pure . nvConstant $ NNull -instance Applicative m => ToValue Bool m (NValueNF m) where - toValue = pure . Fix . NVConstantF . NBool +instance Convertible e t f m => ToValue Bool m (NValueNF t f m) where + toValue = pure . nvConstantNF . NBool -instance Applicative m => ToValue Bool m (NValue m) where - toValue = pure . nvConstant . NBool +instance Convertible e t f m => ToValue Bool m (NValue t f m) where + toValue = pure . nvConstant . NBool -instance Applicative m => ToValue Int m (NValueNF m) where - toValue = pure . Fix . NVConstantF . NInt . toInteger +instance Convertible e t f m => ToValue Int m (NValueNF t f m) where + toValue = pure . nvConstantNF . NInt . toInteger -instance Applicative m => ToValue Int m (NValue m) where - toValue = pure . nvConstant . NInt . toInteger +instance Convertible e t f m => ToValue Int m (NValue t f m) where + toValue = pure . nvConstant . NInt . toInteger -instance Applicative m => ToValue Integer m (NValueNF m) where - toValue = pure . Fix . NVConstantF . NInt +instance Convertible e t f m => ToValue Integer m (NValueNF t f m) where + toValue = pure . nvConstantNF . NInt -instance Applicative m => ToValue Integer m (NValue m) where - toValue = pure . nvConstant . NInt +instance Convertible e t f m => ToValue Integer m (NValue t f m) where + toValue = pure . nvConstant . NInt -instance Applicative m => ToValue Float m (NValueNF m) where - toValue = pure . Fix . NVConstantF . NFloat +instance Convertible e t f m => ToValue Float m (NValueNF t f m) where + toValue = pure . nvConstantNF . NFloat -instance Applicative m => ToValue Float m (NValue m) where - toValue = pure . nvConstant . NFloat +instance Convertible e t f m => ToValue Float m (NValue t f m) where + toValue = pure . nvConstant . NFloat -instance Applicative m => ToValue Text m (NValueNF m) where - toValue = pure . Fix . flip NVStrF mempty +instance Convertible e t f m => ToValue NixString m (NValueNF t f m) where + toValue = pure . nvStrNF -instance Applicative m => ToValue Text m (NValue m) where - toValue = pure . flip nvStr mempty +instance Convertible e t f m => ToValue NixString m (NValue t f m) where + toValue = pure . nvStr -instance Applicative m => ToValue (Text, DList Text) m (NValueNF m) where - toValue = pure . Fix . uncurry NVStrF +instance Convertible e t f m => ToValue ByteString m (NValueNF t f m) where + toValue = pure . nvStrNF . hackyMakeNixStringWithoutContext . decodeUtf8 -instance Applicative m => ToValue (Text, DList Text) m (NValue m) where - toValue = pure . uncurry nvStr +instance Convertible e t f m => ToValue ByteString m (NValue t f m) where + toValue = pure . nvStr . hackyMakeNixStringWithoutContext . decodeUtf8 -instance Applicative m => ToValue ByteString m (NValueNF m) where - toValue = pure . Fix . flip NVStrF mempty . decodeUtf8 +instance Convertible e t f m => ToValue Path m (NValueNF t f m) where + toValue = pure . nvPathNF . getPath -instance Applicative m => ToValue ByteString m (NValue m) where - toValue = pure . flip nvStr mempty . decodeUtf8 +instance Convertible e t f m => ToValue Path m (NValue t f m) where + toValue = pure . nvPath . getPath -instance Applicative m => ToValue Path m (NValueNF m) where - toValue = pure . Fix . NVPathF . getPath +instance Convertible e t f m => ToValue StorePath m (NValueNF t f m) where + toValue = toValue . Path . unStorePath -instance Applicative m => ToValue Path m (NValue m) where - toValue = pure . nvPath . getPath +instance Convertible e t f m => ToValue StorePath m (NValue t f m) where + toValue = toValue . Path . unStorePath -instance MonadThunk (NValue m) (NThunk m) m - => ToValue SourcePos m (NValue m) where - toValue (SourcePos f l c) = do - f' <- toValue (Text.pack f) - l' <- toValue (unPos l) - c' <- toValue (unPos c) - let pos = M.fromList - [ ("file" :: Text, value @_ @_ @m f') - , ("line", value @_ @_ @m l') - , ("column", value @_ @_ @m c') ] - pure $ nvSet pos mempty +instance Convertible e t f m => ToValue SourcePos m (NValue t f m) where + toValue (SourcePos f l c) = do + f' <- pure $ nvStr $ principledMakeNixStringWithoutContext (Text.pack f) + l' <- toValue (unPos l) + c' <- toValue (unPos c) + let pos = M.fromList + [ ("file" :: Text, wrapValue f') + , ("line" , wrapValue l') + , ("column" , wrapValue c') + ] + pure $ nvSet pos mempty -instance (ToValue a m (NValueNF m), Applicative m) - => ToValue [a] m (NValueNF m) where - toValue = fmap (Fix . NVListF) . traverse toValue +instance (Convertible e t f m, ToValue a m (NValueNF t f m)) + => ToValue [a] m (NValueNF t f m) where + toValue = fmap nvListNF . traverse toValue -instance Applicative m => ToValue [NThunk m] m (NValue m) where - toValue = pure . nvList +instance Convertible e t f m => ToValue [t] m (NValue t f m) where + toValue = pure . nvList -instance Applicative m - => ToValue (HashMap Text (NValueNF m)) m (NValueNF m) where - toValue = pure . Fix . flip NVSetF M.empty +instance Convertible e t f m + => ToValue (HashMap Text (NValueNF t f m)) m (NValueNF t f m) where + toValue = pure . flip nvSetNF M.empty -instance Applicative m => ToValue (HashMap Text (NThunk m)) m (NValue m) where - toValue = pure . flip nvSet M.empty +instance Convertible e t f m => ToValue (HashMap Text t) m (NValue t f m) where + toValue = pure . flip nvSet M.empty -instance Applicative m => ToValue (HashMap Text (NValueNF m), - HashMap Text SourcePos) m (NValueNF m) where - toValue (s, p) = pure $ Fix $ NVSetF s p +instance Convertible e t f m => ToValue (HashMap Text (NValueNF t f m), + HashMap Text SourcePos) m (NValueNF t f m) where + toValue (s, p) = pure $ nvSetNF s p -instance Applicative m => ToValue (HashMap Text (NThunk m), - HashMap Text SourcePos) m (NValue m) where - toValue (s, p) = pure $ nvSet s p +instance Convertible e t f m => ToValue (HashMap Text t, + HashMap Text SourcePos) m (NValue t f m) where + toValue (s, p) = pure $ nvSet s p -instance (MonadThunk (NValue m) (NThunk m) m, ToValue a m (NValue m)) - => ToValue a m (NThunk m) where - toValue = fmap (value @(NValue m) @_ @m) . toValue +instance Convertible e t f m => ToValue Bool m (NExprF r) where + toValue = pure . NConstant . NBool -instance Applicative m => ToValue Bool m (NExprF r) where - toValue = pure . NConstant . NBool +instance Convertible e t f m => ToValue () m (NExprF r) where + toValue _ = pure . NConstant $ NNull -instance Applicative m => ToValue () m (NExprF r) where - toValue _ = pure . NConstant $ NNull +instance ( MonadThunk t m (NValue t f m) + , MonadDataErrorContext t f m + , Framed e m + ) + => ToValue NixLikeContextValue m (NValue t f m) where + toValue nlcv = do + path <- if nlcvPath nlcv then Just <$> toValue True else return Nothing + allOutputs <- if nlcvAllOutputs nlcv + then Just <$> toValue True + else return Nothing + outputs <- do + let outputs = + fmap principledMakeNixStringWithoutContext $ nlcvOutputs nlcv + outputsM :: [NValue t f m] <- traverse toValue outputs + let ts :: [t] = fmap wrapValue outputsM + case ts of + [] -> return Nothing + _ -> Just <$> toValue ts + pure $ flip nvSet M.empty $ M.fromList $ catMaybes + [ (\p -> ("path", wrapValue p)) <$> path + , (\ao -> ("allOutputs", wrapValue ao)) <$> allOutputs + , (\os -> ("outputs", wrapValue os)) <$> outputs + ] -whileForcingThunk :: forall s e m r. (Framed e m, Exception s, Typeable m) - => s -> m r -> m r +whileForcingThunk + :: forall t f m s e r . (Exception s, Convertible e t f m) => s -> m r -> m r whileForcingThunk frame = - withFrame Debug (ForcingThunk @m) . withFrame Debug frame - -instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m) - => ToValue A.Value m (NValue m) where - toValue = \case - A.Object m -> flip nvSet M.empty - <$> traverse (thunk . toValue @_ @_ @(NValue m)) m - A.Array l -> nvList <$> - traverse (\x -> thunk . whileForcingThunk (CoercionFromJson @m x) - . toValue $ x) (V.toList l) - A.String s -> pure $ nvStr s mempty - A.Number n -> pure $ nvConstant $ case floatingOrInteger n of - Left r -> NFloat r - Right i -> NInt i - A.Bool b -> pure $ nvConstant $ NBool b - A.Null -> pure $ nvConstant NNull + withFrame Debug (ForcingThunk @t @f @m) . withFrame Debug frame class FromNix a m v where fromNix :: v -> m a @@ -462,122 +424,105 @@ default fromNixMay :: FromValue a m v => v -> m (Maybe a) fromNixMay = fromValueMay -instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m, - FromNix a m (NValue m)) - => FromNix [a] m (NValue m) where - fromNixMay = \case - NVList l -> sequence <$> traverse (`force` fromNixMay) l - _ -> pure Nothing - fromNix v = fromNixMay v >>= \case - Just b -> pure b - _ -> throwError $ Expectation TList v - -instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m, - FromNix a m (NValue m)) - => FromNix (HashMap Text a) m (NValue m) where - fromNixMay = \case - NVSet s _ -> sequence <$> traverse (`force` fromNixMay) s - _ -> pure Nothing - fromNix v = fromNixMay v >>= \case - Just b -> pure b - _ -> throwError $ Expectation TSet v +instance (Convertible e t f m, FromNix a m (NValue t f m)) + => FromNix [a] m (NValue t f m) where + fromNixMay = \case + NVList l -> sequence <$> traverse (`force` fromNixMay) l + _ -> pure Nothing + fromNix v = fromNixMay v >>= \case + Just b -> pure b + _ -> throwError $ Expectation TList v -instance Convertible e m => FromNix () m (NValueNF m) where -instance Convertible e m => FromNix () m (NValue m) where -instance Convertible e m => FromNix Bool m (NValueNF m) where -instance Convertible e m => FromNix Bool m (NValue m) where -instance Convertible e m => FromNix Int m (NValueNF m) where -instance Convertible e m => FromNix Int m (NValue m) where -instance Convertible e m => FromNix Integer m (NValueNF m) where -instance Convertible e m => FromNix Integer m (NValue m) where -instance Convertible e m => FromNix Float m (NValueNF m) where -instance Convertible e m => FromNix Float m (NValue m) where -instance (Convertible e m, MonadEffects m) => FromNix Text m (NValueNF m) where -instance (Convertible e m, MonadEffects m, MonadThunk (NValue m) (NThunk m) m) => FromNix Text m (NValue m) where -instance (Convertible e m, MonadEffects m) => FromNix (Text, DList Text) m (NValueNF m) where -instance (Convertible e m, MonadEffects m, MonadThunk (NValue m) (NThunk m) m) => FromNix (Text, DList Text) m (NValue m) where -instance Convertible e m => FromNix ByteString m (NValueNF m) where -instance Convertible e m => FromNix ByteString m (NValue m) where -instance Convertible e m => FromNix Path m (NValueNF m) where -instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m) => FromNix Path m (NValue m) where -instance (Convertible e m, FromValue a m (NValueNF m), Show a) => FromNix [a] m (NValueNF m) where -instance Convertible e m => FromNix (HashMap Text (NValueNF m)) m (NValueNF m) where -instance Convertible e m => FromNix (HashMap Text (NValueNF m), HashMap Text SourcePos) m (NValueNF m) where -instance Convertible e m => FromNix (HashMap Text (NThunk m), HashMap Text SourcePos) m (NValue m) where -instance (Convertible e m, MonadEffects m, MonadThunk (NValue m) (NThunk m) m) => FromNix A.Value m (NValueNF m) where +instance (Convertible e t f m, FromNix a m (NValue t f m)) + => FromNix (HashMap Text a) m (NValue t f m) where + fromNixMay = \case + NVSet s _ -> sequence <$> traverse (`force` fromNixMay) s + _ -> pure Nothing + fromNix v = fromNixMay v >>= \case + Just b -> pure b + _ -> throwError $ Expectation TSet v -instance (Convertible e m, MonadEffects m, - MonadThunk (NValue m) (NThunk m) m) => FromNix A.Value m (NValue m) where - fromNixMay = fromNixMay <=< normalForm - fromNix = fromNix <=< normalForm +instance Convertible e t f m => FromNix () m (NValueNF t f m) where +instance Convertible e t f m => FromNix () m (NValue t f m) where +instance Convertible e t f m => FromNix Bool m (NValueNF t f m) where +instance Convertible e t f m => FromNix Bool m (NValue t f m) where +instance Convertible e t f m => FromNix Int m (NValueNF t f m) where +instance Convertible e t f m => FromNix Int m (NValue t f m) where +instance Convertible e t f m => FromNix Integer m (NValueNF t f m) where +instance Convertible e t f m => FromNix Integer m (NValue t f m) where +instance Convertible e t f m => FromNix Float m (NValueNF t f m) where +instance Convertible e t f m => FromNix Float m (NValue t f m) where +instance (Convertible e t f m, MonadEffects t f m) + => FromNix NixString m (NValueNF t f m) where +instance (Convertible e t f m, MonadEffects t f m) + => FromNix NixString m (NValue t f m) where +instance Convertible e t f m => FromNix ByteString m (NValueNF t f m) where +instance Convertible e t f m => FromNix ByteString m (NValue t f m) where +instance Convertible e t f m => FromNix Path m (NValueNF t f m) where +instance Convertible e t f m => FromNix Path m (NValue t f m) where +instance (Convertible e t f m, FromValue a m (NValueNF t f m), Show a) + => FromNix [a] m (NValueNF t f m) where +instance Convertible e t f m + => FromNix (HashMap Text (NValueNF t f m)) m (NValueNF t f m) where +instance Convertible e t f m + => FromNix (HashMap Text (NValueNF t f m), + HashMap Text SourcePos) m (NValueNF t f m) where +instance Convertible e t f m + => FromNix (HashMap Text t, HashMap Text SourcePos) m (NValue t f m) where instance (Monad m, FromNix a m v) => FromNix a m (m v) where - fromNixMay = (>>= fromNixMay) - fromNix = (>>= fromNix) - -instance (MonadThunk (NValue m) (NThunk m) m, FromNix a m (NValue m)) - => FromNix a m (NThunk m) where - fromNixMay = force ?? fromNixMay - fromNix = force ?? fromNix - -instance MonadThunk (NValue m) (NThunk m) m - => FromNix (NThunk m) m (NValue m) where - fromNixMay = pure . Just . value - fromNix = pure . value + fromNixMay = (>>= fromNixMay) + fromNix = (>>= fromNix) class ToNix a m v where toNix :: a -> m v default toNix :: ToValue a m v => a -> m v toNix = toValue -instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m, - ToNix a m (NValue m)) - => ToNix [a] m (NValue m) where - toNix = fmap nvList - . traverse (thunk . ((\v -> whileForcingThunk (ConcerningValue v) (pure v)) - <=< toNix)) - -instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m, - ToNix a m (NValue m)) - => ToNix (HashMap Text a) m (NValue m) where - toNix = fmap (flip nvSet M.empty) - . traverse (thunk . ((\v -> whileForcingThunk (ConcerningValue v) (pure v)) - <=< toNix)) +instance (Convertible e t f m, ToNix a m (NValue t f m)) + => ToNix [a] m (NValue t f m) where + toNix = fmap nvList . traverse (thunk . go) + where + go = + (\v -> whileForcingThunk @t @f @m (ConcerningValue v) (pure v)) <=< toNix -instance Applicative m => ToNix () m (NValueNF m) where -instance Applicative m => ToNix () m (NValue m) where -instance Applicative m => ToNix Bool m (NValueNF m) where -instance Applicative m => ToNix Bool m (NValue m) where -instance Applicative m => ToNix Int m (NValueNF m) where -instance Applicative m => ToNix Int m (NValue m) where -instance Applicative m => ToNix Integer m (NValueNF m) where -instance Applicative m => ToNix Integer m (NValue m) where -instance Applicative m => ToNix Float m (NValueNF m) where -instance Applicative m => ToNix Float m (NValue m) where -instance Applicative m => ToNix Text m (NValueNF m) where -instance Applicative m => ToNix Text m (NValue m) where -instance Applicative m => ToNix (Text, DList Text) m (NValueNF m) where -instance Applicative m => ToNix (Text, DList Text) m (NValue m) where -instance Applicative m => ToNix ByteString m (NValueNF m) where -instance Applicative m => ToNix ByteString m (NValue m) where -instance Applicative m => ToNix Path m (NValueNF m) where -instance Applicative m => ToNix Path m (NValue m) where -instance Applicative m => ToNix (HashMap Text (NValueNF m)) m (NValueNF m) where -instance Applicative m => ToNix (HashMap Text (NValueNF m), HashMap Text SourcePos) m (NValueNF m) where -instance Applicative m => ToNix (HashMap Text (NThunk m), HashMap Text SourcePos) m (NValue m) where -instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m) => ToNix A.Value m (NValue m) where -instance Applicative m => ToNix Bool m (NExprF r) where -instance Applicative m => ToNix () m (NExprF r) where +instance (Convertible e t f m, ToNix a m (NValue t f m)) + => ToNix (HashMap Text a) m (NValue t f m) where + toNix = fmap (flip nvSet M.empty) . traverse (thunk . go) + where + go = + (\v -> whileForcingThunk @t @f @m (ConcerningValue v) (pure v)) <=< toNix -instance (MonadThunk (NValue m) (NThunk m) m, ToNix a m (NValue m)) - => ToNix a m (NThunk m) where - toNix = thunk . toNix +instance Convertible e t f m => ToNix () m (NValueNF t f m) where +instance Convertible e t f m => ToNix () m (NValue t f m) where +instance Convertible e t f m => ToNix Bool m (NValueNF t f m) where +instance Convertible e t f m => ToNix Bool m (NValue t f m) where +instance Convertible e t f m => ToNix Int m (NValueNF t f m) where +instance Convertible e t f m => ToNix Int m (NValue t f m) where +instance Convertible e t f m => ToNix Integer m (NValueNF t f m) where +instance Convertible e t f m => ToNix Integer m (NValue t f m) where +instance Convertible e t f m => ToNix Float m (NValueNF t f m) where +instance Convertible e t f m => ToNix Float m (NValue t f m) where +instance Convertible e t f m => ToNix NixString m (NValueNF t f m) where +instance Convertible e t f m => ToNix NixString m (NValue t f m) where +instance Convertible e t f m => ToNix ByteString m (NValueNF t f m) where +instance Convertible e t f m => ToNix ByteString m (NValue t f m) where +instance Convertible e t f m => ToNix Path m (NValueNF t f m) where +instance Convertible e t f m => ToNix Path m (NValue t f m) where +instance Convertible e t f m + => ToNix (HashMap Text (NValueNF t f m)) m (NValueNF t f m) where +instance Convertible e t f m + => ToNix (HashMap Text (NValueNF t f m), + HashMap Text SourcePos) m (NValueNF t f m) where +instance Convertible e t f m + => ToNix (HashMap Text t, HashMap Text SourcePos) m (NValue t f m) where -instance (Applicative m, ToNix a m (NValueNF m)) => ToNix [a] m (NValueNF m) where - toNix = fmap (Fix . NVListF) . traverse toNix +instance Convertible e t f m => ToNix Bool m (NExprF r) where + toNix = pure . NConstant . NBool -instance MonadThunk (NValue m) (NThunk m) m => ToNix (NThunk m) m (NValue m) where - toNix = force ?? pure +instance Convertible e t f m => ToNix () m (NExprF r) where + toNix _ = pure $ NConstant NNull -convertNix :: forall a t m v. (FromNix a m t, ToNix a m v, Monad m) => t -> m v -convertNix = fromNix @a >=> toNix +instance (Convertible e t f m, ToNix a m (NValueNF t f m)) + => ToNix [a] m (NValueNF t f m) where + toNix = fmap nvListNF . traverse toNix diff --git a/src/Nix/Effects.hs b/src/Nix/Effects.hs --- a/src/Nix/Effects.hs +++ b/src/Nix/Effects.hs @@ -1,47 +1,258 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + module Nix.Effects where -import Data.Text (Text) -import Nix.Render -import Nix.Utils -import Nix.Value -import System.Posix.Files +import Prelude hiding ( putStr + , putStrLn + , print + ) +import qualified Prelude +import Control.Monad.Trans +import Data.Text ( Text ) +import qualified Data.Text as T +import Network.HTTP.Client hiding ( path ) +import Network.HTTP.Client.TLS +import Network.HTTP.Types +import Nix.Expr +import Nix.Frames +import Nix.Parser +import Nix.Render +import Nix.Utils +import Nix.Value +import qualified System.Directory as S +import System.Environment +import System.Exit +import qualified System.Info +import System.Process + -- | A path into the nix store newtype StorePath = StorePath { unStorePath :: FilePath } -class MonadFile m => MonadEffects m where - -- | Import a path into the nix store, and return the resulting path - addPath :: FilePath -> m StorePath - - toFile_ :: FilePath -> String -> m StorePath - +class (MonadFile m, + MonadStore m, + MonadPutStr m, + MonadHttp m, + MonadEnv m, + MonadInstantiate m, + MonadExec m, + MonadIntrospect m) => MonadEffects t f m where -- | Determine the absolute path of relative path in the current context makeAbsolutePath :: FilePath -> m FilePath findEnvPath :: String -> m FilePath -- | Having an explicit list of sets corresponding to the NIX_PATH -- and a file path try to find an existing path - findPath :: [NThunk m] -> FilePath -> m FilePath + findPath :: [t] -> FilePath -> m FilePath - pathExists :: FilePath -> m Bool - importPath :: AttrSet (NThunk m) -> FilePath -> m (NValue m) + importPath :: FilePath -> m (NValue t f m) + pathToDefaultNix :: FilePath -> m FilePath + derivationStrict :: NValue t f m -> m (NValue t f m) + + traceEffect :: String -> m () + +class Monad m => MonadIntrospect m where + recursiveSize :: a -> m Word + default recursiveSize :: (MonadTrans t, MonadIntrospect m', m ~ t m') => a -> m Word + recursiveSize = lift . recursiveSize + +instance MonadIntrospect IO where + recursiveSize = +#ifdef MIN_VERSION_ghc_datasize +#if MIN_VERSION_ghc_datasize(0,2,0) && __GLASGOW_HASKELL__ >= 804 +recursiveSize +#else +\_ -> return 0 +#endif +#else + \_ -> return 0 +#endif + +class Monad m => MonadExec m where + exec' :: [String] -> m (Either ErrorCall NExprLoc) + default exec' :: (MonadTrans t, MonadExec m', m ~ t m') + => [String] -> m (Either ErrorCall NExprLoc) + exec' = lift . exec' + +instance MonadExec IO where + exec' = \case + [] -> return $ Left $ ErrorCall "exec: missing program" + (prog : args) -> do + (exitCode, out, _) <- liftIO $ readProcessWithExitCode prog args "" + let t = T.strip (T.pack out) + let emsg = "program[" ++ prog ++ "] args=" ++ show args + case exitCode of + ExitSuccess -> if T.null t + then return $ Left $ ErrorCall $ "exec has no output :" ++ emsg + else case parseNixTextLoc t of + Failure err -> + return + $ Left + $ ErrorCall + $ "Error parsing output of exec: " + ++ show err + ++ " " + ++ emsg + Success v -> return $ Right v + err -> + return + $ Left + $ ErrorCall + $ "exec failed: " + ++ show err + ++ " " + ++ emsg + +class Monad m => MonadInstantiate m where + instantiateExpr :: String -> m (Either ErrorCall NExprLoc) + default instantiateExpr :: (MonadTrans t, MonadInstantiate m', m ~ t m') => String -> m (Either ErrorCall NExprLoc) + instantiateExpr = lift . instantiateExpr + +instance MonadInstantiate IO where + instantiateExpr expr = do + traceM $ "Executing: " ++ show + ["nix-instantiate", "--eval", "--expr ", expr] + (exitCode, out, err) <- readProcessWithExitCode "nix-instantiate" + ["--eval", "--expr", expr] + "" + case exitCode of + ExitSuccess -> case parseNixTextLoc (T.pack out) of + Failure e -> + return + $ Left + $ ErrorCall + $ "Error parsing output of nix-instantiate: " + ++ show e + Success v -> return $ Right v + status -> + return + $ Left + $ ErrorCall + $ "nix-instantiate failed: " + ++ show status + ++ ": " + ++ err + +pathExists :: MonadFile m => FilePath -> m Bool +pathExists = doesFileExist + +class Monad m => MonadEnv m where getEnvVar :: String -> m (Maybe String) + default getEnvVar :: (MonadTrans t, MonadEnv m', m ~ t m') => String -> m (Maybe String) + getEnvVar = lift . getEnvVar getCurrentSystemOS :: m Text + default getCurrentSystemOS :: (MonadTrans t, MonadEnv m', m ~ t m') => m Text + getCurrentSystemOS = lift getCurrentSystemOS getCurrentSystemArch :: m Text + default getCurrentSystemArch :: (MonadTrans t, MonadEnv m', m ~ t m') => m Text + getCurrentSystemArch = lift getCurrentSystemArch - listDirectory :: FilePath -> m [FilePath] - getSymbolicLinkStatus :: FilePath -> m FileStatus +instance MonadEnv IO where + getEnvVar = lookupEnv - derivationStrict :: NValue m -> m (NValue m) + getCurrentSystemOS = return $ T.pack System.Info.os - nixInstantiateExpr :: String -> m (NValue m) +-- Invert the conversion done by GHC_CONVERT_CPU in GHC's aclocal.m4 + getCurrentSystemArch = return $ T.pack $ case System.Info.arch of + "i386" -> "i686" + arch -> arch - getURL :: Text -> m (NValue m) +class Monad m => MonadHttp m where + getURL :: Text -> m (Either ErrorCall StorePath) + default getURL :: (MonadTrans t, MonadHttp m', m ~ t m') => Text -> m (Either ErrorCall StorePath) + getURL = lift . getURL - getRecursiveSize :: a -> m (NValue m) +instance MonadHttp IO where + getURL url = do + let urlstr = T.unpack 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) + if status /= 200 + then + return + $ Left + $ ErrorCall + $ "fail, got " + ++ show status + ++ " when fetching url:" + ++ urlstr + else -- do + -- let bstr = responseBody response + return + $ Left + $ ErrorCall + $ "success in downloading but hnix-store is not yet ready; url = " + ++ urlstr - traceEffect :: String -> m () - exec :: [String] -> m (NValue m) +class Monad m => MonadPutStr m where + --TODO: Should this be used *only* when the Nix to be evaluated invokes a + --`trace` operation? + putStr :: String -> m () + default putStr :: (MonadTrans t, MonadPutStr m', m ~ t m') => String -> m () + putStr = lift . putStr + +putStrLn :: MonadPutStr m => String -> m () +putStrLn = putStr . (++ "\n") + +print :: (MonadPutStr m, Show a) => a -> m () +print = putStrLn . show + +instance MonadPutStr IO where + putStr = Prelude.putStr + +class Monad m => MonadStore m where + -- | Import a path into the nix store, and return the resulting path + addPath' :: FilePath -> m (Either ErrorCall StorePath) + + -- | Add a file with the given name and contents to the nix store + toFile_' :: FilePath -> String -> m (Either ErrorCall StorePath) + +instance MonadStore IO where + addPath' path = do + (exitCode, out, _) <- readProcessWithExitCode "nix-store" ["--add", path] "" + case exitCode of + ExitSuccess -> do + let dropTrailingLinefeed p = take (length p - 1) p + return $ Right $ StorePath $ dropTrailingLinefeed out + _ -> + return + $ Left + $ ErrorCall + $ "addPath: failed: nix-store --add " + ++ show path + +--TODO: Use a temp directory so we don't overwrite anything important + toFile_' filepath content = do + writeFile filepath content + storepath <- addPath' filepath + S.removeFile filepath + return storepath + +addPath :: (Framed e m, MonadStore m) => FilePath -> m StorePath +addPath p = either throwError return =<< addPath' p + +toFile_ :: (Framed e m, MonadStore m) => FilePath -> String -> m StorePath +toFile_ p contents = either throwError return =<< toFile_' p contents + + + + + + diff --git a/src/Nix/Eval.hs b/src/Nix/Eval.hs --- a/src/Nix/Eval.hs +++ b/src/Nix/Eval.hs @@ -18,28 +18,32 @@ import Control.Monad.Fix import Control.Monad.Reader import Control.Monad.State.Strict -import Data.Align.Key (alignWithKey) -import Data.Either (isRight) -import Data.Fix (Fix(Fix)) -import Data.HashMap.Lazy (HashMap) -import qualified Data.HashMap.Lazy as M -import Data.List (partition) -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Maybe (fromMaybe, catMaybes) -import Data.Text (Text) -import Data.These (These(..)) -import Data.Traversable (for) +import Data.Align.Key ( alignWithKey ) +import Data.Either ( isRight ) +import Data.Fix ( Fix(Fix) ) +import Data.HashMap.Lazy ( HashMap ) +import qualified Data.HashMap.Lazy as M +import Data.List ( partition ) +import Data.List.NonEmpty ( NonEmpty(..) ) +import Data.Maybe ( fromMaybe + , catMaybes + ) +import Data.Text ( Text ) +import Data.These ( These(..) ) +import Data.Traversable ( for ) import Nix.Atoms import Nix.Convert import Nix.Expr import Nix.Frames +import Nix.String import Nix.Scope -import Nix.Strings (runAntiquoted) +import Nix.Strings ( runAntiquoted ) import Nix.Thunk import Nix.Utils -class (Show v, Monad m) => MonadEval v m | v -> m where +class (Show v, Monad m) => MonadEval v m where freeVariable :: Text -> m v + synHole :: Text -> m v attrMissing :: NonEmpty Text -> Maybe v -> m v evaledSym :: Text -> v -> m v evalCurPos :: m v @@ -75,302 +79,364 @@ -} evalError :: Exception s => s -> m a -type MonadNixEval e v t m = - (MonadEval v m, - Scoped e t m, - MonadThunk v t m, - MonadFix m, - ToValue Bool m v, - ToValue [t] m v, - FromValue (Text, DList Text) m v, - ToValue (AttrSet t, AttrSet SourcePos) m v, - FromValue (AttrSet t, AttrSet SourcePos) m v) +type MonadNixEval v t m + = ( MonadEval v m + , Scoped t m + , MonadThunk t m v + , MonadFix m + , ToValue Bool m v + , ToValue [t] m v + , FromValue NixString m v + , ToValue (AttrSet t, AttrSet SourcePos) m v + , FromValue (AttrSet t, AttrSet SourcePos) m v + ) -data EvalFrame m v - = EvaluatingExpr (Scopes m v) NExprLoc - | ForcingExpr (Scopes m v) NExprLoc +data EvalFrame m t + = EvaluatingExpr (Scopes m t) NExprLoc + | ForcingExpr (Scopes m t) NExprLoc | Calling String SrcSpan + | SynHole (SynHoleInfo m t) deriving (Show, Typeable) -instance (Typeable m, Typeable v) => Exception (EvalFrame m v) +instance (Typeable m, Typeable t) => Exception (EvalFrame m t) -eval :: forall e v t m. MonadNixEval e v t m => NExprF (m v) -> m v +data SynHoleInfo m t = SynHoleInfo + { _synHoleInfo_expr :: NExprLoc + , _synHoleInfo_scope :: Scopes m t + } deriving (Show, Typeable) +instance (Typeable m, Typeable t) => Exception (SynHoleInfo m t) + +eval :: forall v t m . MonadNixEval v t m => NExprF (m v) -> m v + eval (NSym "__curPos") = evalCurPos -eval (NSym var) = - lookupVar var >>= maybe (freeVariable var) (force ?? evaledSym var) +eval (NSym var ) = (lookupVar var :: m (Maybe t)) + >>= maybe (freeVariable var) (force ?? evaledSym var) -eval (NConstant x) = evalConstant x -eval (NStr str) = evalString str -eval (NLiteralPath p) = evalLiteralPath p -eval (NEnvPath p) = evalEnvPath p -eval (NUnary op arg) = evalUnary op =<< arg +eval (NConstant x ) = evalConstant x +eval (NStr str ) = evalString str +eval (NLiteralPath p ) = evalLiteralPath p +eval (NEnvPath p ) = evalEnvPath p +eval (NUnary op arg ) = evalUnary op =<< arg eval (NBinary NApp fun arg) = do - scope <- currentScopes @_ @t - fun >>= (`evalApp` withScopes scope arg) + scope <- currentScopes :: m (Scopes m t) + fun >>= (`evalApp` withScopes scope arg) -eval (NBinary op larg rarg) = larg >>= evalBinary op ?? rarg +eval (NBinary op larg rarg) = larg >>= evalBinary op ?? rarg -eval (NSelect aset attr alt) = evalSelect aset attr >>= either go id - where - go (s, ks) = fromMaybe (attrMissing ks (Just s)) alt +eval (NSelect aset attr alt ) = evalSelect aset attr >>= either go id + where go (s, ks) = fromMaybe (attrMissing ks (Just s)) alt eval (NHasAttr aset attr) = evalSelect aset attr >>= toValue . isRight -eval (NList l) = do - scope <- currentScopes - for l (thunk . withScopes @t scope) >>= toValue +eval (NList l ) = do + scope <- currentScopes + for l (thunk @t @m @v . withScopes @t scope) >>= toValue eval (NSet binds) = - evalBinds False (desugarBinds (eval . NSet) binds) >>= toValue + evalBinds False (desugarBinds (eval . NSet) binds) >>= toValue eval (NRecSet binds) = - evalBinds True (desugarBinds (eval . NRecSet) binds) >>= toValue + evalBinds True (desugarBinds (eval . NSet) binds) >>= toValue -eval (NLet binds body) = evalBinds True binds >>= (pushScope ?? body) . fst +eval (NLet binds body ) = evalBinds True binds >>= (pushScope ?? body) . fst -eval (NIf cond t f) = cond >>= \v -> evalIf v t f +eval (NIf cond t f ) = cond >>= \v -> evalIf v t f -eval (NWith scope body) = evalWith scope body +eval (NWith scope body) = evalWith scope body -eval (NAssert cond body) = cond >>= evalAssert ?? body +eval (NAssert cond body) = cond >>= evalAssert ?? body -eval (NAbs params body) = do +eval (NAbs params body) = do -- It is the environment at the definition site, not the call site, that -- 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 @_ @t - evalAbs params $ \arg k -> withScopes @t scope $ do - args <- buildArgument params arg - pushScope args (k (M.map (`force` pure) args) body) + scope <- currentScopes :: m (Scopes m t) + evalAbs params $ \arg k -> withScopes scope $ do + args <- buildArgument params arg + pushScope args (k (M.map (`force` pure) args) body) +eval (NSynHole name) = synHole name + -- | If you know that the 'scope' action will result in an 'AttrSet t', then -- this implementation may be used as an implementation for 'evalWith'. -evalWithAttrSet :: forall e v t m. MonadNixEval e v t m => m v -> m v -> m v +evalWithAttrSet :: forall v t m . MonadNixEval v t m => m v -> m v -> m v evalWithAttrSet aset body = do -- The scope is deliberately wrapped in a thunk here, since it is -- evaluated each time a name is looked up within the weak scope, and -- we want to be sure the action it evaluates is to force a thunk, so -- its value is only computed once. - scope <- currentScopes @_ @t - s <- thunk $ withScopes scope aset - pushWeakScope ?? body $ force s $ - fmap fst . fromValue @(AttrSet t, AttrSet SourcePos) + scope <- currentScopes :: m (Scopes m t) + s <- thunk @t @m @v $ withScopes scope aset + pushWeakScope + ?? body + $ force s + $ fmap fst + . fromValue @(AttrSet t, AttrSet SourcePos) -attrSetAlter :: forall e v t m. MonadNixEval e v t m - => [Text] - -> SourcePos - -> AttrSet (m v) - -> AttrSet SourcePos - -> m v - -> m (AttrSet (m v), AttrSet SourcePos) +attrSetAlter + :: forall v t m + . MonadNixEval v t m + => [Text] + -> SourcePos + -> AttrSet (m v) + -> AttrSet SourcePos + -> m v + -> m (AttrSet (m v), AttrSet SourcePos) attrSetAlter [] _ _ _ _ = - evalError @v $ ErrorCall "invalid selector with no components" + evalError @v $ ErrorCall "invalid selector with no components" -attrSetAlter (k:ks) pos m p val = case M.lookup k m of - Nothing | null ks -> go - | otherwise -> recurse M.empty M.empty - Just x | null ks -> go - | otherwise -> - x >>= fromValue @(AttrSet t, AttrSet SourcePos) - >>= \(st, sp) -> recurse (force ?? pure <$> st) sp - where - go = return (M.insert k val m, M.insert k pos p) +attrSetAlter (k : ks) pos m p val = case M.lookup k m of + Nothing | null ks -> go + | otherwise -> recurse M.empty M.empty + Just x + | null ks + -> go + | otherwise + -> x >>= fromValue @(AttrSet t, AttrSet SourcePos) >>= \(st, sp) -> + recurse (force ?? pure <$> st) sp + where + go = return (M.insert k val m, M.insert k pos p) - recurse st sp = attrSetAlter ks pos st sp val <&> \(st', _) -> - ( M.insert k (toValue @(AttrSet t, AttrSet SourcePos) - =<< (, mempty) . fmap value <$> sequence st') st - , M.insert k pos sp ) + recurse st sp = attrSetAlter ks pos st sp val <&> \(st', _) -> + ( M.insert + k + ( toValue @(AttrSet t, AttrSet SourcePos) + =<< (, mempty) + . fmap wrapValue + <$> sequence st' + ) + st + , M.insert k pos sp + ) -desugarBinds :: forall r. ([Binding r] -> r) -> [Binding r] -> [Binding r] +desugarBinds :: forall r . ([Binding r] -> r) -> [Binding r] -> [Binding r] desugarBinds embed binds = evalState (mapM (go <=< collect) binds) M.empty - where - collect :: Binding r - -> State (HashMap VarName (SourcePos, [Binding r])) - (Either VarName (Binding r)) - collect (NamedVar (StaticKey x :| y:ys) val p) = do - m <- get - put $ M.insert x ?? m $ case M.lookup x m of - Nothing -> (p, [NamedVar (y:|ys) val p]) - Just (q, v) -> (q, NamedVar (y:|ys) val q : v) - pure $ Left x - collect x = pure $ Right x + where + collect + :: Binding r + -> State + (HashMap VarName (SourcePos, [Binding r])) + (Either VarName (Binding r)) + collect (NamedVar (StaticKey x :| y : ys) val p) = do + m <- get + put $ M.insert x ?? m $ case M.lookup x m of + Nothing -> (p, [NamedVar (y :| ys) val p]) + Just (q, v) -> (q, NamedVar (y :| ys) val q : v) + pure $ Left x + collect x = pure $ Right x - go :: Either VarName (Binding r) - -> State (HashMap VarName (SourcePos, [Binding r])) - (Binding r) - go (Right x) = pure x - go (Left x) = do - Just (p, v) <- gets $ M.lookup x - pure $ NamedVar (StaticKey x :| []) (embed v) p + go + :: Either VarName (Binding r) + -> State (HashMap VarName (SourcePos, [Binding r])) (Binding r) + go (Right x) = pure x + go (Left x) = do + maybeValue <- gets (M.lookup x) + case maybeValue of + Nothing -> fail ("No binding " ++ show x) + Just (p, v) -> pure $ NamedVar (StaticKey x :| []) (embed v) p -evalBinds :: forall e v t m. MonadNixEval e v t m - => Bool - -> [Binding (m v)] - -> m (AttrSet t, AttrSet SourcePos) +evalBinds + :: forall v t m + . MonadNixEval v t m + => Bool + -> [Binding (m v)] + -> m (AttrSet t, AttrSet SourcePos) evalBinds recursive binds = do - scope <- currentScopes @_ @t - buildResult scope . concat =<< mapM (go scope) (moveOverridesLast binds) - where - moveOverridesLast = (\(x, y) -> y ++ x) . - partition (\case NamedVar (StaticKey "__overrides" :| []) _ _pos -> True - _ -> False) + scope <- currentScopes :: m (Scopes m t) + buildResult scope . concat =<< mapM (go scope) (moveOverridesLast binds) + where + moveOverridesLast = uncurry (++) . partition + (\case + NamedVar (StaticKey "__overrides" :| []) _ _pos -> False + _ -> True + ) - go :: Scopes m t -> Binding (m v) -> m [([Text], SourcePos, m v)] - go _ (NamedVar (StaticKey "__overrides" :| []) finalValue pos) = - finalValue >>= fromValue >>= \(o', p') -> - -- jww (2018-05-09): What to do with the key position here? - return $ map (\(k, v) -> ([k], fromMaybe pos (M.lookup k p'), - force v pure)) - (M.toList o') + go :: Scopes m t -> Binding (m v) -> m [([Text], SourcePos, m v)] + go _ (NamedVar (StaticKey "__overrides" :| []) finalValue pos) = + finalValue >>= fromValue >>= \(o', p') -> + -- jww (2018-05-09): What to do with the key position here? + return $ map + (\(k, v) -> ([k], fromMaybe pos (M.lookup k p'), force @t @m @v v pure)) + (M.toList o') - go _ (NamedVar pathExpr finalValue pos) = do - let go :: NAttrPath (m v) -> m ([Text], SourcePos, m v) - go = \case - h :| t -> evalSetterKeyName h >>= \case - Nothing -> - pure ([], nullPos, - toValue @(AttrSet t, AttrSet SourcePos) - (mempty, mempty)) - Just k -> case t of - [] -> pure ([k], pos, finalValue) - x:xs -> do - (restOfPath, _, v) <- go (x:|xs) - pure (k : restOfPath, pos, v) - go pathExpr <&> \case - -- When there are no path segments, e.g. `${null} = 5;`, we don't - -- bind anything - ([], _, _) -> [] - result -> [result] + go _ (NamedVar pathExpr finalValue pos) = do + let go :: NAttrPath (m v) -> m ([Text], SourcePos, m v) + go = \case + h :| t -> evalSetterKeyName h >>= \case + Nothing -> + pure + ( [] + , nullPos + , toValue @(AttrSet t, AttrSet SourcePos) (mempty, mempty) + ) + Just k -> case t of + [] -> pure ([k], pos, finalValue) + x : xs -> do + (restOfPath, _, v) <- go (x :| xs) + pure (k : restOfPath, pos, v) + go pathExpr <&> \case + -- When there are no path segments, e.g. `${null} = 5;`, we don't + -- bind anything + ([], _, _) -> [] + result -> [result] - go scope (Inherit ms names pos) = fmap catMaybes $ forM names $ - evalSetterKeyName >=> \case - Nothing -> pure Nothing - Just key -> pure $ Just ([key], pos, do - mv <- case ms of - Nothing -> withScopes scope $ lookupVar key - Just s -> s - >>= fromValue @(AttrSet t, AttrSet SourcePos) - >>= \(s, _) -> - clearScopes @t $ pushScope s $ lookupVar key - case mv of - Nothing -> attrMissing (key :| []) Nothing - Just v -> force v pure) + go scope (Inherit ms names pos) = + fmap catMaybes $ forM names $ evalSetterKeyName >=> \case + Nothing -> pure Nothing + Just key -> pure $ Just + ( [key] + , pos + , do + mv <- case ms of + Nothing -> withScopes scope $ lookupVar key + Just s -> + s >>= fromValue @(AttrSet t, AttrSet SourcePos) >>= \(s, _) -> + clearScopes @t $ pushScope s $ lookupVar key + case mv of + Nothing -> attrMissing (key :| []) Nothing + Just v -> force v pure + ) - buildResult :: Scopes m t - -> [([Text], SourcePos, m v)] - -> m (AttrSet t, AttrSet SourcePos) - buildResult scope bindings = do - (s, p) <- foldM insert (M.empty, M.empty) bindings - res <- if recursive - then loebM (encapsulate <$> s) - else traverse mkThunk s - return (res, p) - where - mkThunk = thunk . withScopes scope + buildResult + :: Scopes m t + -> [([Text], SourcePos, m v)] + -> m (AttrSet t, AttrSet SourcePos) + buildResult scope bindings = do + (s, p) <- foldM insert (M.empty, M.empty) bindings + res <- if recursive then loebM (encapsulate <$> s) else traverse mkThunk s + return (res, p) + where + mkThunk = thunk . withScopes scope - encapsulate f attrs = mkThunk . pushScope attrs $ f + encapsulate f attrs = mkThunk . pushScope attrs $ f - insert (m, p) (path, pos, value) = attrSetAlter path pos m p value + insert (m, p) (path, pos, value) = attrSetAlter path pos m p value -evalSelect :: forall e v t m. MonadNixEval e v t m - => m v - -> NAttrPath (m v) - -> m (Either (v, NonEmpty Text) (m v)) +evalSelect + :: forall v t m + . MonadNixEval v t m + => m v + -> NAttrPath (m v) + -> m (Either (v, NonEmpty Text) (m v)) evalSelect aset attr = do - s <- aset - path <- traverse evalGetterKeyName attr - extract s path - where - extract x path@(k:|ks) = fromValueMay x >>= \case - Just (s :: AttrSet t, p :: AttrSet SourcePos) - | Just t <- M.lookup k s -> case ks of - [] -> pure $ Right $ force t pure - y:ys -> force t $ extract ?? (y:|ys) - | otherwise -> Left . (, path) <$> toValue (s, p) - Nothing -> return $ Left (x, path) + s <- aset + path <- traverse evalGetterKeyName attr + extract s path + where + extract x path@(k :| ks) = fromValueMay x >>= \case + Just (s :: AttrSet t, p :: AttrSet SourcePos) + | Just t <- M.lookup k s -> case ks of + [] -> pure $ Right $ force t pure + y : ys -> force t $ extract ?? (y :| ys) + | otherwise -> Left . (, path) <$> toValue (s, p) + Nothing -> return $ Left (x, path) -- | Evaluate a component of an attribute path in a context where we are -- *retrieving* a value -evalGetterKeyName :: forall v m. (MonadEval v m, FromValue (Text, DList Text) m v) - => NKeyName (m v) -> m Text +evalGetterKeyName + :: forall v m + . (MonadEval v m, FromValue NixString m v) + => NKeyName (m v) + -> m Text evalGetterKeyName = evalSetterKeyName >=> \case - Just k -> pure k - Nothing -> evalError @v $ ErrorCall "value is null while a string was expected" + Just k -> pure k + Nothing -> + evalError @v $ ErrorCall "value is null while a string was expected" -- | Evaluate a component of an attribute path in a context where we are -- *binding* a value -evalSetterKeyName :: (MonadEval v m, FromValue (Text, DList Text) m v) - => NKeyName (m v) -> m (Maybe Text) +evalSetterKeyName + :: (MonadEval v m, FromValue NixString m v) + => NKeyName (m v) + -> m (Maybe Text) evalSetterKeyName = \case - StaticKey k -> pure (Just k) - DynamicKey k -> runAntiquoted "\n" assembleString (>>= fromValueMay) k - <&> \case Just (t, _) -> Just t - _ -> Nothing + StaticKey k -> pure (Just k) + DynamicKey k -> + runAntiquoted "\n" assembleString (>>= fromValueMay) k <&> \case + Just ns -> Just (hackyStringIgnoreContext ns) + _ -> Nothing -assembleString :: forall v m. (MonadEval v m, FromValue (Text, DList Text) m v) - => NString (m v) -> m (Maybe (Text, DList Text)) +assembleString + :: forall v m + . (MonadEval v m, FromValue NixString m v) + => NString (m v) + -> m (Maybe NixString) assembleString = \case - Indented _ parts -> fromParts parts - DoubleQuoted parts -> fromParts parts - where - fromParts = fmap (fmap mconcat . sequence) . traverse go + Indented _ parts -> fromParts parts + DoubleQuoted parts -> fromParts parts + where + fromParts = fmap (fmap principledStringMConcat . sequence) . traverse go - go = runAntiquoted "\n" (pure . Just . (, mempty)) (>>= fromValueMay) + go = runAntiquoted "\n" + (pure . Just . principledMakeNixStringWithoutContext) + (>>= fromValueMay) -buildArgument :: forall e v t m. MonadNixEval e v t m - => Params (m v) -> m v -> m (AttrSet t) +buildArgument + :: forall v t m . MonadNixEval v t m => Params (m v) -> m v -> m (AttrSet t) buildArgument params arg = do - scope <- currentScopes @_ @t - case params of - Param name -> M.singleton name <$> thunk (withScopes scope arg) - ParamSet s isVariadic m -> - arg >>= fromValue @(AttrSet t, AttrSet SourcePos) - >>= \(args, _) -> do - let inject = case m of - Nothing -> id - Just n -> M.insert n $ const $ - thunk (withScopes scope arg) - loebM (inject $ alignWithKey (assemble scope isVariadic) - args (M.fromList s)) - where - assemble :: Scopes m t - -> Bool - -> Text - -> These t (Maybe (m v)) - -> AttrSet t - -> m t - assemble scope isVariadic k = \case - That Nothing -> - const $ evalError @v $ ErrorCall $ - "Missing value for parameter: " ++ show k - That (Just f) -> \args -> - thunk $ withScopes scope $ pushScope args f - This x | isVariadic -> const (pure x) - | otherwise -> - const $ evalError @v $ ErrorCall $ - "Unexpected parameter: " ++ show k - These x _ -> const (pure x) + scope <- currentScopes :: m (Scopes m t) + case params of + Param name -> M.singleton name <$> thunk (withScopes scope arg) + ParamSet s isVariadic m -> + arg >>= fromValue @(AttrSet t, AttrSet SourcePos) >>= \(args, _) -> do + let inject = case m of + Nothing -> id + Just n -> M.insert n $ const $ thunk (withScopes scope arg) + loebM + (inject $ M.mapMaybe id $ alignWithKey (assemble scope isVariadic) + args + (M.fromList s) + ) + where + assemble + :: Scopes m t + -> Bool + -> Text + -> These t (Maybe (m v)) + -> Maybe (AttrSet t -> m t) + assemble scope isVariadic k = \case + That Nothing -> + Just + $ const + $ evalError @v + $ ErrorCall + $ "Missing value for parameter: " + ++ show k + That (Just f) -> + Just $ \args -> thunk $ withScopes scope $ pushScope args f + This _ + | isVariadic + -> Nothing + | otherwise + -> Just + $ const + $ evalError @v + $ ErrorCall + $ "Unexpected parameter: " + ++ show k + These x _ -> Just (const (pure x)) -addSourcePositions :: (MonadReader e m, Has e SrcSpan) - => Transform NExprLocF (m a) +addSourcePositions + :: (MonadReader e m, Has e SrcSpan) => Transform NExprLocF (m a) addSourcePositions f v@(Fix (Compose (Ann ann _))) = - local (set hasLens ann) (f v) + local (set hasLens ann) (f v) addStackFrames - :: forall t e m a. (Scoped e t m, Framed e m, Typeable t, Typeable m) - => Transform NExprLocF (m a) + :: forall t e m a + . (Scoped t m, Framed e m, Typeable t, Typeable m) + => Transform NExprLocF (m a) addStackFrames f v = do - scopes <- currentScopes @e @t - withFrame Info (EvaluatingExpr scopes v) (f v) + scopes <- currentScopes :: m (Scopes m t) + withFrame Info (EvaluatingExpr scopes v) (f v) framedEvalExprLoc - :: forall t e v m. - (MonadNixEval e v t m, Framed e m, Has e SrcSpan, - Typeable t, Typeable m) - => NExprLoc -> m v -framedEvalExprLoc = adi (eval . annotated . getCompose) - (addStackFrames @t . addSourcePositions) + :: forall t e v m + . (MonadNixEval v t m, Framed e m, Has e SrcSpan, Typeable t, Typeable m) + => NExprLoc + -> m v +framedEvalExprLoc = + adi (eval . annotated . getCompose) (addStackFrames @t . addSourcePositions) diff --git a/src/Nix/Exec.hs b/src/Nix/Exec.hs --- a/src/Nix/Exec.hs +++ b/src/Nix/Exec.hs @@ -26,783 +26,929 @@ module Nix.Exec where -import Control.Applicative -import Control.Monad -import Control.Monad.Catch -import Control.Monad.Fix -import Control.Monad.IO.Class -import Control.Monad.Reader -import Control.Monad.State.Strict -import Control.Monad.Trans.Reader (ReaderT(..)) -import Control.Monad.Trans.State.Strict (StateT(..)) -import qualified Data.ByteString as BS -import Data.Coerce -import Data.Fix -import Data.HashMap.Lazy (HashMap) -import qualified Data.HashMap.Lazy as M -import Data.IORef -import Data.List -import qualified Data.List.NonEmpty as NE -import Data.List.Split -import Data.Monoid -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Typeable -import Network.HTTP.Client -import Network.HTTP.Client.TLS -import Network.HTTP.Types -import Nix.Atoms -import Nix.Context -import Nix.Convert -import Nix.Effects -import Nix.Eval as Eval -import Nix.Expr -import Nix.Frames -import Nix.Normal -import Nix.Options -import Nix.Parser -import Nix.Pretty -import Nix.Render -import Nix.Scope -import Nix.Thunk -import Nix.Utils -import Nix.Value -#ifdef MIN_VERSION_haskeline -import System.Console.Haskeline.MonadException hiding (catch) -#endif -import System.Directory -import System.Environment -import System.Exit (ExitCode (ExitSuccess)) -import System.FilePath -import qualified System.Info -import System.Posix.Files -import System.Process (readProcessWithExitCode) -import Text.PrettyPrint.ANSI.Leijen (text) -import qualified Text.PrettyPrint.ANSI.Leijen as P -#ifdef MIN_VERSION_pretty_show -import qualified Text.Show.Pretty as PS -#endif - -#ifdef MIN_VERSION_ghc_datasize -#if MIN_VERSION_ghc_datasize(0,2,0) && __GLASGOW_HASKELL__ >= 804 -import GHC.DataSize -#endif -#endif - -type MonadNix e m = - (Scoped e (NThunk m) m, Framed e m, Has e SrcSpan, Has e Options, - Typeable m, MonadVar m, MonadEffects m, MonadFix m, MonadCatch m, - Alternative m) - -data ExecFrame m = Assertion SrcSpan (NValue m) - deriving (Show, Typeable) - -instance Typeable m => Exception (ExecFrame m) - -nverr :: forall s e m a. (MonadNix e m, Exception s) => s -> m a -nverr = evalError @(NValue m) - -currentPos :: forall e m. (MonadReader e m, Has e SrcSpan) => m SrcSpan -currentPos = asks (view hasLens) - -wrapExprLoc :: SrcSpan -> NExprLocF r -> NExprLoc -wrapExprLoc span x = Fix (Fix (NSym_ span "") <$ x) - -instance MonadNix e m => MonadThunk (NValue m) (NThunk m) m where - thunk mv = do - opts :: Options <- asks (view hasLens) - - if thunks opts - then do - frames :: Frames <- asks (view hasLens) - - -- Gather the current evaluation context at the time of thunk - -- creation, and record it along with the thunk. - let go (fromException -> - Just (EvaluatingExpr scope - (Fix (Compose (Ann span e))))) = - let e' = Compose (Ann span (Nothing <$ e)) - in [Provenance scope e'] - go _ = [] - ps = concatMap (go . frame) frames - - fmap (NThunk ps . coerce) . buildThunk $ mv - else - fmap (NThunk [] . coerce) . buildThunk $ mv - - -- The ThunkLoop exception is thrown as an exception with MonadThrow, - -- which does not capture the current stack frame information to provide - -- it in a NixException, so we catch and re-throw it here using - -- 'throwError' from Frames.hs. - force (NThunk ps t) f = catch go (throwError @ThunkLoop) - where - go = case ps of - [] -> forceThunk t f - Provenance scope e@(Compose (Ann span _)):_ -> - withFrame Info (ForcingExpr scope (wrapExprLoc span e)) - (forceThunk t f) - - value = NThunk [] . coerce . valueRef - -{- -prov :: MonadNix e m - => (NValue m -> Provenance m) -> NValue m -> m (NValue m) -prov p v = do - opts :: Options <- asks (view hasLens) - pure $ if values opts - then addProvenance p v - else v --} - -instance MonadNix e m => MonadEval (NValue m) m where - freeVariable var = - nverr $ ErrorCall $ "Undefined variable '" ++ Text.unpack var ++ "'" - - attrMissing ks Nothing = - evalError @(NValue m) $ ErrorCall $ - "Inheriting unknown attribute: " - ++ intercalate "." (map Text.unpack (NE.toList ks)) - - attrMissing ks (Just s) = - evalError @(NValue m) $ ErrorCall $ "Could not look up attribute " - ++ intercalate "." (map Text.unpack (NE.toList ks)) - ++ " in " ++ show s - - evalCurPos = do - scope <- currentScopes - span@(SrcSpan delta _) <- currentPos - addProvenance (\_ -> Provenance scope (NSym_ span "__curPos")) - <$> toValue delta - - evaledSym name val = do - scope <- currentScopes - span <- currentPos - pure $ addProvenance (const $ Provenance scope (NSym_ span name)) val - - evalConstant c = do - scope <- currentScopes - span <- currentPos - pure $ nvConstantP (Provenance scope (NConstant_ span c)) c - - evalString = assembleString >=> \case - Just (s, c) -> do - scope <- currentScopes - span <- currentPos - pure $ nvStrP (Provenance scope - (NStr_ span (DoubleQuoted [Plain s]))) s c - Nothing -> nverr $ ErrorCall "Failed to assemble string" - - evalLiteralPath p = do - scope <- currentScopes - span <- currentPos - nvPathP (Provenance scope (NLiteralPath_ span p)) <$> makeAbsolutePath p - - evalEnvPath p = do - scope <- currentScopes - span <- currentPos - nvPathP (Provenance scope (NEnvPath_ span p)) <$> findEnvPath p - - evalUnary op arg = do - scope <- currentScopes - span <- currentPos - execUnaryOp scope span op arg - - evalBinary op larg rarg = do - scope <- currentScopes - span <- currentPos - execBinaryOp scope span op larg rarg - - evalWith c b = do - scope <- currentScopes - span <- currentPos - addProvenance (\b -> Provenance scope (NWith_ span Nothing (Just b))) - <$> evalWithAttrSet c b - - evalIf c t f = do - scope <- currentScopes - span <- currentPos - fromValue c >>= \b -> - if b - then addProvenance (\t -> Provenance scope (NIf_ span (Just c) (Just t) Nothing)) <$> t - else addProvenance (\f -> Provenance scope (NIf_ span (Just c) Nothing (Just f))) <$> f - - evalAssert c body = fromValue c >>= \b -> do - span <- currentPos - if b - then do - scope <- currentScopes - addProvenance (\b -> Provenance scope (NAssert_ span (Just c) (Just b))) <$> body - else nverr $ Assertion span c - - evalApp f x = do - scope <- currentScopes - span <- currentPos - addProvenance (const $ Provenance scope (NBinary_ span NApp (Just f) Nothing)) - <$> callFunc f x - - evalAbs p k = do - scope <- currentScopes - span <- currentPos - pure $ nvClosureP (Provenance scope (NAbs_ span (Nothing <$ p) Nothing)) - (void p) (\arg -> snd <$> k arg (\_ b -> ((),) <$> b)) - - evalError = throwError - -infixl 1 `callFunc` -callFunc :: forall e m. (MonadNix e m, Typeable m) - => NValue m -> m (NValue m) -> m (NValue m) -callFunc fun arg = case fun of - NVClosure params f -> do - traceM $ "callFunc:NVFunction taking " ++ show params - f arg - NVBuiltin name f -> do - span <- currentPos - withFrame Info (Calling @m @(NThunk m) name span) $ f arg - s@(NVSet m _) | Just f <- M.lookup "__functor" m -> do - traceM "callFunc:__functor" - force f $ (`callFunc` pure s) >=> (`callFunc` arg) - x -> throwError $ ErrorCall $ "Attempt to call non-function: " ++ show x - -execUnaryOp :: (Framed e m, MonadVar m) - => Scopes m (NThunk m) -> SrcSpan -> NUnaryOp -> NValue m - -> m (NValue m) -execUnaryOp scope span op arg = do - traceM "NUnary" - 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) - _ -> throwError $ ErrorCall $ - "unsupported argument type for unary operator " ++ show op - x -> throwError $ ErrorCall $ "argument to unary operator" - ++ " must evaluate to an atomic type: " ++ show x - where - unaryOp = pure . nvConstantP (Provenance scope (NUnary_ span op (Just arg))) - -execBinaryOp - :: forall e m. (MonadNix e m, MonadEval (NValue m) m) - => Scopes m (NThunk m) - -> SrcSpan - -> NBinaryOp - -> NValue m - -> m (NValue m) - -> m (NValue m) - -execBinaryOp scope span NOr larg rarg = fromNix larg >>= \l -> - if l - then orOp Nothing True - else rarg >>= \rval -> fromNix @Bool rval >>= orOp (Just rval) - where - orOp r b = pure $ - nvConstantP (Provenance scope (NBinary_ span NOr (Just larg) r)) (NBool b) - -execBinaryOp scope span NAnd larg rarg = fromNix larg >>= \l -> - if l - then rarg >>= \rval -> fromNix @Bool rval >>= andOp (Just rval) - else andOp Nothing False - where - andOp r b = pure $ - nvConstantP (Provenance scope (NBinary_ span NAnd (Just larg) r)) (NBool b) - -execBinaryOp scope span op lval rarg = do - rval <- rarg - let bin :: (Provenance m -> a) -> a - bin f = f (Provenance scope (NBinary_ span op (Just lval) (Just rval))) - toBool = pure . bin nvConstantP . NBool - case (lval, rval) of - (NVConstant lc, NVConstant rc) -> case (op, lc, rc) of - (NEq, _, _) -> toBool =<< valueEq lval rval - (NNEq, _, _) -> toBool . not =<< valueEq lval rval - (NLt, l, r) -> toBool $ l < r - (NLte, l, r) -> toBool $ l <= r - (NGt, l, r) -> toBool $ l > r - (NGte, l, r) -> toBool $ l >= r - (NAnd, _, _) -> - nverr $ ErrorCall "should be impossible: && is handled above" - (NOr, _, _) -> - nverr $ ErrorCall "should be impossible: || is handled above" - (NPlus, l, r) -> numBinOp bin (+) l r - (NMinus, l, r) -> numBinOp bin (-) l r - (NMult, l, r) -> numBinOp bin (*) l r - (NDiv, l, r) -> numBinOp' bin div (/) l r - (NImpl, - NBool l, NBool r) -> toBool $ not l || r - _ -> nverr $ ErrorCall $ unsupportedTypes lval rval - - (NVStr ls lc, NVStr rs rc) -> case op of - NPlus -> pure $ bin nvStrP (ls `mappend` rs) (lc `mappend` rc) - NEq -> toBool =<< valueEq lval rval - NNEq -> toBool . not =<< valueEq lval rval - NLt -> toBool $ ls < rs - NLte -> toBool $ ls <= rs - NGt -> toBool $ ls > rs - NGte -> toBool $ ls >= rs - _ -> nverr $ ErrorCall $ unsupportedTypes lval rval - - (NVStr _ _, NVConstant NNull) -> case op of - NEq -> toBool =<< valueEq lval (nvStr "" mempty) - NNEq -> toBool . not =<< valueEq lval (nvStr "" mempty) - _ -> nverr $ ErrorCall $ unsupportedTypes lval rval - - (NVConstant NNull, NVStr _ _) -> case op of - NEq -> toBool =<< valueEq (nvStr "" mempty) rval - NNEq -> toBool . not =<< valueEq (nvStr "" mempty) rval - _ -> nverr $ ErrorCall $ unsupportedTypes lval rval - - (NVSet ls lp, NVSet rs rp) -> case op of - NUpdate -> pure $ bin nvSetP (rs `M.union` ls) (rp `M.union` lp) - NEq -> toBool =<< valueEq lval rval - NNEq -> toBool . not =<< valueEq lval rval - _ -> nverr $ ErrorCall $ unsupportedTypes lval rval - - (NVSet ls lp, NVConstant NNull) -> case op of - NUpdate -> pure $ bin nvSetP ls lp - NEq -> toBool =<< valueEq lval (nvSet M.empty M.empty) - NNEq -> toBool . not =<< valueEq lval (nvSet M.empty M.empty) - _ -> nverr $ ErrorCall $ unsupportedTypes lval rval - - (NVConstant NNull, NVSet rs rp) -> case op of - NUpdate -> pure $ bin nvSetP rs rp - NEq -> toBool =<< valueEq (nvSet M.empty M.empty) rval - NNEq -> toBool . not =<< valueEq (nvSet M.empty M.empty) rval - _ -> nverr $ ErrorCall $ unsupportedTypes lval rval - - (ls@NVSet {}, NVStr rs rc) -> case op of - NPlus -> (\ls -> bin nvStrP (Text.pack ls `mappend` rs) rc) - <$> coerceToString False ls - NEq -> toBool =<< valueEq lval rval - NNEq -> toBool . not =<< valueEq lval rval - _ -> nverr $ ErrorCall $ unsupportedTypes lval rval - - (NVStr ls lc, rs@NVSet {}) -> case op of - NPlus -> (\rs -> bin nvStrP (ls `mappend` Text.pack rs) lc) - <$> coerceToString False rs - NEq -> toBool =<< valueEq lval rval - NNEq -> toBool . not =<< valueEq lval rval - _ -> nverr $ ErrorCall $ unsupportedTypes lval rval - - (NVList ls, NVList rs) -> case op of - NConcat -> pure $ bin nvListP $ ls ++ rs - NEq -> toBool =<< valueEq lval rval - NNEq -> toBool . not =<< valueEq lval rval - _ -> nverr $ ErrorCall $ unsupportedTypes lval rval - - (NVList ls, NVConstant NNull) -> case op of - NConcat -> pure $ bin nvListP ls - NEq -> toBool =<< valueEq lval (nvList []) - NNEq -> toBool . not =<< valueEq lval (nvList []) - _ -> nverr $ ErrorCall $ unsupportedTypes lval rval - - (NVConstant NNull, NVList rs) -> case op of - NConcat -> pure $ bin nvListP rs - NEq -> toBool =<< valueEq (nvList []) rval - NNEq -> toBool . not =<< valueEq (nvList []) rval - _ -> nverr $ ErrorCall $ unsupportedTypes lval rval - - (NVPath p, NVStr s _) -> case op of - NEq -> toBool $ p == Text.unpack s - NNEq -> toBool $ p /= Text.unpack s - NPlus -> bin nvPathP <$> makeAbsolutePath (p `mappend` Text.unpack s) - _ -> nverr $ ErrorCall $ unsupportedTypes lval rval - - (NVPath ls, NVPath rs) -> case op of - NPlus -> bin nvPathP <$> makeAbsolutePath (ls ++ rs) - _ -> nverr $ ErrorCall $ unsupportedTypes lval rval - - _ -> case op of - NEq -> toBool False - NNEq -> toBool True - _ -> nverr $ ErrorCall $ unsupportedTypes lval rval - where - unsupportedTypes :: Show a => a -> a -> String - unsupportedTypes lval rval = - "Unsupported argument types for binary operator " - ++ show op ++ ": " ++ show lval ++ ", " ++ show rval - - numBinOp :: (forall r. (Provenance m -> r) -> r) - -> (forall a. Num a => a -> a -> a) -> NAtom -> NAtom -> m (NValue m) - numBinOp bin f = numBinOp' bin f f - - numBinOp' :: (forall r. (Provenance m -> r) -> r) - -> (Integer -> Integer -> Integer) - -> (Float -> Float -> Float) - -> NAtom -> NAtom -> m (NValue m) - numBinOp' bin intF floatF l r = case (l, r) of - (NInt li, NInt ri) -> toInt $ li `intF` ri - (NInt li, NFloat rf) -> toFloat $ fromInteger li `floatF` rf - (NFloat lf, NInt ri) -> toFloat $ lf `floatF` fromInteger ri - (NFloat lf, NFloat rf) -> toFloat $ lf `floatF` rf - _ -> nverr $ ErrorCall $ unsupportedTypes l r - where - toInt = pure . bin nvConstantP . NInt - toFloat = pure . bin nvConstantP . NFloat - -coerceToString :: MonadNix e m => Bool -> NValue m -> m String -coerceToString copyToStore = go - where - go = \case - NVConstant (NBool b) - | b -> pure "1" - | otherwise -> pure "" - NVConstant (NInt n) -> pure $ show n - NVConstant (NFloat n) -> pure $ show n - NVConstant NNull -> pure "" - - NVStr t _ -> pure $ Text.unpack t - NVPath p | copyToStore -> unStorePath <$> addPath p - | otherwise -> pure p - NVList l -> unwords <$> traverse (`force` go) l - - v@(NVSet s _) | Just p <- M.lookup "__toString" s -> - force p $ (`callFunc` pure v) >=> go - - NVSet s _ | Just p <- M.lookup "outPath" s -> - force p go - - v -> throwError $ ErrorCall $ "Expected a string, but saw: " ++ show v - -newtype Lazy m a = Lazy - { runLazy :: ReaderT (Context (Lazy m) (NThunk (Lazy m))) - (StateT (HashMap FilePath NExprLoc) m) a } - deriving (Functor, Applicative, Alternative, Monad, MonadPlus, - MonadFix, MonadIO, - MonadReader (Context (Lazy m) (NThunk (Lazy m)))) - -instance MonadIO m => MonadVar (Lazy m) where - type Var (Lazy m) = IORef - - newVar = liftIO . newIORef - readVar = liftIO . readIORef - writeVar = (liftIO .) . writeIORef - atomicModifyVar = (liftIO .) . atomicModifyIORef - -instance (MonadIO m, Monad m) => MonadFile m where - readFile = liftIO . BS.readFile - -instance MonadCatch m => MonadCatch (Lazy m) where - catch (Lazy (ReaderT m)) f = Lazy $ ReaderT $ \e -> - catch (m e) ((`runReaderT` e) . runLazy . f) - -instance MonadThrow m => MonadThrow (Lazy m) where - throwM = Lazy . throwM - -#ifdef MIN_VERSION_haskeline -instance MonadException m => MonadException (Lazy m) where - controlIO f = Lazy $ controlIO $ \(RunIO run) -> - let run' = RunIO (fmap Lazy . run . runLazy) - in runLazy <$> f run' -#endif - -instance (MonadFix m, MonadCatch m, MonadIO m, Alternative m, - MonadPlus m, Typeable m) - => MonadEffects (Lazy m) where - addPath path = do - (exitCode, out, _) <- - liftIO $ readProcessWithExitCode "nix-store" ["--add", path] "" - case exitCode of - ExitSuccess -> do - let dropTrailingLinefeed p = take (length p - 1) p - return $ StorePath $ dropTrailingLinefeed out - _ -> throwError $ ErrorCall $ - "addPath: failed: nix-store --add " ++ show path - - toFile_ filepath content = do - liftIO $ writeFile filepath content - storepath <- addPath filepath - liftIO $ removeFile filepath - return storepath - - makeAbsolutePath origPath = do - origPathExpanded <- liftIO $ expandHomePath origPath - absPath <- if isAbsolute origPathExpanded then pure origPathExpanded else do - cwd <- do - mres <- lookupVar @_ @(NThunk (Lazy m)) "__cur_file" - case mres of - Nothing -> liftIO getCurrentDirectory - Just v -> force v $ \case - NVPath s -> return $ takeDirectory s - v -> throwError $ ErrorCall $ "when resolving relative path," - ++ " __cur_file is in scope," - ++ " but is not a path; it is: " - ++ show v - pure $ cwd origPathExpanded - liftIO $ removeDotDotIndirections <$> canonicalizePath absPath - - findEnvPath = findEnvPathM - - findPath = findPathM - - pathExists = liftIO . fileExist - - importPath scope origPath = do - path <- liftIO $ pathToDefaultNixFile origPath - mres <- lookupVar @(Context (Lazy m) (NThunk (Lazy m))) - "__cur_file" - path' <- case mres of - Nothing -> do - traceM "No known current directory" - return path - Just p -> fromValue @_ @_ @(NThunk (Lazy m)) p >>= \(Path p') -> do - traceM $ "Current file being evaluated is: " ++ show p' - return $ takeDirectory p' path - - traceM $ "Importing file " ++ path' - withFrame Info (ErrorCall $ "While importing file " ++ show path') $ do - imports <- Lazy $ ReaderT $ const get - expr <- case M.lookup path' imports of - Just expr -> pure expr - Nothing -> do - eres <- Lazy $ parseNixFileLoc path' - case eres of - Failure err -> - throwError $ ErrorCall . show $ - text "Parse during import failed:" P. err - Success expr -> do - Lazy $ ReaderT $ const $ - modify (M.insert origPath expr) - pure expr - - let ref = value @_ @_ @(Lazy m) (nvPath path') - -- Use this cookie so that when we evaluate the next - -- import, we'll remember which directory its containing - -- file was in. - pushScope (M.singleton "__cur_file" ref) $ - pushScope scope $ evalExprLoc expr - - getEnvVar = liftIO . lookupEnv - - getCurrentSystemOS = return $ Text.pack System.Info.os - - -- Invert the conversion done by GHC_CONVERT_CPU in GHC's aclocal.m4 - getCurrentSystemArch = return $ Text.pack $ case System.Info.arch of - "i386" -> "i686" - arch -> arch - - listDirectory = liftIO . System.Directory.listDirectory - getSymbolicLinkStatus = liftIO . System.Posix.Files.getSymbolicLinkStatus - - derivationStrict = fromValue @(ValueSet (Lazy m)) >=> \s -> do - nn <- maybe (pure False) fromNix (M.lookup "__ignoreNulls" s) - s' <- M.fromList <$> mapMaybeM (handleEntry nn) (M.toList s) - v' <- normalForm =<< toValue @(ValueSet (Lazy m)) s' - nixInstantiateExpr $ "derivationStrict " ++ show (prettyNValueNF v') - where - mapMaybeM :: (a -> Lazy m (Maybe b)) -> [a] -> Lazy m [b] - mapMaybeM op = foldr f (return []) - where f x xs = op x >>= \case - Nothing -> xs - Just x -> (x:) <$> xs - - handleEntry ignoreNulls (k, v) = fmap (k,) <$> case k of - -- The `args' attribute is special: it supplies the command-line - -- arguments to the builder. - "args" -> Just <$> convertNix @[Text] v - "__ignoreNulls" -> pure Nothing - _ -> force v $ \case - NVConstant NNull | ignoreNulls -> pure Nothing - v' -> Just <$> (toNix =<< Text.pack <$> coerceToString True v') - - nixInstantiateExpr expr = do - traceM $ "Executing: " - ++ show ["nix-instantiate", "--eval", "--expr ", expr] - (exitCode, out, err) <- - liftIO $ readProcessWithExitCode "nix-instantiate" - [ "--eval", "--expr", expr] "" - case exitCode of - ExitSuccess -> case parseNixTextLoc (Text.pack out) of - Failure err -> - throwError $ ErrorCall $ - "Error parsing output of nix-instantiate: " ++ show err - Success v -> evalExprLoc v - status -> - throwError $ ErrorCall $ "nix-instantiate failed: " ++ show status - ++ ": " ++ err - - getRecursiveSize = -#ifdef MIN_VERSION_ghc_datasize -#if MIN_VERSION_ghc_datasize(0,2,0) && __GLASGOW_HASKELL__ >= 804 - toNix @Integer <=< fmap fromIntegral . liftIO . recursiveSize -#else - const $ toNix (0 :: Integer) -#endif -#else - const $ toNix (0 :: Integer) -#endif - - getURL url = do - let urlstr = Text.unpack url - traceM $ "fetching HTTP URL: " ++ urlstr - response <- liftIO $ do - req <- parseRequest urlstr - manager <- - if secure req - then newTlsManager - else newManager defaultManagerSettings - -- print req - httpLbs (req { method = "GET" }) manager - -- return response - let status = statusCode (responseStatus response) - if status /= 200 - then throwError $ ErrorCall $ - "fail, got " ++ show status ++ " when fetching url:" ++ urlstr - else -- do - -- let bstr = responseBody response - -- liftIO $ print bstr - throwError $ ErrorCall $ - "success in downloading but hnix-store is not yet ready; url = " ++ urlstr - - traceEffect = liftIO . putStrLn - - exec = \case - [] -> throwError $ ErrorCall "exec: missing program" - (prog:args) -> do - (exitCode, out, _) <- - liftIO $ readProcessWithExitCode prog args "" - let t = Text.strip (Text.pack out) - let emsg = "program[" ++ prog ++ "] args=" ++ show args - case exitCode of - ExitSuccess -> - if Text.null t - then throwError $ ErrorCall $ "exec has no output :" ++ emsg - else case parseNixTextLoc t of - Failure err -> - throwError $ ErrorCall $ - "Error parsing output of exec: " ++ show err ++ " " ++ emsg - Success v -> evalExprLoc v - err -> throwError $ ErrorCall $ - "exec failed: " ++ show err ++ " " ++ emsg - -runLazyM :: Options -> MonadIO m => Lazy m a -> m a -runLazyM opts = (`evalStateT` M.empty) - . (`runReaderT` newContext opts) - . runLazy - --- | 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 [] . splitOn "/" - where go s [] = reverse s - go (_:s) ("..":rest) = go s rest - go s (this:rest) = go (this:s) rest - -expandHomePath :: FilePath -> IO FilePath -expandHomePath ('~' : xs) = flip (++) xs <$> getHomeDirectory -expandHomePath p = return p - --- Given a path, determine the nix file to load -pathToDefaultNixFile :: FilePath -> IO FilePath -pathToDefaultNixFile p = do - isDir <- doesDirectoryExist p - pure $ if isDir then p "default.nix" else p - -infixr 9 -() :: FilePath -> FilePath -> FilePath -x y | isAbsolute y || "." `isPrefixOf` y = x y - | otherwise = joinByLargestOverlap x y - where - joinByLargestOverlap (splitDirectories -> xs) (splitDirectories -> ys) = - joinPath $ head [ xs ++ drop (length tx) ys - | tx <- tails xs, tx `elem` inits ys ] - -findPathBy :: forall e m. (MonadNix e m, MonadIO m) => - (FilePath -> m (Maybe FilePath)) -> - [NThunk m] -> FilePath -> m FilePath -findPathBy finder l name = do - mpath <- foldM go Nothing l - case mpath of - Nothing -> - throwError $ ErrorCall $ "file '" ++ name - ++ "' was not found in the Nix search path" - ++ " (add it using $NIX_PATH or -I)" - Just path -> return path - where - go :: Maybe FilePath -> NThunk m -> m (Maybe FilePath) - go p@(Just _) _ = pure p - go Nothing l = force l $ fromValue >=> - \(s :: HashMap Text (NThunk m)) -> - case M.lookup "path" s of - Just p -> force p $ fromValue >=> \(Path path) -> - case M.lookup "prefix" s of - Nothing -> tryPath path Nothing - Just pf -> force pf $ fromValueMay >=> \case - Just (pfx :: Text) | not (Text.null pfx) -> - tryPath path (Just (Text.unpack pfx)) - _ -> tryPath path Nothing - Nothing -> - throwError $ ErrorCall $ "__nixPath must be a list of attr sets" - ++ " with 'path' elements, but saw: " ++ show s - - tryPath p (Just n) | n':ns <- splitDirectories name, n == n' = - finder $ p joinPath ns - tryPath p _ = finder $ p name - -findPathM :: forall e m. (MonadNix e m, MonadIO m) => - [NThunk m] -> FilePath -> m FilePath -findPathM l name = findPathBy path l name - where - path :: (MonadEffects m, MonadIO m) => FilePath -> m (Maybe FilePath) - path path = do - path <- makeAbsolutePath path - exists <- liftIO $ doesPathExist path - return $ if exists then Just path else Nothing - -findEnvPathM :: forall e m. (MonadNix e m, MonadIO m) - => FilePath -> m FilePath -findEnvPathM name = do - mres <- lookupVar @_ @(NThunk m) "__nixPath" - case mres of - Nothing -> error "impossible" - Just x -> force x $ fromValue >=> \(l :: [NThunk m]) -> - findPathBy nixFilePath l name - where - nixFilePath :: (MonadEffects m, MonadIO m) => FilePath -> m (Maybe FilePath) - nixFilePath path = do - path <- makeAbsolutePath path - exists <- liftIO $ doesDirectoryExist path - path' <- if exists - then makeAbsolutePath $ path "default.nix" - else return path - exists <- liftIO $ doesFileExist path' - return $ if exists then Just path' else Nothing - -addTracing :: (MonadNix e m, Has e Options, MonadIO m, - MonadReader Int n, Alternative n) - => Alg NExprLocF (m a) -> Alg NExprLocF (n (m a)) -addTracing k v = do - depth <- ask - guard (depth < 2000) - local succ $ do - v'@(Compose (Ann span x)) <- sequence v - return $ do - opts :: Options <- asks (view hasLens) - let rendered = - if verbose opts >= Chatty -#ifdef MIN_VERSION_pretty_show - then text $ PS.ppShow (void x) -#else - then text $ show (void x) -#endif - else prettyNix (Fix (Fix (NSym "?") <$ x)) - msg x = text ("eval: " ++ replicate depth ' ') <> x - loc <- renderLocation span (msg rendered <> text " ...\n") - liftIO $ putStr $ show loc - res <- k v' - liftIO $ print $ msg rendered <> text " ...done" - return res - -evalExprLoc :: forall e m. (MonadNix e m, Has e Options, MonadIO m) - => NExprLoc -> m (NValue m) -evalExprLoc expr = do - opts :: Options <- asks (view hasLens) - if tracing opts - then join . (`runReaderT` (0 :: Int)) $ - adi (addTracing phi) - (raise (addStackFrames @(NThunk m) . addSourcePositions)) - expr - else adi phi (addStackFrames @(NThunk m) . addSourcePositions) expr - where - phi = Eval.eval @_ @(NValue m) @(NThunk m) @m . annotated . getCompose - raise k f x = ReaderT $ \e -> k (\t -> runReaderT (f t) e) x +import Prelude hiding ( putStr + , putStrLn + , print + ) + +import Control.Applicative +import Control.Monad +import Control.Monad.Catch hiding ( catchJust ) +import Control.Monad.Fix +import Control.Monad.Reader +import Control.Monad.Ref +import Control.Monad.State.Strict +import Control.Monad.Trans.Reader ( ReaderT(..) ) +import Control.Monad.Trans.State.Strict + ( StateT(..) ) +import Data.Fix +import Data.HashMap.Lazy ( HashMap ) +import qualified Data.HashMap.Lazy as M +import Data.List +import qualified Data.List.NonEmpty as NE +import Data.List.Split +import Data.Maybe ( maybeToList ) +import Data.Text ( Text ) +import qualified Data.Text as Text +import Data.Text.Prettyprint.Doc +import Data.Typeable +import Nix.Atoms +import Nix.Cited +import Nix.Context +import Nix.Convert +import Nix.Effects +import Nix.Eval as Eval +import Nix.Expr +import Nix.Frames +import Nix.Normal +import Nix.Options +import Nix.Parser +import Nix.Pretty +import Nix.Render +import Nix.Scope +import Nix.String +import Nix.Thunk +import Nix.Utils +import Nix.Value +import Nix.Value.Equal +#ifdef MIN_VERSION_haskeline +import System.Console.Haskeline.MonadException hiding(catch) +#endif +import System.FilePath +#ifdef MIN_VERSION_pretty_show +import qualified Text.Show.Pretty as PS +#endif + +#ifdef MIN_VERSION_ghc_datasize +#if MIN_VERSION_ghc_datasize(0,2,0) && __GLASGOW_HASKELL__ >= 804 +import GHC.DataSize +#endif +#endif + +type MonadCited t f m + = (HasCitations1 t m (NValue t f m) f, MonadDataContext f m) + +nvConstantP + :: MonadCited t f m => Provenance t m (NValue t f m) -> NAtom -> NValue t f m +nvConstantP p x = addProvenance p (nvConstant x) + +nvStrP + :: MonadCited t f m + => Provenance t m (NValue t f m) + -> NixString + -> NValue t f m +nvStrP p ns = addProvenance p (nvStr ns) + +nvPathP + :: MonadCited t f m + => Provenance t m (NValue t f m) + -> FilePath + -> NValue t f m +nvPathP p x = addProvenance p (nvPath x) + +nvListP + :: MonadCited t f m => Provenance t m (NValue t f m) -> [t] -> NValue t f m +nvListP p l = addProvenance p (nvList l) + +nvSetP + :: MonadCited t f m + => Provenance t m (NValue t f m) + -> AttrSet t + -> AttrSet SourcePos + -> NValue t f m +nvSetP p s x = addProvenance p (nvSet s x) + +nvClosureP + :: MonadCited t f m + => Provenance t m (NValue t f m) + -> Params () + -> (m (NValue t f m) -> m t) + -> NValue t f m +nvClosureP p x f = addProvenance p (nvClosure x f) + +nvBuiltinP + :: MonadCited t f m + => Provenance t m (NValue t f m) + -> String + -> (m (NValue t f m) -> m t) + -> NValue t f m +nvBuiltinP p name f = addProvenance p (nvBuiltin name f) + +type MonadCitedThunks t f m + = ( MonadThunk t m (NValue t f m) + , MonadDataErrorContext t f m + , HasCitations1 t m (NValue t f m) f + ) + +type MonadNix e t f m + = ( Has e SrcSpan + , Has e Options + , Scoped t m + , Framed e m + , MonadFix m + , MonadCatch m + , MonadThrow m + , Alternative m + , MonadEffects t f m + , MonadCitedThunks t f m + ) + +data ExecFrame t f m = Assertion SrcSpan (NValue t f m) + deriving (Show, Typeable) + +instance MonadDataErrorContext t f m => Exception (ExecFrame t f m) + +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) + +wrapExprLoc :: SrcSpan -> NExprLocF r -> NExprLoc +wrapExprLoc span x = Fix (Fix (NSym_ span "") <$ x) + +instance MonadNix e t f m => MonadEval (NValue t f m) m where + freeVariable var = + nverr @e @t @f + $ ErrorCall + $ "Undefined variable '" + ++ Text.unpack var + ++ "'" + + synHole name = do + span <- currentPos + scope <- currentScopes + evalError @(NValue t f m) $ SynHole $ SynHoleInfo + { _synHoleInfo_expr = Fix $ NSynHole_ span name + , _synHoleInfo_scope = scope + } + + attrMissing ks Nothing = + evalError @(NValue t f m) + $ ErrorCall + $ "Inheriting unknown attribute: " + ++ intercalate "." (map Text.unpack (NE.toList ks)) + + attrMissing ks (Just s) = do + s' <- prettyNValue s + evalError @(NValue t f m) + $ ErrorCall + $ "Could not look up attribute " + ++ intercalate "." (map Text.unpack (NE.toList ks)) + ++ " in " + ++ show s' + + evalCurPos = do + scope <- currentScopes + span@(SrcSpan delta _) <- currentPos + addProvenance @_ @_ @(NValue t f m) + (Provenance scope (NSym_ span "__curPos")) + <$> toValue delta + + evaledSym name val = do + scope <- currentScopes + span <- currentPos + pure $ addProvenance @_ @_ @(NValue t f m) + (Provenance scope (NSym_ span name)) + val + + evalConstant c = do + scope <- currentScopes + span <- currentPos + pure $ nvConstantP (Provenance scope (NConstant_ span c)) c + + evalString = assembleString >=> \case + Just ns -> do + scope <- currentScopes + span <- currentPos + pure $ nvStrP + (Provenance + scope + (NStr_ span (DoubleQuoted [Plain (hackyStringIgnoreContext ns)])) + ) + ns + Nothing -> nverr $ ErrorCall "Failed to assemble string" + + evalLiteralPath p = do + scope <- currentScopes + span <- currentPos + nvPathP (Provenance scope (NLiteralPath_ span p)) + <$> makeAbsolutePath @t @f @m p + + evalEnvPath p = do + scope <- currentScopes + span <- currentPos + nvPathP (Provenance scope (NEnvPath_ span p)) <$> findEnvPath @t @f @m p + + evalUnary op arg = do + scope <- currentScopes + span <- currentPos + execUnaryOp scope span op arg + + evalBinary op larg rarg = do + scope <- currentScopes + span <- currentPos + execBinaryOp scope span op larg rarg + + evalWith c b = do + scope <- currentScopes + span <- currentPos + (\b -> addProvenance (Provenance scope (NWith_ span Nothing (Just b))) b) + <$> evalWithAttrSet c b + + evalIf c t f = do + scope <- currentScopes + span <- currentPos + fromValue c >>= \b -> if b + then + (\t -> addProvenance + (Provenance scope (NIf_ span (Just c) (Just t) Nothing)) + t + ) + <$> t + else + (\f -> addProvenance + (Provenance scope (NIf_ span (Just c) Nothing (Just f))) + f + ) + <$> f + + evalAssert c body = fromValue c >>= \b -> do + span <- currentPos + if b + then do + scope <- currentScopes + (\b -> + addProvenance (Provenance scope (NAssert_ span (Just c) (Just b))) b + ) + <$> body + else nverr $ Assertion span c + + evalApp f x = do + scope <- currentScopes + span <- currentPos + addProvenance (Provenance scope (NBinary_ span NApp (Just f) Nothing)) + <$> callFunc f x + + evalAbs p k = do + scope <- currentScopes + span <- currentPos + pure $ nvClosureP + (Provenance scope (NAbs_ span (Nothing <$ p) Nothing)) + (void p) + (\arg -> wrapValue . snd <$> k arg (\_ b -> ((), ) <$> b)) + + evalError = throwError + +infixl 1 `callFunc` +callFunc + :: forall e t f m + . MonadNix e t f m + => NValue t f m + -> m (NValue t f m) + -> m (NValue t f m) +callFunc fun arg = do + frames :: Frames <- asks (view hasLens) + when (length frames > 2000) $ throwError $ ErrorCall + "Function call stack exhausted" + case fun of + NVClosure params f -> do + traceM $ "callFunc:NVFunction taking " ++ show params + force ?? pure =<< f arg + NVBuiltin name f -> do + span <- currentPos + force ?? pure =<< withFrame Info (Calling @m @t name span) (f arg) + s@(NVSet m _) | Just f <- M.lookup "__functor" m -> do + traceM "callFunc:__functor" + force f $ (`callFunc` pure s) >=> (`callFunc` arg) + x -> throwError $ ErrorCall $ "Attempt to call non-function: " ++ show x + +execUnaryOp + :: (Framed e m, MonadCited t f m, Show t) + => Scopes m t + -> SrcSpan + -> NUnaryOp + -> NValue t f m + -> m (NValue t f m) +execUnaryOp scope span op arg = do + traceM "NUnary" + 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) + _ -> + throwError + $ ErrorCall + $ "unsupported argument type for unary operator " + ++ show op + x -> + throwError + $ ErrorCall + $ "argument to unary operator" + ++ " must evaluate to an atomic type: " + ++ show x + where + unaryOp = pure . nvConstantP (Provenance scope (NUnary_ span op (Just arg))) + +execBinaryOp + :: forall e t f m + . (MonadNix e t f m, MonadEval (NValue t f m) m) + => Scopes m t + -> SrcSpan + -> NBinaryOp + -> NValue t f m + -> m (NValue t f m) + -> m (NValue t f m) + +execBinaryOp scope span NOr larg rarg = fromNix larg >>= \l -> if l + then orOp Nothing True + else rarg >>= \rval -> fromNix @Bool rval >>= orOp (Just rval) + where + orOp r b = pure $ nvConstantP + (Provenance scope (NBinary_ span NOr (Just larg) r)) + (NBool b) + +execBinaryOp scope span NAnd larg rarg = fromNix larg >>= \l -> if l + then rarg >>= \rval -> fromNix @Bool rval >>= andOp (Just rval) + else andOp Nothing False + where + andOp r b = pure $ nvConstantP + (Provenance scope (NBinary_ span NAnd (Just larg) r)) + (NBool b) + +execBinaryOp scope span op lval rarg = do + rval <- rarg + let bin :: (Provenance t m (NValue t f m) -> a) -> a + bin f = f (Provenance scope (NBinary_ span op (Just lval) (Just rval))) + toBool = pure . bin nvConstantP . NBool + case (lval, rval) of + (NVConstant lc, NVConstant rc) -> case (op, lc, rc) of + (NEq , _, _) -> toBool =<< valueEqM lval rval + (NNEq, _, _) -> toBool . not =<< valueEqM lval rval + (NLt , l, r) -> toBool $ l < r + (NLte, l, r) -> toBool $ l <= r + (NGt , l, r) -> toBool $ l > r + (NGte, l, r) -> toBool $ l >= r + (NAnd, _, _) -> + nverr $ ErrorCall "should be impossible: && is handled above" + (NOr, _, _) -> + nverr $ ErrorCall "should be impossible: || is handled above" + (NPlus , l , r ) -> numBinOp bin (+) l r + (NMinus, l , r ) -> numBinOp bin (-) l r + (NMult , l , r ) -> numBinOp bin (*) l r + (NDiv , l , r ) -> numBinOp' bin div (/) l r + (NImpl , NBool l, NBool r) -> toBool $ not l || r + _ -> nverr $ ErrorCall $ unsupportedTypes lval rval + + (NVStr ls, NVStr rs) -> case op of + NPlus -> pure $ bin nvStrP (ls `principledStringMappend` rs) + NEq -> toBool =<< valueEqM lval rval + NNEq -> toBool . not =<< valueEqM lval rval + NLt -> toBool $ ls < rs + NLte -> toBool $ ls <= rs + NGt -> toBool $ ls > rs + NGte -> toBool $ ls >= rs + _ -> nverr $ ErrorCall $ unsupportedTypes lval rval + + (NVStr _, NVConstant NNull) -> case op of + NEq -> toBool False + NNEq -> toBool True + _ -> nverr $ ErrorCall $ unsupportedTypes lval rval + + (NVConstant NNull, NVStr _) -> case op of + NEq -> toBool False + NNEq -> toBool True + _ -> nverr $ ErrorCall $ unsupportedTypes lval rval + + (NVSet ls lp, NVSet rs rp) -> case op of + NUpdate -> pure $ bin nvSetP (rs `M.union` ls) (rp `M.union` lp) + NEq -> toBool =<< valueEqM lval rval + NNEq -> toBool . not =<< valueEqM lval rval + _ -> nverr $ ErrorCall $ unsupportedTypes lval rval + + (NVSet ls lp, NVConstant NNull) -> case op of + NUpdate -> pure $ bin nvSetP ls lp + NEq -> toBool =<< valueEqM lval (nvSet M.empty M.empty) + NNEq -> toBool . not =<< valueEqM lval (nvSet M.empty M.empty) + _ -> nverr $ ErrorCall $ unsupportedTypes lval rval + + (NVConstant NNull, NVSet rs rp) -> case op of + NUpdate -> pure $ bin nvSetP rs rp + NEq -> toBool =<< valueEqM (nvSet M.empty M.empty) rval + NNEq -> toBool . not =<< valueEqM (nvSet M.empty M.empty) rval + _ -> nverr $ ErrorCall $ unsupportedTypes lval rval + + (ls@NVSet{}, NVStr rs) -> case op of + NPlus -> + (\ls2 -> bin nvStrP (ls2 `principledStringMappend` rs)) + <$> coerceToString DontCopyToStore CoerceStringy ls + NEq -> toBool =<< valueEqM lval rval + NNEq -> toBool . not =<< valueEqM lval rval + _ -> nverr $ ErrorCall $ unsupportedTypes lval rval + + (NVStr ls, rs@NVSet{}) -> case op of + NPlus -> + (\rs2 -> bin nvStrP (ls `principledStringMappend` rs2)) + <$> coerceToString DontCopyToStore CoerceStringy rs + NEq -> toBool =<< valueEqM lval rval + NNEq -> toBool . not =<< valueEqM lval rval + _ -> nverr $ ErrorCall $ unsupportedTypes lval rval + + (NVList ls, NVList rs) -> case op of + NConcat -> pure $ bin nvListP $ ls ++ rs + NEq -> toBool =<< valueEqM lval rval + NNEq -> toBool . not =<< valueEqM lval rval + _ -> nverr $ ErrorCall $ unsupportedTypes lval rval + + (NVList ls, NVConstant NNull) -> case op of + NConcat -> pure $ bin nvListP ls + NEq -> toBool =<< valueEqM lval (nvList []) + NNEq -> toBool . not =<< valueEqM lval (nvList []) + _ -> nverr $ ErrorCall $ unsupportedTypes lval rval + + (NVConstant NNull, NVList rs) -> case op of + NConcat -> pure $ bin nvListP rs + NEq -> toBool =<< valueEqM (nvList []) rval + NNEq -> toBool . not =<< valueEqM (nvList []) rval + _ -> nverr $ ErrorCall $ unsupportedTypes lval rval + + (NVPath p, NVStr ns) -> case op of + NEq -> toBool False -- From eqValues in nix/src/libexpr/eval.cc + NNEq -> toBool True + NPlus -> bin nvPathP <$> makeAbsolutePath @t @f + (p `mappend` Text.unpack (hackyStringIgnoreContext ns)) + _ -> nverr $ ErrorCall $ unsupportedTypes lval rval + + (NVPath ls, NVPath rs) -> case op of + NPlus -> bin nvPathP <$> makeAbsolutePath @t @f (ls ++ rs) + _ -> nverr $ ErrorCall $ unsupportedTypes lval rval + + _ -> case op of + NEq -> toBool False + NNEq -> toBool True + _ -> nverr $ ErrorCall $ unsupportedTypes lval rval + where + unsupportedTypes :: Show a => a -> a -> String + unsupportedTypes lval rval = + "Unsupported argument types for binary operator " + ++ show op + ++ ": " + ++ show lval + ++ ", " + ++ show rval + + numBinOp + :: (forall r . (Provenance t m (NValue t f m) -> r) -> r) + -> (forall a . Num a => a -> a -> a) + -> NAtom + -> NAtom + -> m (NValue t f m) + numBinOp bin f = numBinOp' bin f f + + numBinOp' + :: (forall r . (Provenance t m (NValue t f m) -> r) -> r) + -> (Integer -> Integer -> Integer) + -> (Float -> Float -> Float) + -> NAtom + -> NAtom + -> m (NValue t f m) + numBinOp' bin intF floatF l r = case (l, r) of + (NInt li, NInt ri ) -> toInt $ li `intF` ri + (NInt li, NFloat rf) -> toFloat $ fromInteger li `floatF` rf + (NFloat lf, NInt ri ) -> toFloat $ lf `floatF` fromInteger ri + (NFloat lf, NFloat rf) -> toFloat $ lf `floatF` rf + _ -> nverr $ ErrorCall $ unsupportedTypes l r + where + toInt = pure . bin nvConstantP . NInt + toFloat = pure . bin nvConstantP . NFloat + +-- | 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 + | CoerceAny + -- ^ Coerce everything but functions + deriving (Eq,Ord,Enum,Bounded) + +-- | Data type to avoid boolean blindness on what used to be called copyToStore +data CopyToStoreMode + = CopyToStore + -- ^ Add paths to the store as they are encountered + | DontCopyToStore + -- ^ Add paths to the store as they are encountered + deriving (Eq,Ord,Enum,Bounded) + +coerceToString + :: MonadNix e t f m + => CopyToStoreMode + -> CoercionLevel + -> NValue t f m + -> m NixString +coerceToString ctsm clevel = go + where + go = \case + NVConstant (NBool b) + | + -- TODO Return a singleton for "" and "1" + b && clevel == CoerceAny -> pure + $ principledMakeNixStringWithoutContext "1" + | clevel == CoerceAny -> pure $ principledMakeNixStringWithoutContext "" + NVConstant (NInt n) | clevel == CoerceAny -> + pure $ principledMakeNixStringWithoutContext $ Text.pack $ show n + NVConstant (NFloat n) | clevel == CoerceAny -> + pure $ principledMakeNixStringWithoutContext $ Text.pack $ show n + NVConstant NNull | clevel == CoerceAny -> + pure $ principledMakeNixStringWithoutContext "" + NVStr ns -> pure ns + NVPath p + | ctsm == CopyToStore -> storePathToNixString <$> addPath p + | otherwise -> pure $ principledMakeNixStringWithoutContext $ Text.pack p + NVList l | clevel == CoerceAny -> + nixStringUnwords <$> traverse (`force` go) l + + v@(NVSet s _) | Just p <- M.lookup "__toString" s -> + force p $ (`callFunc` pure v) >=> go + + NVSet s _ | Just p <- M.lookup "outPath" s -> force p go + + v -> throwError $ ErrorCall $ "Expected a string, but saw: " ++ show v + + nixStringUnwords = + principledIntercalateNixString (principledMakeNixStringWithoutContext " ") + storePathToNixString :: StorePath -> NixString + storePathToNixString sp = principledMakeNixStringWithSingletonContext + t + (StringContext t DirectPath) + where t = Text.pack $ unStorePath sp + +fromStringNoContext :: MonadNix e t f m => NixString -> m Text +fromStringNoContext ns = case principledGetStringNoContext ns of + Just str -> return str + Nothing -> throwError $ ErrorCall "expected string with no context" + +newtype Lazy t (f :: * -> *) m a = Lazy + { runLazy :: ReaderT (Context (Lazy t f m) t) + (StateT (HashMap FilePath NExprLoc) m) a } + deriving + ( Functor + , Applicative + , Alternative + , Monad + , MonadPlus + , MonadFix + , MonadIO + , MonadCatch + , MonadThrow + , MonadReader (Context (Lazy t f m) t) + ) + +instance MonadTrans (Lazy t f) where + lift = Lazy . lift . lift + +instance MonadRef m => MonadRef (Lazy t f m) where + type Ref (Lazy t f m) = Ref m + newRef = lift . newRef + readRef = lift . readRef + writeRef r = lift . writeRef r + +instance MonadAtomicRef m => MonadAtomicRef (Lazy t f m) where + atomicModifyRef r = lift . atomicModifyRef r + +instance (MonadFile m, Monad m) => MonadFile (Lazy t f m) + +#ifdef MIN_VERSION_haskeline +instance MonadException m => MonadException (Lazy t f m) where + controlIO f = Lazy $ controlIO $ \(RunIO run) -> + let run' = RunIO (fmap Lazy . run . runLazy) + in runLazy <$> f run' +#endif + +instance MonadStore m => MonadStore (Lazy t f m) where + addPath' = lift . addPath' + toFile_' n = lift . toFile_' n + +instance MonadPutStr m => MonadPutStr (Lazy t f m) +instance MonadHttp m => MonadHttp (Lazy t f m) +instance MonadEnv m => MonadEnv (Lazy t f m) +instance MonadInstantiate m => MonadInstantiate (Lazy t f m) +instance MonadExec m => MonadExec (Lazy t f m) +instance MonadIntrospect m => MonadIntrospect (Lazy t f m) + +instance MonadThunkId m => MonadThunkId (Lazy t f m) where + type ThunkId (Lazy t f m) = ThunkId m + +instance ( MonadFix m + , MonadCatch m + , MonadFile m + , MonadStore m + , MonadPutStr m + , MonadHttp m + , MonadEnv m + , MonadInstantiate m + , MonadExec m + , MonadIntrospect m + , Alternative m + , MonadPlus m + , MonadCitedThunks t f (Lazy t f m) + ) + => MonadEffects t f (Lazy t f m) where + makeAbsolutePath origPath = do + origPathExpanded <- expandHomePath origPath + absPath <- if isAbsolute origPathExpanded + then pure origPathExpanded + else do + cwd <- do + mres <- lookupVar "__cur_file" + case mres of + Nothing -> getCurrentDirectory + Just v -> force v $ \case + NVPath s -> return $ takeDirectory s + v -> + throwError + $ ErrorCall + $ "when resolving relative path," + ++ " __cur_file is in scope," + ++ " but is not a path; it is: " + ++ show v + pure $ cwd origPathExpanded + removeDotDotIndirections <$> canonicalizePath absPath + +-- Given a path, determine the nix file to load + pathToDefaultNix = pathToDefaultNixFile + + findEnvPath = findEnvPathM + findPath = findPathM + + importPath path = do + traceM $ "Importing file " ++ path + withFrame Info (ErrorCall $ "While importing file " ++ show path) $ do + imports <- Lazy $ ReaderT $ const get + evalExprLoc =<< case M.lookup path imports of + Just expr -> pure expr + Nothing -> do + eres <- parseNixFileLoc path + case eres of + Failure err -> + throwError + $ ErrorCall + . show + $ fillSep + $ ["Parse during import failed:", err] + Success expr -> do + Lazy $ ReaderT $ const $ modify (M.insert path expr) + pure expr + + derivationStrict = fromValue @(AttrSet t) >=> \s -> do + nn <- maybe (pure False) (force ?? fromNix) (M.lookup "__ignoreNulls" s) + s' <- M.fromList <$> mapMaybeM (handleEntry nn) (M.toList s) + v' <- normalForm =<< toValue @(AttrSet t) @_ @(NValue t f (Lazy t f m)) s' + nixInstantiateExpr $ "derivationStrict " ++ show (prettyNValueNF v') + where + mapMaybeM :: (a -> Lazy t f m (Maybe b)) -> [a] -> Lazy t f m [b] + mapMaybeM op = foldr f (return []) + where f x xs = op x >>= (<$> xs) . (++) . maybeToList + + handleEntry :: Bool -> (Text, t) -> Lazy t f m (Maybe (Text, t)) + handleEntry ignoreNulls (k, v) = fmap (k, ) <$> case k of + -- The `args' attribute is special: it supplies the command-line + -- arguments to the builder. + -- TODO This use of coerceToString is probably not right and may + -- not have the right arguments. + "args" -> force v $ fmap Just . coerceNixList + "__ignoreNulls" -> pure Nothing + _ -> force v $ \case + NVConstant NNull | ignoreNulls -> pure Nothing + v' -> Just <$> coerceNix v' + where + coerceNix :: NValue t f (Lazy t f m) -> Lazy t f m t + coerceNix = + fmap wrapValue . toNix <=< coerceToString CopyToStore CoerceAny + + coerceNixList :: NValue t f (Lazy t f m) -> Lazy t f m t + coerceNixList v = do + xs :: [t] <- fromValue @[t] v + ys :: [t] <- traverse (\x -> force x coerceNix) xs + v' :: NValue t f (Lazy t f m) <- toValue @[t] ys + return $ wrapValue v' + + traceEffect = putStrLn + +getRecursiveSize :: (MonadIntrospect m, Applicative f) => a -> m (NValue t f m) +getRecursiveSize = fmap (nvConstant . NInt . fromIntegral) . recursiveSize + +runLazyM :: Options -> MonadIO m => Lazy t f m a -> m a +runLazyM opts = + (`evalStateT` M.empty) . (`runReaderT` newContext opts) . runLazy + +-- | 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 [] . splitOn "/" + where + go s [] = reverse s + go (_ : s) (".." : rest) = go s rest + go s (this : rest) = go (this : s) rest + +expandHomePath :: MonadFile m => FilePath -> m FilePath +expandHomePath ('~' : xs) = flip (++) xs <$> getHomeDirectory +expandHomePath p = return p + +-- Given a path, determine the nix file to load +pathToDefaultNixFile :: MonadFile m => FilePath -> m FilePath +pathToDefaultNixFile p = do + isDir <- doesDirectoryExist p + pure $ if isDir then p "default.nix" else p + +infixr 9 +() :: FilePath -> FilePath -> FilePath +x y | isAbsolute y || "." `isPrefixOf` y = x y + | otherwise = joinByLargestOverlap x y + where + joinByLargestOverlap (splitDirectories -> xs) (splitDirectories -> ys) = + joinPath $ head + [ xs ++ drop (length tx) ys | tx <- tails xs, tx `elem` inits ys ] + +findPathBy + :: forall e t f m + . MonadNix e t f m + => (FilePath -> m (Maybe FilePath)) + -> [t] + -> FilePath + -> m FilePath +findPathBy finder l name = do + mpath <- foldM go Nothing l + case mpath of + Nothing -> + throwError + $ ErrorCall + $ "file '" + ++ name + ++ "' was not found in the Nix search path" + ++ " (add it using $NIX_PATH or -I)" + Just path -> return path + where + go :: Maybe FilePath -> t -> m (Maybe FilePath) + go p@(Just _) _ = pure p + go Nothing l = force l $ fromValue >=> \(s :: HashMap Text t) -> do + p <- resolvePath s + force p $ fromValue >=> \(Path path) -> case M.lookup "prefix" s of + Nothing -> tryPath path Nothing + Just pf -> force pf $ fromValueMay >=> \case + Just (nsPfx :: NixString) -> + let pfx = hackyStringIgnoreContext nsPfx + in if not (Text.null pfx) + then tryPath path (Just (Text.unpack pfx)) + else tryPath path Nothing + _ -> tryPath path Nothing + + tryPath p (Just n) | n' : ns <- splitDirectories name, n == n' = + finder $ p joinPath ns + tryPath p _ = finder $ p name + + resolvePath s = case M.lookup "path" s of + Just t -> return t + Nothing -> case M.lookup "uri" s of + Just ut -> thunk $ fetchTarball (force ut pure) + Nothing -> + throwError + $ ErrorCall + $ "__nixPath must be a list of attr sets" + ++ " with 'path' elements, but saw: " + ++ show s + +findPathM :: forall e t f m . MonadNix e t f m => [t] -> FilePath -> m FilePath +findPathM l name = findPathBy path l name + where + path :: MonadEffects t f m => FilePath -> m (Maybe FilePath) + path path = do + path <- makeAbsolutePath @t @f path + exists <- doesPathExist path + return $ if exists then Just path else Nothing + +findEnvPathM :: forall e t f m . MonadNix e t f m => FilePath -> m FilePath +findEnvPathM name = do + mres <- lookupVar "__nixPath" + case mres of + Nothing -> error "impossible" + Just x -> + force x $ fromValue >=> \(l :: [t]) -> findPathBy nixFilePath l name + where + nixFilePath :: MonadEffects t f m => FilePath -> m (Maybe FilePath) + nixFilePath path = do + path <- makeAbsolutePath @t @f path + exists <- doesDirectoryExist path + path' <- if exists + then makeAbsolutePath @t @f $ path "default.nix" + else return path + exists <- doesFileExist path' + return $ if exists then Just path' else Nothing + +addTracing + :: (MonadNix e t f m, Has e Options, MonadReader Int n, Alternative n) + => Alg NExprLocF (m a) + -> Alg NExprLocF (n (m a)) +addTracing k v = do + depth <- ask + guard (depth < 2000) + local succ $ do + v'@(Compose (Ann span x)) <- sequence v + return $ do + opts :: Options <- asks (view hasLens) + let rendered = if verbose opts >= Chatty +#ifdef MIN_VERSION_pretty_show + then pretty $ PS.ppShow (void x) +#else + then pretty $ show (void x) +#endif + else prettyNix (Fix (Fix (NSym "?") <$ x)) + msg x = pretty ("eval: " ++ replicate depth ' ') <> x + loc <- renderLocation span (msg rendered <> " ...\n") + putStr $ show loc + res <- k v' + print $ msg rendered <> " ...done" + return res + +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) + if tracing opts + then join . (`runReaderT` (0 :: Int)) $ adi + (addTracing phi) + (raise (addStackFrames @t . addSourcePositions)) + expr + else adi phi (addStackFrames @t . addSourcePositions) expr + where + phi = Eval.eval . annotated . getCompose + raise k f x = ReaderT $ \e -> k (\t -> runReaderT (f t) e) x + +fetchTarball + :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m) +fetchTarball v = v >>= \case + NVSet s _ -> case M.lookup "url" s of + Nothing -> + throwError $ ErrorCall "builtins.fetchTarball: Missing url attribute" + Just url -> force url $ go (M.lookup "sha256" s) + v@NVStr{} -> go Nothing v + v -> + throwError + $ ErrorCall + $ "builtins.fetchTarball: Expected URI or set, got " + ++ show v + where + go :: Maybe t -> NValue t f m -> m (NValue t f m) + go msha = \case + NVStr ns -> fetch (hackyStringIgnoreContext 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) + fetch uri msha = case takeExtension (Text.unpack uri) of + ".tgz" -> undefined + ".gz" -> undefined + ".bz2" -> undefined + ".xz" -> undefined + ".tar" -> undefined + ext -> throwError $ ErrorCall $ "builtins.fetchTarball: Unsupported extension '" + ++ ext ++ "'" +-} + + fetch :: Text -> Maybe t -> m (NValue t f m) + fetch uri Nothing = + nixInstantiateExpr $ "builtins.fetchTarball \"" ++ Text.unpack uri ++ "\"" + fetch url (Just t) = force t $ fromValue >=> \nsSha -> + let sha = hackyStringIgnoreContext nsSha + in nixInstantiateExpr + $ "builtins.fetchTarball { " + ++ "url = \"" + ++ Text.unpack url + ++ "\"; " + ++ "sha256 = \"" + ++ Text.unpack sha + ++ "\"; }" + +exec :: (MonadNix e t f m, MonadInstantiate m) => [String] -> m (NValue t f m) +exec args = either throwError evalExprLoc =<< exec' args + +nixInstantiateExpr + :: (MonadNix e t f m, MonadInstantiate m) => String -> m (NValue t f m) +nixInstantiateExpr s = either throwError evalExprLoc =<< instantiateExpr s + +instance Monad m => Scoped t (Lazy t f m) where + currentScopes = currentScopesReader + clearScopes = clearScopesReader @(Lazy t f m) @t + pushScopes = pushScopesReader + lookupVar = lookupVarReader + + + + + + + diff --git a/src/Nix/Expr.hs b/src/Nix/Expr.hs --- a/src/Nix/Expr.hs +++ b/src/Nix/Expr.hs @@ -1,10 +1,11 @@ -- | Wraps the expression submodules. -module Nix.Expr ( - module Nix.Expr.Types, - module Nix.Expr.Types.Annotated, - module Nix.Expr.Shorthands - ) where +module Nix.Expr + ( module Nix.Expr.Types + , module Nix.Expr.Types.Annotated + , module Nix.Expr.Shorthands + ) +where -import Nix.Expr.Types -import Nix.Expr.Shorthands -import Nix.Expr.Types.Annotated +import Nix.Expr.Types +import Nix.Expr.Shorthands +import Nix.Expr.Types.Annotated 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 @@ -7,13 +7,12 @@ -- 'Fix' wrapper. module Nix.Expr.Shorthands where -import Data.Fix -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Monoid -import Data.Text (Text) -import Nix.Atoms -import Nix.Expr.Types -import Text.Megaparsec.Pos (SourcePos) +import Data.Fix +import Data.List.NonEmpty ( NonEmpty(..) ) +import Data.Text ( Text ) +import Nix.Atoms +import Nix.Expr.Types +import Text.Megaparsec.Pos ( SourcePos ) -- | Make an integer literal expression. mkInt :: Integer -> NExpr @@ -33,13 +32,13 @@ mkStr :: Text -> NExpr mkStr = Fix . NStr . DoubleQuoted . \case "" -> [] - x -> [Plain x] + x -> [Plain x] -- | Make an indented string. mkIndentedStr :: Int -> Text -> NExpr mkIndentedStr w = Fix . NStr . Indented w . \case "" -> [] - x -> [Plain x] + x -> [Plain x] -- | Make a path. Use 'True' if the path should be read from the -- environment, else 'False'. @@ -48,7 +47,7 @@ mkPathF :: Bool -> FilePath -> NExprF a mkPathF False = NLiteralPath -mkPathF True = NEnvPath +mkPathF True = NEnvPath -- | Make a path expression which pulls from the NIX_PATH env variable. mkEnvPath :: FilePath -> NExpr @@ -71,6 +70,12 @@ mkSymF :: Text -> NExprF a mkSymF = NSym +mkSynHole :: Text -> NExpr +mkSynHole = Fix . mkSynHoleF + +mkSynHoleF :: Text -> NExprF a +mkSynHoleF = NSynHole + mkSelector :: Text -> NAttrPath NExpr mkSelector = (:| []) . StaticKey @@ -157,15 +162,15 @@ appendBindings :: [Binding NExpr] -> NExpr -> NExpr appendBindings newBindings (Fix e) = case e of NLet bindings e' -> Fix $ NLet (bindings <> newBindings) e' - NSet bindings -> Fix $ NSet (bindings <> newBindings) + NSet bindings -> Fix $ NSet (bindings <> newBindings) NRecSet bindings -> Fix $ NRecSet (bindings <> newBindings) - _ -> error "Can only append bindings to a set or a let" + _ -> error "Can only append bindings to a set or a let" -- | Applies a transformation to the body of a nix function. modifyFunctionBody :: (NExpr -> NExpr) -> NExpr -> NExpr modifyFunctionBody f (Fix e) = case e of NAbs params body -> Fix $ NAbs params (f body) - _ -> error "Not a function" + _ -> error "Not a function" -- | A let statement with multiple assignments. letsE :: [(Text, NExpr)] -> NExpr -> NExpr @@ -196,8 +201,7 @@ mkBinop op e1 e2 = Fix (NBinary op e1 e2) -- | Various nix binary operators -($==), ($!=), ($<), ($<=), ($>), ($>=), ($&&), ($||), ($->), - ($//), ($+), ($-), ($*), ($/), ($++) +($==), ($!=), ($<), ($<=), ($>), ($>=), ($&&), ($||), ($->), ($//), ($+), ($-), ($*), ($/), ($++) :: NExpr -> NExpr -> NExpr e1 $== e2 = mkBinop NEq e1 e2 e1 $!= e2 = mkBinop NNEq e1 e2 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 @@ -28,16 +28,16 @@ module Nix.Expr.Types where #ifdef MIN_VERSION_serialise -import Codec.Serialise (Serialise) -import qualified Codec.Serialise as Ser +import Codec.Serialise ( Serialise ) +import qualified Codec.Serialise as Ser #endif import Control.Applicative import Control.DeepSeq import Control.Monad import Data.Aeson import Data.Aeson.TH -import Data.Binary (Binary) -import qualified Data.Binary as Bin +import Data.Binary ( Binary ) +import qualified Data.Binary as Bin import Data.Data import Data.Eq.Deriving import Data.Fix @@ -46,13 +46,17 @@ #if MIN_VERSION_hashable(1, 2, 5) import Data.Hashable.Lifted #endif -import Data.List (inits, tails) -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NE -import Data.Maybe (fromMaybe) -import Data.Monoid +import Data.List ( inits + , tails + ) +import Data.List.NonEmpty ( NonEmpty(..) ) +import qualified Data.List.NonEmpty as NE +import Data.Maybe ( fromMaybe ) import Data.Ord.Deriving -import Data.Text (Text, pack, unpack) +import Data.Text ( Text + , pack + , unpack + ) import Data.Traversable import GHC.Exts import GHC.Generics @@ -65,12 +69,15 @@ import Text.Read.Deriving import Text.Show.Deriving #if MIN_VERSION_base(4, 10, 0) -import Type.Reflection (eqTypeRep) -import qualified Type.Reflection as Reflection +import Type.Reflection ( eqTypeRep ) +import qualified Type.Reflection as Reflection #endif type VarName = Text +hashAt :: VarName -> Lens' (AttrSet v) (Maybe v) +hashAt = flip alterF + -- unfortunate orphans #if MIN_VERSION_hashable(1, 2, 5) instance Hashable1 NonEmpty @@ -135,9 +142,10 @@ -- evaluate the second argument. | NAssert !r !r -- ^ Assert that the first returns true before evaluating the second. + | NSynHole !VarName + -- ^ Syntactic hole, e.g. @^foo@ , @^hole_name@ deriving (Ord, Eq, Generic, Generic1, Typeable, Data, Functor, - Foldable, Traversable, Show, NFData, - Hashable) + Foldable, Traversable, Show, NFData, Hashable) #if MIN_VERSION_hashable(1, 2, 5) instance Hashable1 NExprF @@ -158,10 +166,10 @@ #if MIN_VERSION_base(4, 10, 0) instance Lift (Fix NExprF) where - lift = dataToExpQ $ \b -> - case Reflection.typeOf b `eqTypeRep` Reflection.typeRep @Text of - Just HRefl -> Just [| pack $(liftString $ unpack b) |] - Nothing -> Nothing + lift = dataToExpQ $ \b -> + case Reflection.typeOf b `eqTypeRep` Reflection.typeRep @Text of + Just HRefl -> Just [| pack $(liftString $ unpack b) |] + Nothing -> Nothing #else instance Lift (Fix NExprF) where lift = dataToExpQ $ \b -> case cast b of @@ -187,8 +195,7 @@ -- first name, whether that be the first argument to this constructor, or -- the first member of the list in the second argument. deriving (Generic, Generic1, Typeable, Data, Ord, Eq, Functor, - Foldable, Traversable, Show, NFData, - Hashable) + Foldable, Traversable, Show, NFData, Hashable) #if MIN_VERSION_hashable(1, 2, 5) instance Hashable1 Binding @@ -243,12 +250,10 @@ 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 + 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 #endif #if MIN_VERSION_deepseq(1, 4, 3) @@ -287,7 +292,7 @@ -- | For the the 'IsString' instance, we use a plain doublequoted string. instance IsString (NString r) where - fromString "" = DoubleQuoted [] + fromString "" = DoubleQuoted [] fromString string = DoubleQuoted [Plain $ pack string] -- | A 'KeyName' is something that can appear on the left side of an @@ -312,27 +317,26 @@ data NKeyName r = DynamicKey !(Antiquoted (NString r) r) | StaticKey !VarName - deriving (Eq, Ord, Generic, Typeable, Data, Show, Read, NFData, - Hashable) + deriving (Eq, Ord, Generic, Typeable, Data, Show, Read, NFData, Hashable) #ifdef MIN_VERSION_serialise instance Serialise r => Serialise (NKeyName r) instance Serialise Pos where - encode x = Ser.encode (unPos x) - decode = mkPos <$> Ser.decode + encode x = Ser.encode (unPos x) + decode = mkPos <$> Ser.decode instance Serialise SourcePos where - encode (SourcePos f l c) = Ser.encode f <> Ser.encode l <> Ser.encode c - decode = SourcePos <$> Ser.decode <*> Ser.decode <*> Ser.decode + encode (SourcePos f l c) = Ser.encode f <> Ser.encode l <> Ser.encode c + decode = SourcePos <$> Ser.decode <*> Ser.decode <*> Ser.decode #endif instance Hashable Pos where - hashWithSalt salt x = hashWithSalt salt (unPos x) + hashWithSalt salt x = hashWithSalt salt (unPos x) instance Hashable SourcePos where - hashWithSalt salt (SourcePos f l c) = - salt `hashWithSalt` f `hashWithSalt` l `hashWithSalt` c + hashWithSalt salt (SourcePos f l c) = + salt `hashWithSalt` f `hashWithSalt` l `hashWithSalt` c instance Generic1 NKeyName where type Rep1 NKeyName = NKeyName @@ -341,10 +345,10 @@ #if MIN_VERSION_deepseq(1, 4, 3) instance NFData1 NKeyName where - liftRnf _ (StaticKey !_) = () - liftRnf _ (DynamicKey (Plain !_)) = () - liftRnf _ (DynamicKey EscapedNewline) = () - liftRnf k (DynamicKey (Antiquoted r)) = k r + liftRnf _ (StaticKey !_ ) = () + liftRnf _ (DynamicKey (Plain !_) ) = () + liftRnf _ (DynamicKey EscapedNewline) = () + liftRnf k (DynamicKey (Antiquoted r)) = k r #endif -- | Most key names are just static text, so this instance is convenient. @@ -353,22 +357,26 @@ instance Eq1 NKeyName where liftEq eq (DynamicKey a) (DynamicKey b) = liftEq2 (liftEq eq) eq a b - liftEq _ (StaticKey a) (StaticKey b) = a == b - liftEq _ _ _ = False + liftEq _ (StaticKey a) (StaticKey b) = a == b + liftEq _ _ _ = False #if MIN_VERSION_hashable(1, 2, 5) instance Hashable1 NKeyName where liftHashWithSalt h salt (DynamicKey a) = - liftHashWithSalt2 (liftHashWithSalt h) h (salt `hashWithSalt` (0 :: Int)) a + liftHashWithSalt2 (liftHashWithSalt h) h (salt `hashWithSalt` (0 :: Int)) a liftHashWithSalt _ salt (StaticKey n) = - salt `hashWithSalt` (1 :: Int) `hashWithSalt` n + salt `hashWithSalt` (1 :: Int) `hashWithSalt` n #endif -- Deriving this instance automatically is not possible because @r@ -- 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 showsPrec "StaticKey" p t -- Deriving this instance automatically is not possible because @r@ @@ -385,10 +393,10 @@ -- occurs not only as last argument in @Antiquoted (NString r) r@ instance Traversable NKeyName where traverse f = \case - DynamicKey (Plain str) -> DynamicKey . Plain <$> traverse f str - DynamicKey (Antiquoted e) -> DynamicKey . Antiquoted <$> f e - DynamicKey EscapedNewline -> pure $ DynamicKey EscapedNewline - StaticKey key -> pure (StaticKey key) + DynamicKey (Plain str) -> DynamicKey . Plain <$> traverse f str + DynamicKey (Antiquoted e ) -> DynamicKey . Antiquoted <$> f e + DynamicKey EscapedNewline -> pure $ DynamicKey EscapedNewline + StaticKey key -> pure (StaticKey key) -- | A selector (for example in a @let@ or an attribute set) is made up -- of strung-together key names. @@ -414,7 +422,7 @@ | NAnd -- ^ Logical and (&&) | NOr -- ^ Logical or (||) | NImpl -- ^ Logical implication (->) - | NUpdate -- ^ Joining two attribut sets (//) + | NUpdate -- ^ Joining two attribute sets (//) | NPlus -- ^ Addition (+) | NMinus -- ^ Subtraction (-) | NMult -- ^ Multiplication (*) @@ -430,7 +438,7 @@ -- | Get the name out of the parameter (there might be none). paramName :: Params r -> Maybe VarName -paramName (Param n) = Just n +paramName (Param n ) = Just n paramName (ParamSet _ _ n) = n #if !MIN_VERSION_deepseq(1, 4, 3) @@ -472,8 +480,8 @@ instance Binary a => Binary (NString a) instance Binary a => Binary (Binding a) instance Binary Pos where - put x = Bin.put (unPos x) - get = mkPos <$> Bin.get + put x = Bin.put (unPos x) + get = mkPos <$> Bin.get instance Binary SourcePos instance Binary a => Binary (NKeyName a) instance Binary a => Binary (Params a) @@ -486,7 +494,7 @@ instance ToJSON a => ToJSON (NString a) instance ToJSON a => ToJSON (Binding a) instance ToJSON Pos where - toJSON x = toJSON (unPos x) + toJSON x = toJSON (unPos x) instance ToJSON SourcePos instance ToJSON a => ToJSON (NKeyName a) instance ToJSON a => ToJSON (Params a) @@ -500,7 +508,7 @@ instance FromJSON a => FromJSON (NString a) instance FromJSON a => FromJSON (Binding a) instance FromJSON Pos where - parseJSON = fmap mkPos . parseJSON + parseJSON = fmap mkPos . parseJSON instance FromJSON SourcePos instance FromJSON a => FromJSON (NKeyName a) instance FromJSON a => FromJSON (Params a) @@ -525,43 +533,46 @@ fromNExpr :: g r -> (NExprF r, ann) toNExpr :: (NExprF r, ann) -> g r -ekey :: NExprAnn ann g - => NonEmpty Text - -> SourcePos - -> Lens' (Fix g) (Maybe (Fix g)) -ekey keys pos f e@(Fix x) | (NSet xs, ann) <- fromNExpr x = - case go xs of - ((v, []):_) -> fromMaybe e <$> f (Just v) - ((v, r:rest):_) -> ekey (r :| rest) pos f v +ekey + :: NExprAnn ann g + => NonEmpty Text + -> SourcePos + -> Lens' (Fix g) (Maybe (Fix g)) +ekey keys pos f e@(Fix x) | (NSet xs, ann) <- fromNExpr x = case go xs of + ((v, [] ) : _) -> fromMaybe e <$> f (Just v) + ((v, r : rest) : _) -> ekey (r :| rest) pos f v - _ -> f Nothing <&> \case - Nothing -> e - Just v -> - let entry = NamedVar (NE.map StaticKey keys) v pos - in Fix (toNExpr (NSet (entry : xs), ann)) - where - go xs = do - let keys' = NE.toList keys - (ks, rest) <- zip (inits keys') (tails keys') - case ks of - [] -> empty - j:js -> do - NamedVar ns v _p <- xs - guard $ (j:js) == (NE.toList ns ^.. traverse._StaticKey) - return (v, rest) + _ -> f Nothing <&> \case + Nothing -> e + Just v -> + let entry = NamedVar (NE.map StaticKey keys) v pos + in Fix (toNExpr (NSet (entry : xs), ann)) + where + go xs = do + let keys' = NE.toList keys + (ks, rest) <- zip (inits keys') (tails keys') + case ks of + [] -> empty + j : js -> do + NamedVar ns v _p <- xs + guard $ (j : js) == (NE.toList ns ^.. traverse . _StaticKey) + return (v, rest) ekey _ _ f e = fromMaybe e <$> f Nothing stripPositionInfo :: NExpr -> NExpr stripPositionInfo = transport phi - where - phi (NSet binds) = NSet (map go binds) - phi (NRecSet binds) = NRecSet (map go binds) - phi (NLet binds body) = NLet (map go binds) body - phi x = x + where + phi (NSet binds ) = NSet (map go binds) + phi (NRecSet binds ) = NRecSet (map go binds) + phi (NLet binds body) = NLet (map go binds) body + phi x = x - go (NamedVar path r _pos) = NamedVar path r nullPos - go (Inherit ms names _pos) = Inherit ms names nullPos + go (NamedVar path r _pos) = NamedVar path r nullPos + go (Inherit ms names _pos) = Inherit ms names nullPos nullPos :: SourcePos nullPos = SourcePos "" (mkPos 1) (mkPos 1) + + + 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 @@ -18,43 +18,50 @@ module Nix.Expr.Types.Annotated ( module Nix.Expr.Types.Annotated , module Data.Functor.Compose - , SourcePos(..), unPos, mkPos - )where + , SourcePos(..) + , unPos + , mkPos + ) +where #ifdef MIN_VERSION_serialise -import Codec.Serialise +import Codec.Serialise #endif -import Control.DeepSeq -import Data.Aeson (ToJSON(..), FromJSON(..)) -import Data.Aeson.TH -import Data.Binary (Binary(..)) -import Data.Data -import Data.Eq.Deriving -import Data.Fix -import Data.Function (on) -import Data.Functor.Compose -import Data.Hashable +import Control.DeepSeq +import Data.Aeson ( ToJSON(..) + , FromJSON(..) + ) +import Data.Aeson.TH +import Data.Binary ( Binary(..) ) +import Data.Data +import Data.Eq.Deriving +import Data.Fix +import Data.Function ( on ) +import Data.Functor.Compose +import Data.Hashable #if MIN_VERSION_hashable(1, 2, 5) -import Data.Hashable.Lifted +import Data.Hashable.Lifted #endif -import Data.Ord.Deriving -import Data.Semigroup -import Data.Text (Text, pack) -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 +import Data.Ord.Deriving +import Data.Text ( Text + , pack + ) +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 -- | A location in a source file data SrcSpan = SrcSpan { spanBegin :: SourcePos , spanEnd :: SourcePos } - deriving (Ord, Eq, Generic, Typeable, Data, Show, NFData, - Hashable) + deriving (Ord, Eq, Generic, Typeable, Data, Show, NFData, Hashable) #ifdef MIN_VERSION_serialise instance Serialise SrcSpan @@ -95,8 +102,7 @@ $(deriveJSON2 defaultOptions ''Ann) instance Semigroup SrcSpan where - s1 <> s2 = SrcSpan ((min `on` spanBegin) s1 s2) - ((max `on` spanEnd) s1 s2) + s1 <> s2 = SrcSpan ((min `on` spanBegin) s1 s2) ((max `on` spanEnd) s1 s2) type AnnF ann f = Compose (Ann ann) f @@ -132,8 +138,8 @@ #ifdef MIN_VERSION_serialise instance Serialise r => Serialise (Compose (Ann SrcSpan) NExprF r) where - encode (Compose (Ann ann a)) = encode ann <> encode a - decode = (Compose .) . Ann <$> decode <*> decode + encode (Compose (Ann ann a)) = encode ann <> encode a + decode = (Compose .) . Ann <$> decode <*> decode #endif pattern AnnE :: forall ann (g :: * -> *). ann @@ -148,32 +154,32 @@ nUnary :: Ann SrcSpan NUnaryOp -> NExprLoc -> NExprLoc nUnary (Ann s1 u) e1@(AnnE s2 _) = AnnE (s1 <> s2) (NUnary u e1) -nUnary _ _ = error "nUnary: unexpected" +nUnary _ _ = error "nUnary: unexpected" 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) nBinary _ _ _ = error "nBinary: unexpected" -nSelectLoc :: NExprLoc -> Ann SrcSpan (NAttrPath NExprLoc) -> Maybe NExprLoc - -> NExprLoc +nSelectLoc + :: NExprLoc -> Ann SrcSpan (NAttrPath NExprLoc) -> Maybe NExprLoc -> NExprLoc nSelectLoc e1@(AnnE s1 _) (Ann s2 ats) d = case d of Nothing -> AnnE (s1 <> s2) (NSelect e1 ats Nothing) Just (e2@(AnnE s3 _)) -> AnnE (s1 <> s2 <> s3) (NSelect e1 ats (Just e2)) - _ -> error "nSelectLoc: unexpected" + _ -> error "nSelectLoc: unexpected" nSelectLoc _ _ _ = error "nSelectLoc: unexpected" nHasAttr :: NExprLoc -> Ann SrcSpan (NAttrPath NExprLoc) -> NExprLoc nHasAttr e1@(AnnE s1 _) (Ann s2 ats) = AnnE (s1 <> s2) (NHasAttr e1 ats) -nHasAttr _ _ = error "nHasAttr: unexpected" +nHasAttr _ _ = error "nHasAttr: unexpected" nApp :: NExprLoc -> NExprLoc -> NExprLoc nApp e1@(AnnE s1 _) e2@(AnnE s2 _) = AnnE (s1 <> s2) (NBinary NApp e1 e2) -nApp _ _ = error "nApp: unexpected" +nApp _ _ = error "nApp: unexpected" nAbs :: Ann SrcSpan (Params NExprLoc) -> NExprLoc -> NExprLoc nAbs (Ann s1 ps) e1@(AnnE s2 _) = AnnE (s1 <> s2) (NAbs ps e1) -nAbs _ _ = error "nAbs: unexpected" +nAbs _ _ = error "nAbs: unexpected" nStr :: Ann SrcSpan (NString NExprLoc) -> NExprLoc nStr (Ann s1 s) = AnnE s1 (NStr s) @@ -191,6 +197,9 @@ pattern NSym_ :: SrcSpan -> VarName -> NExprLocF r pattern NSym_ ann x = Compose (Ann ann (NSym x)) + +pattern NSynHole_ :: SrcSpan -> Text -> NExprLocF r +pattern NSynHole_ ann x = Compose (Ann ann (NSynHole x)) pattern NConstant_ :: SrcSpan -> NAtom -> NExprLocF r pattern NConstant_ ann x = Compose (Ann ann (NConstant x)) diff --git a/src/Nix/Frames.hs b/src/Nix/Frames.hs --- a/src/Nix/Frames.hs +++ b/src/Nix/Frames.hs @@ -4,16 +4,26 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} -module Nix.Frames (NixLevel(..), Frames, Framed, NixFrame(..), - NixException(..), withFrame, throwError, - module Data.Typeable, - module Control.Exception) where +module Nix.Frames + ( NixLevel(..) + , Frames + , Framed + , NixFrame(..) + , NixException(..) + , withFrame + , throwError + , module Data.Typeable + , module Control.Exception + ) +where -import Control.Exception hiding (catch, evaluate) -import Control.Monad.Catch -import Control.Monad.Reader -import Data.Typeable hiding (typeOf) -import Nix.Utils +import Control.Exception hiding ( catch + , evaluate + ) +import Control.Monad.Catch +import Control.Monad.Reader +import Data.Typeable hiding ( typeOf ) +import Nix.Utils data NixLevel = Fatal | Error | Warning | Info | Debug deriving (Ord, Eq, Bounded, Enum, Show) @@ -24,8 +34,8 @@ } instance Show NixFrame where - show (NixFrame level f) = - "Nix frame at level " ++ show level ++ ": "++ show f + show (NixFrame level f) = + "Nix frame at level " ++ show level ++ ": " ++ show f type Frames = [NixFrame] @@ -36,11 +46,13 @@ instance Exception NixException -withFrame :: forall s e m a. (Framed e m, Exception s) => NixLevel -> s -> m a -> m a +withFrame + :: forall s e m a . (Framed e m, Exception s) => NixLevel -> s -> m a -> m a withFrame level f = local (over hasLens (NixFrame level (toException f) :)) -throwError :: forall s e m a. (Framed e m, Exception s, MonadThrow m) => s -> m a +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 error..." - throwM $ NixException (NixFrame Error (toException err):context) + context <- asks (view hasLens) + traceM "Throwing error..." + throwM $ NixException (NixFrame Error (toException err) : context) diff --git a/src/Nix/Fresh.hs b/src/Nix/Fresh.hs new file mode 100644 --- /dev/null +++ b/src/Nix/Fresh.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Nix.Fresh where + +import Control.Applicative +import Control.Monad.Base +import Control.Monad.Catch +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.Ref +import Control.Monad.ST +import Control.Monad.State.Strict +import Control.Monad.Writer +import Data.Typeable +#ifdef MIN_VERSION_haskeline +import System.Console.Haskeline.MonadException hiding(catch) +#endif + +import Nix.Var +import Nix.Thunk + +newtype FreshIdT i m a = FreshIdT { unFreshIdT :: ReaderT (Var m i) m a } + deriving + ( Functor + , Applicative + , Alternative + , Monad + , MonadPlus + , MonadFix + , MonadRef + , MonadAtomicRef + , MonadIO + , MonadCatch + , MonadThrow +#ifdef MIN_VERSION_haskeline + , MonadException +#endif + ) + +instance MonadTrans (FreshIdT i) where + lift = FreshIdT . lift + +instance MonadBase b m => MonadBase b (FreshIdT i m) where + liftBase = FreshIdT . liftBase + +-- instance MonadTransControl (FreshIdT i) where +-- type StT (FreshIdT i) a = StT (ReaderT (Var m i)) a +-- liftWith = defaultLiftWith FreshIdT unFreshIdT +-- restoreT = defaultRestoreT FreshIdT + +-- instance MonadBaseControl b m => MonadBaseControl b (FreshIdT i m) where +-- type StM (FreshIdT i m) a = ComposeSt (FreshIdT i) m a +-- liftBaseWith = defaultLiftBaseWith +-- restoreM = defaultRestoreM + +instance ( MonadVar m + , Eq i + , Ord i + , Show i + , Enum i + , Typeable i + ) + => MonadThunkId (FreshIdT i m) where + type ThunkId (FreshIdT i m) = i + freshId = FreshIdT $ do + v <- ask + atomicModifyVar v (\i -> (succ i, i)) + +runFreshIdT :: Functor m => Var m i -> FreshIdT i m a -> m a +runFreshIdT i m = runReaderT (unFreshIdT m) i + +instance MonadThunkId m => MonadThunkId (ReaderT r m) where + type ThunkId (ReaderT r m) = ThunkId m +instance (Monoid w, MonadThunkId m) => MonadThunkId (WriterT w m) where + type ThunkId (WriterT w m) = ThunkId m +instance MonadThunkId m => MonadThunkId (ExceptT e m) where + type ThunkId (ExceptT e m) = ThunkId m +instance MonadThunkId m => MonadThunkId (StateT s m) where + type ThunkId (StateT s m) = ThunkId m + +-- Orphan instance needed by Infer.hs and Lint.hs + +-- Since there's no forking, it's automatically atomic. +instance MonadAtomicRef (ST s) where + atomicModifyRef r f = do + v <- readRef r + let (a, b) = f v + writeRef r a + return b + atomicModifyRef' r f = do + v <- readRef r + let (a, b) = f v + writeRef r $! a + return b + + + + + + + diff --git a/src/Nix/Fresh/Basic.hs b/src/Nix/Fresh/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Nix/Fresh/Basic.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeSynonymInstances #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Nix.Fresh.Basic where + +import Control.Monad.Reader +import Nix.Effects +import Nix.Render +import Nix.Fresh +import Nix.Value + +type StdIdT = FreshIdT Int + +instance MonadFile m => MonadFile (StdIdT m) +instance MonadIntrospect m => MonadIntrospect (StdIdT m) +instance MonadStore m => MonadStore (StdIdT m) where + addPath' = lift . addPath' + toFile_' = (lift .) . toFile_' +instance MonadPutStr m => MonadPutStr (StdIdT m) +instance MonadHttp m => MonadHttp (StdIdT m) +instance MonadEnv m => MonadEnv (StdIdT m) +instance MonadInstantiate m => MonadInstantiate (StdIdT m) +instance MonadExec m => MonadExec (StdIdT m) + +instance (MonadEffects t f m, MonadDataContext f m) + => MonadEffects t f (StdIdT m) where + makeAbsolutePath = lift . makeAbsolutePath @t @f @m + findEnvPath = lift . findEnvPath @t @f @m + findPath = (lift .) . findPath @t @f @m + importPath path = do + i <- FreshIdT ask + p <- lift $ importPath @t @f @m path + return $ liftNValue (runFreshIdT i) p + pathToDefaultNix = lift . pathToDefaultNix @t @f @m + derivationStrict v = do + i <- FreshIdT ask + p <- lift $ derivationStrict @t @f @m (unliftNValue (runFreshIdT i) v) + return $ liftNValue (runFreshIdT i) p + traceEffect = lift . traceEffect @t @f @m + diff --git a/src/Nix/Json.hs b/src/Nix/Json.hs new file mode 100644 --- /dev/null +++ b/src/Nix/Json.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} + +module Nix.Json where + +import Control.Monad +import Control.Monad.Trans +import qualified Data.Aeson as A +import qualified Data.Aeson.Encoding as A +import qualified Data.HashMap.Lazy as HM +import qualified Data.Text as Text +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import qualified Data.Vector as V +import Nix.Atoms +import Nix.Effects +import Nix.Exec +import Nix.Frames +import Nix.String +import Nix.Thunk +import Nix.Utils +import Nix.Value + +nvalueToJSONNixString :: MonadNix e t f m => NValue t f m -> m NixString +nvalueToJSONNixString = + runWithStringContextT + . fmap + ( TL.toStrict + . TL.decodeUtf8 + . A.encodingToLazyByteString + . toEncodingSorted + ) + . nvalueToJSON + +nvalueToJSON :: MonadNix e t f m => NValue t f m -> WithStringContextT m A.Value +nvalueToJSON = \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 (join . lift . flip force (return . nvalueToJSON)) l + NVSet m _ -> case HM.lookup "outPath" m of + Nothing -> + A.Object <$> traverse (join . lift . flip force (return . nvalueToJSON)) m + Just outPath -> join $ lift $ force outPath (return . nvalueToJSON) + NVPath p -> do + fp <- lift $ unStorePath <$> addPath p + addSingletonStringContext $ StringContext (Text.pack fp) DirectPath + return $ A.toJSON fp + v -> lift $ throwError $ CoercionToJson v diff --git a/src/Nix/Lint.hs b/src/Nix/Lint.hs --- a/src/Nix/Lint.hs +++ b/src/Nix/Lint.hs @@ -1,8 +1,8 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -13,6 +13,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -23,32 +24,35 @@ module Nix.Lint where -import Control.Exception import Control.Monad import Control.Monad.Catch import Control.Monad.Fix -import Control.Monad.Reader (MonadReader) +import Control.Monad.Reader ( MonadReader ) +import Control.Monad.Ref import Control.Monad.ST import Control.Monad.Trans.Reader import Data.Coerce -import Data.HashMap.Lazy (HashMap) -import qualified Data.HashMap.Lazy as M +import Data.HashMap.Lazy ( HashMap ) +import qualified Data.HashMap.Lazy as M import Data.List -import qualified Data.List.NonEmpty as NE -import Data.STRef -import Data.Text (Text) -import qualified Data.Text as Text +import qualified Data.List.NonEmpty as NE +import Data.Text ( Text ) +import qualified Data.Text as Text import Nix.Atoms import Nix.Context import Nix.Convert -import Nix.Eval (MonadEval(..)) -import qualified Nix.Eval as Eval +import Nix.Eval ( MonadEval(..) ) +import qualified Nix.Eval as Eval import Nix.Expr import Nix.Frames +import Nix.Fresh +import Nix.String import Nix.Options import Nix.Scope import Nix.Thunk +import Nix.Thunk.Basic import Nix.Utils +import Nix.Var data TAtom = TInt @@ -68,38 +72,38 @@ deriving Functor compareTypes :: NTypeF m r -> NTypeF m r -> Ordering -compareTypes (TConstant _) (TConstant _) = EQ -compareTypes (TConstant _) _ = LT -compareTypes _ (TConstant _) = GT -compareTypes TStr TStr = EQ -compareTypes TStr _ = LT -compareTypes _ TStr = GT -compareTypes (TList _) (TList _) = EQ -compareTypes (TList _) _ = LT -compareTypes _ (TList _) = GT -compareTypes (TSet _) (TSet _) = EQ -compareTypes (TSet _) _ = LT -compareTypes _ (TSet _) = GT -compareTypes TClosure {} TClosure {} = EQ -compareTypes TClosure {} _ = LT -compareTypes _ TClosure {} = GT -compareTypes TPath TPath = EQ -compareTypes TPath _ = LT -compareTypes _ TPath = GT -compareTypes (TBuiltin _ _) (TBuiltin _ _) = EQ +compareTypes (TConstant _) (TConstant _) = EQ +compareTypes (TConstant _) _ = LT +compareTypes _ (TConstant _) = GT +compareTypes TStr TStr = EQ +compareTypes TStr _ = LT +compareTypes _ TStr = GT +compareTypes (TList _) (TList _) = EQ +compareTypes (TList _) _ = LT +compareTypes _ (TList _) = GT +compareTypes (TSet _) (TSet _) = EQ +compareTypes (TSet _) _ = LT +compareTypes _ (TSet _) = GT +compareTypes TClosure{} TClosure{} = EQ +compareTypes TClosure{} _ = LT +compareTypes _ TClosure{} = GT +compareTypes TPath TPath = EQ +compareTypes TPath _ = LT +compareTypes _ TPath = GT +compareTypes (TBuiltin _ _) (TBuiltin _ _) = EQ data NSymbolicF r = NAny | NMany [r] deriving (Show, Eq, Ord, Functor, Foldable, Traversable) -newtype SThunk m = SThunk { getSThunk :: Thunk m (Symbolic m) } +newtype SThunk m = SThunk { getSThunk :: NThunkF m (Symbolic m) } newtype Symbolic m = Symbolic { getSymbolic :: Var m (NSymbolicF (NTypeF m (SThunk m))) } instance Show (Symbolic m) where - show _ = "" + show _ = "" everyPossible :: MonadVar m => m (Symbolic m) everyPossible = packSymbolic NAny @@ -107,82 +111,87 @@ mkSymbolic :: MonadVar m => [NTypeF m (SThunk m)] -> m (Symbolic m) mkSymbolic xs = packSymbolic (NMany xs) -packSymbolic :: MonadVar m - => NSymbolicF (NTypeF m (SThunk m)) -> m (Symbolic m) +packSymbolic :: MonadVar m => NSymbolicF (NTypeF m (SThunk m)) -> m (Symbolic m) packSymbolic = fmap coerce . newVar -unpackSymbolic :: MonadVar m - => Symbolic m -> m (NSymbolicF (NTypeF m (SThunk m))) +unpackSymbolic + :: MonadVar m => Symbolic m -> m (NSymbolicF (NTypeF m (SThunk m))) unpackSymbolic = readVar . coerce -type MonadLint e m = (Scoped e (SThunk m) m, Framed e m, MonadVar m) +type MonadLint e m + = (Scoped (SThunk m) m, Framed e m, MonadVar m, MonadCatch m, MonadThunkId m) -symerr :: forall e m a. MonadLint e m => String -> m a +symerr :: forall e m a . MonadLint e m => String -> m a symerr = evalError @(Symbolic m) . ErrorCall renderSymbolic :: MonadLint e m => Symbolic m -> m String renderSymbolic = unpackSymbolic >=> \case - NAny -> return "" - NMany xs -> fmap (intercalate ", ") $ forM xs $ \case - TConstant ys -> fmap (intercalate ", ") $ forM ys $ \case - TInt -> return "int" - TFloat -> return "float" - TBool -> return "bool" - TNull -> return "null" - TStr -> return "string" - TList r -> do - x <- force r renderSymbolic - return $ "[" ++ x ++ "]" - TSet Nothing -> return "" - TSet (Just s) -> do - x <- traverse (`force` renderSymbolic) s - return $ "{" ++ 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 - return $ "(" ++ show args' ++ " -> " ++ sym' ++ ")" - TPath -> return "path" - TBuiltin _n _f -> return "" + NAny -> return "" + NMany xs -> fmap (intercalate ", ") $ forM xs $ \case + TConstant ys -> fmap (intercalate ", ") $ forM ys $ \case + TInt -> return "int" + TFloat -> return "float" + TBool -> return "bool" + TNull -> return "null" + TStr -> return "string" + TList r -> do + x <- force r renderSymbolic + return $ "[" ++ x ++ "]" + TSet Nothing -> return "" + TSet (Just s) -> do + x <- traverse (`force` renderSymbolic) s + return $ "{" ++ 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 + return $ "(" ++ show args' ++ " -> " ++ sym' ++ ")" + TPath -> return "path" + TBuiltin _n _f -> return "" -- This function is order and uniqueness preserving (of types). -merge :: forall e m. MonadLint e m - => NExprF () -> [NTypeF m (SThunk m)] -> [NTypeF m (SThunk m)] - -> m [NTypeF m (SThunk m)] +merge + :: forall e m + . MonadLint e m + => NExprF () + -> [NTypeF m (SThunk m)] + -> [NTypeF m (SThunk m)] + -> m [NTypeF m (SThunk m)] merge context = go - where - go :: [NTypeF m (SThunk m)] -> [NTypeF m (SThunk m)] - -> m [NTypeF m (SThunk m)] - go [] _ = return [] - go _ [] = return [] - go (x:xs) (y:ys) = case (x, y) of - (TStr, TStr) -> (TStr :) <$> go xs ys - (TPath, TPath) -> (TPath :) <$> go xs ys - (TConstant ls, TConstant rs) -> - (TConstant (ls `intersect` rs) :) <$> go xs ys - (TList l, TList r) -> force l $ \l' -> force r $ \r' -> do - m <- thunk $ unify context l' r' - (TList m :) <$> go xs ys - (TSet x, TSet Nothing) -> (TSet x :) <$> go xs ys - (TSet Nothing, TSet x) -> (TSet x :) <$> go xs ys - (TSet (Just l), TSet (Just r)) -> do - m <- sequenceA $ M.intersectionWith - (\i j -> i >>= \i' -> j >>= \j' -> - force i' $ \i'' -> force j' $ \j'' -> - thunk $ unify context i'' j'') - (return <$> l) (return <$> r) - if M.null m - then go xs ys - else (TSet (Just m) :) <$> go xs ys - (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 - | otherwise -> error "impossible" + where + go + :: [NTypeF m (SThunk m)] -> [NTypeF m (SThunk m)] -> m [NTypeF m (SThunk m)] + go [] _ = return [] + go _ [] = return [] + go (x : xs) (y : ys) = case (x, y) of + (TStr , TStr ) -> (TStr :) <$> go xs ys + (TPath, TPath) -> (TPath :) <$> go xs ys + (TConstant ls, TConstant rs) -> + (TConstant (ls `intersect` rs) :) <$> go xs ys + (TList l, TList r) -> force l $ \l' -> force r $ \r' -> do + m <- thunk $ unify context l' r' + (TList m :) <$> go xs ys + (TSet x , TSet Nothing ) -> (TSet x :) <$> go xs ys + (TSet Nothing , TSet x ) -> (TSet x :) <$> go xs ys + (TSet (Just l), TSet (Just r)) -> do + m <- sequenceA $ M.intersectionWith + (\i j -> i >>= \i' -> + j + >>= \j' -> force i' + $ \i'' -> force j' $ \j'' -> thunk $ unify context i'' j'' + ) + (return <$> l) + (return <$> r) + if M.null m then go xs ys else (TSet (Just m) :) <$> go xs ys + (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 + | otherwise -> error "impossible" {- mergeFunctions pl nl fl pr fr xs ys = do @@ -204,31 +213,36 @@ -} -- | unify raises an error if the result is would be 'NMany []'. -unify :: forall e m. MonadLint e m - => NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m) +unify + :: forall e m + . MonadLint e m + => NExprF () + -> Symbolic m + -> Symbolic m + -> m (Symbolic m) unify context (Symbolic x) (Symbolic y) = do - x' <- readVar x - y' <- readVar y - case (x', y') of - (NAny, _) -> do - writeVar x y' - return $ Symbolic y - (_, NAny) -> do - writeVar y x' - return $ Symbolic x - (NMany xs, NMany ys) -> do - m <- merge context xs ys - if null m - then do - -- x' <- renderSymbolic (Symbolic x) - -- y' <- renderSymbolic (Symbolic y) - throwError $ ErrorCall "Cannot unify " - -- ++ show x' ++ " with " ++ show y' - -- ++ " in context: " ++ show context - else do - writeVar x (NMany m) - writeVar y (NMany m) - packSymbolic (NMany m) + x' <- readVar x + y' <- readVar y + case (x', y') of + (NAny, _) -> do + writeVar x y' + return $ Symbolic y + (_, NAny) -> do + writeVar y x' + return $ Symbolic x + (NMany xs, NMany ys) -> do + m <- merge context xs ys + if null m + then do + -- x' <- renderSymbolic (Symbolic x) + -- y' <- renderSymbolic (Symbolic y) + throwError $ ErrorCall "Cannot unify " + -- ++ show x' ++ " with " ++ show y' + -- ++ " in context: " ++ show context + else do + writeVar x (NMany m) + writeVar y (NMany m) + packSymbolic (NMany m) -- These aren't worth defining yet, because once we move to Hindley-Milner, -- we're not going to be managing Symbolic values this way anymore. @@ -237,182 +251,201 @@ instance ToValue [SThunk m] m (Symbolic m) where -instance FromValue (Text, DList Text) m (Symbolic m) where +instance FromValue NixString m (Symbolic m) where instance FromValue (AttrSet (SThunk m), AttrSet SourcePos) m (Symbolic m) where instance ToValue (AttrSet (SThunk m), AttrSet SourcePos) m (Symbolic m) where -instance MonadLint e m => MonadThunk (Symbolic m) (SThunk m) m where - thunk = fmap coerce . buildThunk - force = forceThunk . coerce - value = coerce . valueRef +instance MonadLint e m => MonadThunk (SThunk m) m (Symbolic m) where + thunk = fmap SThunk . thunk + thunkId = thunkId . getSThunk + query x b f = query (getSThunk x) b f + queryM x b f = queryM (getSThunk x) b f + force = force . getSThunk + forceEff = forceEff . getSThunk + wrapValue = SThunk . wrapValue + getValue = getValue . getSThunk instance MonadLint e m => MonadEval (Symbolic m) m where - freeVariable var = symerr $ - "Undefined variable '" ++ Text.unpack var ++ "'" + freeVariable var = symerr $ "Undefined variable '" ++ Text.unpack var ++ "'" - attrMissing ks Nothing = - evalError @(Symbolic m) $ ErrorCall $ - "Inheriting unknown attribute: " - ++ intercalate "." (map Text.unpack (NE.toList ks)) + attrMissing ks Nothing = + evalError @(Symbolic m) + $ ErrorCall + $ "Inheriting unknown attribute: " + ++ intercalate "." (map Text.unpack (NE.toList ks)) - attrMissing ks (Just s) = - evalError @(Symbolic m) $ ErrorCall $ "Could not look up attribute " - ++ intercalate "." (map Text.unpack (NE.toList ks)) - ++ " in " ++ show s + attrMissing ks (Just s) = + evalError @(Symbolic m) + $ ErrorCall + $ "Could not look up attribute " + ++ intercalate "." (map Text.unpack (NE.toList ks)) + ++ " in " + ++ show s - evalCurPos = do - f <- value <$> mkSymbolic [TPath] - l <- value <$> mkSymbolic [TConstant [TInt]] - c <- value <$> mkSymbolic [TConstant [TInt]] - mkSymbolic [TSet (Just (M.fromList (go f l c)))] - where - go f l c = - [ (Text.pack "file", f) - , (Text.pack "line", l) - , (Text.pack "col", c) ] + evalCurPos = do + f <- wrapValue <$> mkSymbolic [TPath] + l <- wrapValue <$> mkSymbolic [TConstant [TInt]] + c <- wrapValue <$> mkSymbolic [TConstant [TInt]] + mkSymbolic [TSet (Just (M.fromList (go f l c)))] + where + go f l c = + [(Text.pack "file", f), (Text.pack "line", l), (Text.pack "col", c)] - evalConstant c = mkSymbolic [TConstant [go c]] - where - go = \case - NInt _ -> TInt - NFloat _ -> TFloat - NBool _ -> TBool - NNull -> TNull + evalConstant c = mkSymbolic [TConstant [go c]] + where + go = \case + NInt _ -> TInt + NFloat _ -> TFloat + NBool _ -> TBool + NNull -> TNull - evalString = const $ mkSymbolic [TStr] - evalLiteralPath = const $ mkSymbolic [TPath] - evalEnvPath = const $ mkSymbolic [TPath] + evalString = const $ mkSymbolic [TStr] + evalLiteralPath = const $ mkSymbolic [TPath] + evalEnvPath = const $ mkSymbolic [TPath] - evalUnary op arg = - unify (void (NUnary op arg)) arg - =<< mkSymbolic [TConstant [TInt, TBool]] + evalUnary op arg = + unify (void (NUnary op arg)) arg =<< mkSymbolic [TConstant [TInt, TBool]] - evalBinary = lintBinaryOp + evalBinary = lintBinaryOp - evalWith scope body = do - -- The scope is deliberately wrapped in a thunk here, since it is - -- evaluated each time a name is looked up within the weak scope, and - -- we want to be sure the action it evaluates is to force a thunk, so - -- its value is only computed once. - s <- thunk scope - pushWeakScope ?? body $ force s $ unpackSymbolic >=> \case - NMany [TSet (Just s')] -> return s' - NMany [TSet Nothing] -> error "NYI: with unknown" - _ -> throwError $ ErrorCall "scope must be a set in with statement" + -- The scope is deliberately wrapped in a thunk here, since it is evaluated + -- each time a name is looked up within the weak scope, and we want to be + -- sure the action it evaluates is to force a thunk, so its value is only + -- computed once. + evalWith scope body = do + s <- thunk @(SThunk m) @m @(Symbolic m) scope + pushWeakScope ?? body $ force s $ unpackSymbolic >=> \case + NMany [TSet (Just s')] -> return s' + NMany [TSet Nothing] -> error "NYI: with unknown" + _ -> throwError $ ErrorCall "scope must be a set in with statement" - evalIf cond t f = do - t' <- t - f' <- f - let e = NIf cond t' f' - _ <- unify (void e) cond =<< mkSymbolic [TConstant [TBool]] - unify (void e) t' f' + evalIf cond t f = do + t' <- t + f' <- f + let e = NIf cond t' f' + _ <- unify (void e) cond =<< mkSymbolic [TConstant [TBool]] + unify (void e) t' f' - evalAssert cond body = do - body' <- body - let e = NAssert cond body' - _ <- unify (void e) cond =<< mkSymbolic [TConstant [TBool]] - pure body' + evalAssert cond body = do + body' <- body + let e = NAssert cond body' + _ <- unify (void e) cond =<< mkSymbolic [TConstant [TBool]] + pure body' - evalApp = (fmap snd .) . lintApp (NBinary NApp () ()) - evalAbs params _ = mkSymbolic [TClosure (void params)] + evalApp = (fmap snd .) . lintApp (NBinary NApp () ()) + evalAbs params _ = mkSymbolic [TClosure (void params)] - evalError = throwError + evalError = throwError lintBinaryOp - :: forall e m. (MonadLint e m, MonadEval (Symbolic m) m) - => NBinaryOp -> Symbolic m -> m (Symbolic m) -> m (Symbolic m) + :: forall e m + . (MonadLint e m, MonadEval (Symbolic m) m) + => NBinaryOp + -> Symbolic m + -> m (Symbolic m) + -> m (Symbolic m) lintBinaryOp op lsym rarg = do - rsym <- rarg - y <- thunk everyPossible - case op of - NApp -> symerr "lintBinaryOp:NApp: should never get here" - NEq -> check lsym rsym [ TConstant [TInt, TBool, TNull] - , TStr - , TList y ] - NNEq -> check lsym rsym [ TConstant [TInt, TBool, TNull] - , TStr - , TList y ] + rsym <- rarg + y <- thunk everyPossible + case op of + NApp -> symerr "lintBinaryOp:NApp: should never get here" + NEq -> check lsym rsym [TConstant [TInt, TBool, TNull], TStr, TList y] + NNEq -> check lsym rsym [TConstant [TInt, TBool, TNull], TStr, TList y] - NLt -> check lsym rsym [ TConstant [TInt, TBool, TNull] ] - NLte -> check lsym rsym [ TConstant [TInt, TBool, TNull] ] - NGt -> check lsym rsym [ TConstant [TInt, TBool, TNull] ] - NGte -> check lsym rsym [ TConstant [TInt, TBool, TNull] ] + NLt -> check lsym rsym [TConstant [TInt, TBool, TNull]] + NLte -> check lsym rsym [TConstant [TInt, TBool, TNull]] + NGt -> check lsym rsym [TConstant [TInt, TBool, TNull]] + NGte -> check lsym rsym [TConstant [TInt, TBool, TNull]] - NAnd -> check lsym rsym [ TConstant [TBool] ] - NOr -> check lsym rsym [ TConstant [TBool] ] - NImpl -> check lsym rsym [ TConstant [TBool] ] + NAnd -> check lsym rsym [TConstant [TBool]] + NOr -> check lsym rsym [TConstant [TBool]] + NImpl -> check lsym rsym [TConstant [TBool]] - -- jww (2018-04-01): NYI: Allow Path + Str - NPlus -> check lsym rsym [ TConstant [TInt], TStr, TPath ] - NMinus -> check lsym rsym [ TConstant [TInt] ] - NMult -> check lsym rsym [ TConstant [TInt] ] - NDiv -> check lsym rsym [ TConstant [TInt] ] + -- jww (2018-04-01): NYI: Allow Path + Str + NPlus -> check lsym rsym [TConstant [TInt], TStr, TPath] + NMinus -> check lsym rsym [TConstant [TInt]] + NMult -> check lsym rsym [TConstant [TInt]] + NDiv -> check lsym rsym [TConstant [TInt]] - NUpdate -> check lsym rsym [ TSet Nothing ] + NUpdate -> check lsym rsym [TSet Nothing] - NConcat -> check lsym rsym [ TList y ] - where - check lsym rsym xs = do - let e = NBinary op lsym rsym - m <- mkSymbolic xs - _ <- unify (void e) lsym m - _ <- unify (void e) rsym m - unify (void e) lsym rsym + NConcat -> check lsym rsym [TList y] + where + check lsym rsym xs = do + let e = NBinary op lsym rsym + m <- mkSymbolic xs + _ <- unify (void e) lsym m + _ <- unify (void e) rsym m + unify (void e) lsym rsym infixl 1 `lintApp` -lintApp :: forall e m. MonadLint e m - => NExprF () -> Symbolic m -> m (Symbolic m) - -> m (HashMap VarName (Symbolic m), Symbolic m) +lintApp + :: forall e m + . MonadLint e m + => NExprF () + -> 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" + 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 [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" + 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" - y <- everyPossible - (args,) <$> foldM (unify context) y ys + y <- everyPossible + (head args, ) <$> foldM (unify context) y ys newtype Lint s a = Lint - { runLint :: ReaderT (Context (Lint s) (SThunk (Lint s))) (ST s) a } - deriving (Functor, Applicative, Monad, MonadFix, - MonadReader (Context (Lint s) (SThunk (Lint s)))) - -instance MonadVar (Lint s) where - type Var (Lint s) = STRef s - - newVar x = Lint $ ReaderT $ \_ -> newSTRef x - readVar x = Lint $ ReaderT $ \_ -> readSTRef x - writeVar x y = Lint $ ReaderT $ \_ -> writeSTRef x y - atomicModifyVar x f = Lint $ ReaderT $ \_ -> do - res <- snd . f <$> readSTRef x - _ <- modifySTRef x (fst . f) - return res + { runLint :: ReaderT (Context (Lint s) (SThunk (Lint s))) (FreshIdT Int (ST s)) a } + deriving + ( Functor + , Applicative + , Monad + , MonadFix + , MonadReader (Context (Lint s) (SThunk (Lint s))) + , MonadThunkId + , MonadRef + , MonadAtomicRef + ) instance MonadThrow (Lint s) where - throwM e = Lint $ ReaderT $ \_ -> throw e + throwM e = Lint $ ReaderT $ \_ -> throw e +instance MonadCatch (Lint s) where + catch _m _h = Lint $ ReaderT $ \_ -> error "Cannot catch in 'Lint s'" + runLintM :: Options -> Lint s a -> ST s a -runLintM opts = flip runReaderT (newContext opts) . runLint +runLintM opts action = do + i <- newVar (1 :: Int) + runFreshIdT i $ flip runReaderT (newContext opts) $ runLint action symbolicBaseEnv :: Monad m => m (Scopes m (SThunk m)) symbolicBaseEnv = return emptyScopes lint :: Options -> NExprLoc -> ST s (Symbolic (Lint s)) -lint opts expr = runLintM opts $ - symbolicBaseEnv - >>= (`pushScopes` - adi (Eval.eval . annotated . getCompose) - Eval.addSourcePositions expr) +lint opts expr = + runLintM opts + $ symbolicBaseEnv + >>= (`pushScopes` adi (Eval.eval . annotated . getCompose) + Eval.addSourcePositions + expr + ) + +instance Scoped (SThunk (Lint s)) (Lint s) where + currentScopes = currentScopesReader + clearScopes = clearScopesReader @(Lint s) @(SThunk (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 @@ -13,86 +13,103 @@ module Nix.Normal where import Control.Monad -import Data.Fix -import qualified Data.HashMap.Lazy as M -import Data.Text (Text) -import qualified Data.Text as Text -import Nix.Atoms -import Nix.Effects +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State +import Data.Set import Nix.Frames +import Nix.String import Nix.Thunk -import Nix.Utils import Nix.Value -newtype NormalLoop m = NormalLoop (NValue m) +newtype NormalLoop t f m = NormalLoop (NValue t f m) deriving Show -instance Typeable m => Exception (NormalLoop m) +instance MonadDataErrorContext t f m => Exception (NormalLoop t f m) -normalFormBy - :: forall e m. (Framed e m, MonadVar m, Typeable m) - => (forall r. NThunk m -> (NValue m -> m r) -> m r) - -> Int - -> NValue m - -> m (NValueNF m) -normalFormBy k n v = do - when (n > 2000) $ throwError $ NormalLoop v - case v of - NVConstant a -> return $ Fix $ NVConstantF a - NVStr t s -> return $ Fix $ NVStrF t s - NVList l -> - fmap (Fix . NVListF) $ forM (zip [0..] l) $ \(i :: Int, t) -> do - traceM $ replicate n ' ' ++ "normalFormBy: List[" ++ show i ++ "]" - t `k` normalFormBy k (succ n) - NVSet s p -> - fmap (Fix . flip NVSetF p) $ sequence $ flip M.mapWithKey s $ \ky t -> do - traceM $ replicate n ' ' ++ "normalFormBy: Set{" ++ show ky ++ "}" - t `k` normalFormBy k (succ n) - NVClosure p f -> return $ Fix $ NVClosureF p f - NVPath fp -> return $ Fix $ NVPathF fp - NVBuiltin name f -> return $ Fix $ NVBuiltinF name f - _ -> error "Pattern synonyms mask complete matches" +normalForm' + :: forall e t m f + . ( Framed e m + , MonadThunk t m (NValue t f m) + , MonadDataErrorContext t f m + , Ord (ThunkId m) + ) + => (forall r . t -> (NValue t f m -> m r) -> m r) + -> NValue t f m + -> m (NValueNF t f m) +normalForm' f = run . nValueToNFM run go + where + start = 0 :: Int + table = mempty -normalForm :: (Framed e m, MonadVar m, Typeable m, - MonadThunk (NValue m) (NThunk m) m) - => NValue m -> m (NValueNF m) -normalForm = normalFormBy force 0 + run :: ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r + run = (`evalStateT` table) . (`runReaderT` start) -embed :: forall m. (MonadThunk (NValue m) (NThunk m) m) - => NValueNF m -> m (NValue m) -embed (Fix x) = case x of - NVConstantF a -> return $ nvConstant a - NVStrF t s -> return $ nvStr t s - NVListF l -> nvList . fmap (value @_ @_ @m) - <$> traverse embed l - NVSetF s p -> flip nvSet p . fmap (value @_ @_ @m) - <$> traverse embed s - NVClosureF p f -> return $ nvClosure p f - NVPathF fp -> return $ nvPath fp - NVBuiltinF name f -> return $ nvBuiltin name f + go + :: t + -> ( NValue t f m + -> ReaderT Int (StateT (Set (ThunkId m)) m) (NValueNF t f m) + ) + -> ReaderT Int (StateT (Set (ThunkId m)) m) (NValueNF t f m) + go t k = do + b <- seen t + if b + then return $ pure t + else do + i <- ask + when (i > 2000) + $ error "Exceeded maximum normalization depth of 2000 levels" + s <- lift get + (res, s') <- lift $ lift $ f t $ \v -> + (`runStateT` s) . (`runReaderT` i) $ local succ $ k v + lift $ put s' + return res -valueText :: forall e m. (Framed e m, MonadEffects m, Typeable m) - => Bool -> NValueNF m -> m (Text, DList Text) -valueText addPathsToStore = cata phi - where - phi :: NValueF m (m (Text, DList Text)) -> m (Text, DList Text) - phi (NVConstantF a) = pure (atomText a, mempty) - phi (NVStrF t c) = pure (t, c) - phi v@(NVListF _) = coercionFailed v - phi v@(NVSetF s _) - | Just asString <- M.lookup "__asString" s = asString - | otherwise = coercionFailed v - phi v@NVClosureF {} = coercionFailed v - phi (NVPathF originalPath) - | addPathsToStore = do - storePath <- addPath originalPath - pure (Text.pack $ unStorePath storePath, mempty) - | otherwise = pure (Text.pack originalPath, mempty) - phi v@(NVBuiltinF _ _) = coercionFailed v + seen t = case thunkId t of + Just tid -> lift $ do + res <- gets (member tid) + unless res $ modify (insert tid) + return res + Nothing -> return False - coercionFailed v = - throwError $ Coercion @m (valueType v) TString +normalForm + :: ( Framed e m + , MonadThunk t m (NValue t f m) + , MonadDataErrorContext t f m + , Ord (ThunkId m) + ) + => NValue t f m + -> m (NValueNF t f m) +normalForm = normalForm' force -valueTextNoContext :: (Framed e m, MonadEffects m, Typeable m) - => Bool -> NValueNF m -> m Text -valueTextNoContext addPathsToStore = fmap fst . valueText addPathsToStore +normalForm_ + :: ( Framed e m + , MonadThunk t m (NValue t f m) + , MonadDataErrorContext t f m + , Ord (ThunkId m) + ) + => NValue t f m + -> m () +normalForm_ = void <$> normalForm' forceEff + +removeEffects + :: (MonadThunk t m (NValue t f m), MonadDataContext f m) + => NValue t f m + -> NValueNF t f m +removeEffects = nValueToNF (flip query opaque) + +removeEffectsM + :: (MonadThunk t m (NValue t f m), MonadDataContext f m) + => NValue t f m + -> m (NValueNF t f m) +removeEffectsM = nValueToNFM id (flip queryM (pure opaque)) + +opaque + :: (MonadThunk t m (NValue t f m), MonadDataContext f m) => NValueNF t f m +opaque = nvStrNF $ principledMakeNixStringWithoutContext "" + +dethunk + :: (MonadThunk t m (NValue t f m), MonadDataContext f m) + => t + -> m (NValueNF t f m) +dethunk t = queryM t (pure opaque) removeEffectsM diff --git a/src/Nix/Options.hs b/src/Nix/Options.hs --- a/src/Nix/Options.hs +++ b/src/Nix/Options.hs @@ -1,6 +1,6 @@ module Nix.Options where -import Data.Text (Text) +import Data.Text ( Text ) import Data.Time data Options = Options @@ -8,6 +8,7 @@ , tracing :: Bool , thunks :: Bool , values :: Bool + , scopes :: Bool , reduce :: Maybe FilePath , reduceSets :: Bool , reduceLists :: Bool @@ -36,36 +37,36 @@ deriving Show defaultOptions :: UTCTime -> Options -defaultOptions current = Options - { verbose = ErrorsOnly - , tracing = False - , thunks = False - , values = False - , reduce = Nothing - , reduceSets = False - , reduceLists = False - , parse = False - , parseOnly = False - , finder = False - , findFile = Nothing - , strict = False - , evaluate = False - , json = False - , xml = False - , attr = Nothing - , include = [] - , check = False - , readFrom = Nothing - , cache = False - , repl = False - , ignoreErrors = False - , expression = Nothing - , arg = [] - , argstr = [] - , fromFile = Nothing - , currentTime = current - , filePaths = [] - } +defaultOptions current = Options { verbose = ErrorsOnly + , tracing = False + , thunks = False + , values = False + , scopes = False + , reduce = Nothing + , reduceSets = False + , reduceLists = False + , parse = False + , parseOnly = False + , finder = False + , findFile = Nothing + , strict = False + , evaluate = False + , json = False + , xml = False + , attr = Nothing + , include = [] + , check = False + , readFrom = Nothing + , cache = False + , repl = False + , ignoreErrors = False + , expression = Nothing + , arg = [] + , argstr = [] + , fromFile = Nothing + , currentTime = current + , filePaths = [] + } data Verbosity = ErrorsOnly 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,14 +1,13 @@ module Nix.Options.Parser where -import Control.Arrow (second) -import Data.Char (isDigit) -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import qualified Data.Text as Text +import Control.Arrow ( second ) +import Data.Char ( isDigit ) +import Data.Maybe ( fromMaybe ) +import Data.Text ( Text ) +import qualified Data.Text as Text import Data.Time import Nix.Options -import Options.Applicative hiding (ParserResult(..)) -import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) +import Options.Applicative hiding ( ParserResult(..) ) decodeVerbosity :: Int -> Verbosity decodeVerbosity 0 = ErrorsOnly @@ -19,109 +18,149 @@ decodeVerbosity _ = Vomit argPair :: Mod OptionFields (Text, Text) -> Parser (Text, Text) -argPair = option $ str >>= \s -> - case Text.findIndex (== '=') s of - Nothing -> errorWithoutStackTrace - "Format of --arg/--argstr in hnix is: name=expr" - Just i -> return $ second Text.tail $ Text.splitAt i s +argPair = option $ str >>= \s -> case Text.findIndex (== '=') s of + Nothing -> + errorWithoutStackTrace "Format of --arg/--argstr in hnix is: name=expr" + Just i -> return $ second Text.tail $ Text.splitAt i s nixOptions :: UTCTime -> Parser Options -nixOptions current = Options - <$> (fromMaybe ErrorsOnly <$> - optional - (option (do a <- str - if all isDigit a - then pure $ decodeVerbosity (read a) - else fail "Argument to -v/--verbose must be a number") - ( short 'v' - <> long "verbose" - <> help "Verbose output"))) - <*> switch - ( long "trace" - <> help "Enable tracing code (even more can be seen if built with --flags=tracing)") +nixOptions current = + Options + <$> (fromMaybe Informational <$> optional + (option + (do + a <- str + if all isDigit a + then pure $ decodeVerbosity (read a) + else fail "Argument to -v/--verbose must be a number" + ) + (short 'v' <> long "verbose" <> help "Verbose output") + ) + ) <*> switch - ( long "thunks" - <> help "Enable reporting of thunk tracing as well as regular evaluation") + ( long "trace" + <> help + "Enable tracing code (even more can be seen if built with --flags=tracing)" + ) <*> switch - ( long "values" - <> help "Enable reporting of value provenance in error messages") - <*> optional (strOption - ( long "reduce" - <> help "When done evaluating, output the evaluated part of the expression to FILE")) + (long "thunks" <> help + "Enable reporting of thunk tracing as well as regular evaluation" + ) <*> switch - ( long "reduce-sets" - <> help "Reduce set members that aren't used; breaks if hasAttr is used") + ( long "values" + <> help "Enable reporting of value provenance in error messages" + ) <*> switch - ( long "reduce-lists" - <> help "Reduce list members that aren't used; breaks if elemAt is used") + ( long "scopes" + <> help "Enable reporting of scopes in evaluation traces" + ) + <*> optional + (strOption + ( long "reduce" + <> help + "When done evaluating, output the evaluated part of the expression to FILE" + ) + ) <*> switch - ( long "parse" - <> help "Whether to parse the file (also the default right now)") + (long "reduce-sets" <> help + "Reduce set members that aren't used; breaks if hasAttr is used" + ) <*> switch - ( long "parse-only" - <> help "Whether to parse only, no pretty printing or checking") + (long "reduce-lists" <> help + "Reduce list members that aren't used; breaks if elemAt is used" + ) <*> switch - ( long "find" - <> help "If selected, find paths within attr trees") - <*> optional (strOption - ( long "find-file" - <> help "Look up the given files in Nix's search path")) + ( long "parse" + <> help "Whether to parse the file (also the default right now)" + ) <*> switch - ( long "strict" - <> help "When used with --eval, recursively evaluate list elements and attributes") + ( long "parse-only" + <> help "Whether to parse only, no pretty printing or checking" + ) + <*> switch (long "find" <> help "If selected, find paths within attr trees") + <*> optional + (strOption + ( long "find-file" + <> help "Look up the given files in Nix's search path" + ) + ) <*> switch - ( long "eval" - <> help "Whether to evaluate, or just pretty-print") + ( long "strict" + <> help + "When used with --eval, recursively evaluate list elements and attributes" + ) + <*> switch (long "eval" <> help "Whether to evaluate, or just pretty-print") <*> switch - ( long "json" - <> help "Print the resulting value as an JSON representation") + ( long "json" + <> help "Print the resulting value as an JSON representation" + ) <*> switch - ( long "xml" - <> help "Print the resulting value as an XML representation") - <*> optional (strOption - ( short 'A' - <> long "attr" - <> help "Select an attribute from the top-level Nix expression being evaluated")) - <*> many (strOption - ( short 'I' - <> long "include" - <> help "Add a path to the Nix expression search path")) + ( long "xml" + <> help "Print the resulting value as an XML representation" + ) + <*> optional + (strOption + ( short 'A' + <> long "attr" + <> help + "Select an attribute from the top-level Nix expression being evaluated" + ) + ) + <*> many + (strOption + (short 'I' <> long "include" <> help + "Add a path to the Nix expression search path" + ) + ) <*> switch - ( long "check" - <> help "Whether to check for syntax errors after parsing") - <*> optional (strOption - ( long "read" - <> help "Read in an expression tree from a binary cache")) + ( long "check" + <> help "Whether to check for syntax errors after parsing" + ) + <*> optional + (strOption + ( long "read" + <> help "Read in an expression tree from a binary cache" + ) + ) <*> switch - ( long "cache" - <> help "Write out the parsed expression tree to a binary cache") + ( long "cache" + <> help "Write out the parsed expression tree to a binary cache" + ) <*> switch - ( long "repl" - <> help "After performing any indicated actions, enter the REPL") + ( long "repl" + <> help "After performing any indicated actions, enter the REPL" + ) <*> switch - ( long "ignore-errors" - <> help "Continue parsing files, even if there are errors") - <*> optional (strOption - ( short 'E' - <> long "expr" - <> help "Expression to parse or evaluate")) - <*> many (argPair - ( long "arg" - <> help "Argument to pass to an evaluated lambda")) - <*> many (argPair - ( long "argstr" - <> help "Argument string to pass to an evaluated lambda")) - <*> optional (strOption - ( short 'f' - <> long "file" - <> help "Parse all of the files given in FILE; - means stdin")) - <*> option (parseTimeOrError True defaultTimeLocale "%Y/%m/%d %H:%M:%S" <$> str) - ( long "now" - <> value current - <> help "Set current time for testing purposes") + ( long "ignore-errors" + <> help "Continue parsing files, even if there are errors" + ) + <*> optional + (strOption + (short 'E' <> long "expr" <> help "Expression to parse or evaluate") + ) + <*> many + (argPair + (long "arg" <> help "Argument to pass to an evaluated lambda") + ) + <*> many + (argPair + ( long "argstr" + <> help "Argument string to pass to an evaluated lambda" + ) + ) + <*> optional + (strOption + (short 'f' <> long "file" <> help + "Parse all of the files given in FILE; - means stdin" + ) + ) + <*> option + (parseTimeOrError True defaultTimeLocale "%Y/%m/%d %H:%M:%S" <$> str) + (long "now" <> value current <> help + "Set current time for testing purposes" + ) <*> many (strArgument (metavar "FILE" <> help "Path of file to parse")) nixOptionsInfo :: UTCTime -> ParserInfo Options -nixOptionsInfo current = - info (helper <*> nixOptions current) - (fullDesc <> progDesc "" <> header "hnix") +nixOptionsInfo current = info (helper <*> nixOptions current) + (fullDesc <> progDesc "" <> 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,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -9,50 +10,82 @@ {-# OPTIONS_GHC -Wno-missing-signatures #-} module Nix.Parser - ( parseNixFile - , parseNixFileLoc - , parseNixText - , parseNixTextLoc - , parseFromFileEx - , parseFromText - , Result(..) - , reservedNames - , OperatorInfo(..) - , NSpecialOp(..) - , NAssoc(..) - , NOperatorDef - , getUnaryOperator - , getBinaryOperator - , getSpecialOperator - ) where + ( 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 Control.Applicative hiding (many, some) +import Prelude hiding ( readFile ) + +import Control.Applicative hiding ( many + , some + ) import Control.DeepSeq import Control.Monad -import Control.Monad.IO.Class -import Data.Char (isAlpha, isDigit, isSpace) -import Data.Data (Data(..)) -import Data.Foldable (concat) +import Control.Monad.Combinators.Expr +import Data.Char ( isAlpha + , isDigit + , isSpace + ) +import Data.Data ( Data(..) ) +import Data.Foldable ( concat ) import Data.Functor import Data.Functor.Identity -import Data.HashSet (HashSet) -import qualified Data.HashSet as HashSet -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map as Map -import Data.Text (Text) -import Data.Text hiding (map, foldr1, concat, concatMap, zipWith) -import qualified Data.Text.IO as T -import Data.Typeable (Typeable) +import Data.HashSet ( HashSet ) +import qualified Data.HashSet as HashSet +import Data.List.NonEmpty ( NonEmpty(..) ) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as Map +import Data.Text ( Text ) +import Data.Text hiding ( map + , foldr1 + , concat + , concatMap + , zipWith + ) +import Data.Text.Prettyprint.Doc ( Doc + , pretty + ) +import Data.Text.Encoding +import Data.Typeable ( Typeable ) import Data.Void -import GHC.Generics hiding (Prefix) -import Nix.Expr hiding (($>)) +import GHC.Generics hiding ( Prefix ) +import Nix.Expr hiding ( ($>) ) +import Nix.Render import Nix.Strings import Text.Megaparsec import Text.Megaparsec.Char -import qualified Text.Megaparsec.Char.Lexer as L -import Text.Megaparsec.Expr -import Text.PrettyPrint.ANSI.Leijen (Doc, text) +import qualified Text.Megaparsec.Char.Lexer as L infixl 3 <+> (<+>) :: MonadPlus m => m a -> m a -> m a @@ -60,16 +93,18 @@ -------------------------------------------------------------------------------- -nixExprLoc :: Parser NExprLoc -nixExprLoc = makeExprParser nixTerm $ map (map snd) (nixOperators nixSelector) +nixExpr :: Parser NExprLoc +nixExpr = makeExprParser nixTerm $ map (map snd) (nixOperators nixSelector) antiStart :: Parser Text antiStart = symbol "${" show ("${" :: String) nixAntiquoted :: Parser a -> Parser (Antiquoted a NExprLoc) nixAntiquoted p = - Antiquoted <$> (antiStart *> nixToplevelForm <* symbol "}") - <+> Plain <$> p + Antiquoted + <$> (antiStart *> nixToplevelForm <* symbol "}") + <+> Plain + <$> p "anti-quotation" selDot :: Parser () @@ -77,74 +112,87 @@ nixSelect :: Parser NExprLoc -> Parser NExprLoc nixSelect term = do - res <- build - <$> term - <*> optional ((,) <$> (selDot *> nixSelector) - <*> optional (reserved "or" *> nixTerm)) - continues <- optional $ lookAhead selDot - case continues of - Nothing -> pure res - Just _ -> nixSelect (pure res) + res <- build <$> term <*> optional + ((,) <$> (selDot *> nixSelector) <*> optional (reserved "or" *> nixTerm)) + continues <- optional $ lookAhead selDot + case continues of + Nothing -> pure res + Just _ -> nixSelect (pure res) where - build :: NExprLoc - -> Maybe (Ann SrcSpan (NAttrPath NExprLoc), Maybe NExprLoc) - -> NExprLoc - build t Nothing = t - build t (Just (s,o)) = nSelectLoc t s o + build + :: NExprLoc + -> Maybe (Ann SrcSpan (NAttrPath NExprLoc), Maybe NExprLoc) + -> NExprLoc + build t Nothing = t + build t (Just (s, o)) = nSelectLoc t s o nixSelector :: Parser (Ann SrcSpan (NAttrPath NExprLoc)) nixSelector = annotateLocation $ do - (x:xs) <- keyName `sepBy1` selDot - return $ x :| xs + (x : xs) <- keyName `sepBy1` selDot + return $ x :| xs nixTerm :: Parser NExprLoc nixTerm = do - c <- try $ lookAhead $ satisfy $ \x -> - pathChar x || - x == '(' || - x == '{' || - x == '[' || - x == '<' || - x == '/' || - x == '"' || - x == '\'' - case c of - '(' -> nixSelect nixParens - '{' -> nixSelect nixSet - '[' -> nixList - '<' -> nixSPath - '/' -> nixPath - '"' -> nixStringExpr - '\'' -> nixStringExpr - _ -> 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 ] + c <- try $ lookAhead $ satisfy $ \x -> + pathChar x + || x + == '(' + || x + == '{' + || x + == '[' + || x + == '<' + || x + == '/' + || x + == '"' + || x + == '\'' + || x + == '^' + case c of + '(' -> 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 <+> nixExprLoc - where - keywords = nixLet <+> nixIf <+> nixAssert <+> nixWith +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") +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 +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") @@ -156,115 +204,147 @@ nixList = annotateLocation1 (brackets (NList <$> many nixTerm) "list") pathChar :: Char -> Bool -pathChar x = isAlpha x || isDigit x || x == '.' || x == '_' || x == '-' || x == '+' || x == '~' +pathChar x = + isAlpha x + || isDigit x + || x + == '.' + || x + == '_' + || x + == '-' + || x + == '+' + || x + == '~' slash :: Parser Char -slash = try (char '/' <* notFollowedBy (satisfy (\x -> x == '/' || x == '*' || isSpace x))) +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. -nixSPath :: Parser NExprLoc -nixSPath = annotateLocation1 - (mkPathF True <$> try (char '<' *> many (satisfy pathChar <+> slash) <* symbol ">") - "spath") +nixSearchPath :: Parser NExprLoc +nixSearchPath = annotateLocation1 + ( mkPathF True + <$> try (char '<' *> many (satisfy pathChar <+> slash) <* symbol ">") + "spath" + ) pathStr :: Parser FilePath -pathStr = lexeme $ liftM2 (++) (many (satisfy pathChar)) - (Prelude.concat <$> some (liftM2 (:) slash (some (satisfy pathChar)))) +pathStr = lexeme $ liftM2 + (++) + (many (satisfy pathChar)) + (Prelude.concat <$> some (liftM2 (:) 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 = NLet - <$> nixBinders - <*> (reserved "in" *> nixToplevelForm) - -- Let expressions `let {..., body = ...}' are just desugared - -- into `(rec {..., body = ...}).body'. - letBody = (\x -> NSelect x (StaticKey "body" :| []) Nothing) <$> aset - aset = annotateLocation1 $ NRecSet <$> braces nixBinders +nixLet = annotateLocation1 + (reserved "let" *> (letBody <+> letBinders) "let block") + where + letBinders = NLet <$> nixBinders <*> (reserved "in" *> nixToplevelForm) + -- Let expressions `let {..., body = ...}' are just desugared + -- into `(rec {..., body = ...}).body'. + letBody = (\x -> NSelect x (StaticKey "body" :| []) Nothing) <$> aset + aset = annotateLocation1 $ NRecSet <$> braces nixBinders nixIf :: Parser NExprLoc -nixIf = annotateLocation1 (NIf - <$> (reserved "if" *> nixExprLoc) - <*> (reserved "then" *> nixToplevelForm) - <*> (reserved "else" *> nixToplevelForm) - "if") +nixIf = annotateLocation1 + ( NIf + <$> (reserved "if" *> nixExpr) + <*> (reserved "then" *> nixToplevelForm) + <*> (reserved "else" *> nixToplevelForm) + "if" + ) nixAssert :: Parser NExprLoc -nixAssert = annotateLocation1 (NAssert - <$> (reserved "assert" *> nixExprLoc) +nixAssert = annotateLocation1 + ( NAssert + <$> (reserved "assert" *> nixExpr) <*> (semi *> nixToplevelForm) - "assert") + "assert" + ) nixWith :: Parser NExprLoc -nixWith = annotateLocation1 (NWith +nixWith = annotateLocation1 + ( NWith <$> (reserved "with" *> nixToplevelForm) <*> (semi *> nixToplevelForm) - "with") + "with" + ) nixLambda :: Parser NExprLoc nixLambda = nAbs <$> annotateLocation (try argExpr) <*> nixToplevelForm -nixStringExpr :: Parser NExprLoc -nixStringExpr = nStr <$> annotateLocation nixString +nixString :: Parser NExprLoc +nixString = nStr <$> annotateLocation nixString' nixUri :: Parser NExprLoc nixUri = annotateLocation1 $ lexeme $ try $ do - start <- letterChar - protocol <- many $ satisfy $ \x -> - isAlpha x || isDigit x || x `elem` ("+-." :: String) - _ <- string ":" - address <- some $ satisfy $ \x -> - isAlpha x || isDigit x || x `elem` ("%/?:@&=+$,-_.!~*'" :: String) - return $ NStr $ - DoubleQuoted [Plain $ pack $ start : protocol ++ ':' : address] + start <- letterChar + protocol <- many $ satisfy $ \x -> + isAlpha x || isDigit x || x `elem` ("+-." :: String) + _ <- string ":" + address <- some $ satisfy $ \x -> + isAlpha x || isDigit x || x `elem` ("%/?:@&=+$,-_.!~*'" :: String) + return $ NStr $ DoubleQuoted + [Plain $ pack $ 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" +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 . singleton <$> (char '\\' *> escapeCode) + doubleQ = void (char '"') + doubleEscape = Plain . singleton <$> (char '\\' *> escapeCode) - indented :: Parser (NString NExprLoc) - indented = stripIndent - <$> (indentedQ *> many (stringChar indentedQ indentedQ - indentedEscape) - <* indentedQ) - "indented string" + 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 $ if c == '\n' - then EscapedNewline - else Plain $ singleton c + indentedQ = void (string "''" "\"''\"") + indentedEscape = try $ do + indentedQ + (Plain <$> ("''" <$ char '\'' <+> "$" <$ char '$')) <+> do + _ <- char '\\' + c <- escapeCode + pure $ if c == '\n' then EscapedNewline else Plain $ singleton c - stringChar end escStart esc = - Antiquoted <$> (antiStart *> nixToplevelForm <* char '}') - <+> Plain . singleton <$> char '$' - <+> esc - <+> Plain . pack <$> some plainChar - where - plainChar = - notFollowedBy (end <+> void (char '$') <+> escStart) *> anyChar + stringChar end escStart esc = + Antiquoted + <$> (antiStart *> nixToplevelForm <* char '}') + <+> Plain + . singleton + <$> char '$' + <+> esc + <+> Plain + . pack + <$> some plainChar + where + plainChar = + notFollowedBy (end <+> void (char '$') <+> escStart) *> anySingle - escapeCode = msum [ c <$ char e | (c,e) <- escapeCodes ] <+> anyChar + escapeCode = msum [ c <$ char e | (c, e) <- escapeCodes ] <+> anySingle -- | Gets all of the arguments for a function. argExpr :: Parser (Params NExprLoc) @@ -273,19 +353,22 @@ -- 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' NE.:| "alid uri")), - Param <$> identifier] + onlyname = + msum + [ nixUri >> unexpected (Label ('v' NE.:| "alid uri")) + , Param <$> identifier + ] -- Parameters named by an identifier on the left (`args @ {x, y}`) atLeft = try $ do - name <- identifier <* symbol "@" + name <- identifier <* symbol "@" (variadic, params) <- params return $ ParamSet params variadic (Just name) -- Parameters named by an identifier on the right, or none (`{x, y} @ args`) atRight = do (variadic, params) <- params - name <- optional $ symbol "@" *> identifier + name <- optional $ symbol "@" *> identifier return $ ParamSet params variadic name -- Return the parameters set. @@ -296,7 +379,7 @@ -- 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 [] where + getParams = go [] 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 @@ -304,49 +387,49 @@ go acc = ((acc, True) <$ symbol "...") <+> getMore acc getMore acc = -- Could be nothing, in which just return what we have so far. - option (acc, False) $ do + option (acc, False) $ do -- Get an argument name and an optional default. - pair <- liftM2 (,) identifier (optional $ question *> nixToplevelForm) - -- Either return this, or attempt to get a comma and restart. - option (acc ++ [pair], False) $ comma >> go (acc ++ [pair]) + pair <- liftM2 (,) identifier (optional $ question *> nixToplevelForm) + -- Either return this, or attempt to get a comma and restart. + option (acc ++ [pair], False) $ comma >> go (acc ++ [pair]) 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 <- getPosition - x <- whiteSpace *> optional scope - Inherit x <$> many keyName <*> pure p "inherited binding" + try $ string "inherit" *> lookAhead (void (satisfy reservedEnd)) + p <- getSourcePos + x <- whiteSpace *> optional scope + Inherit x <$> many keyName <*> pure p "inherited binding" namedVar = do - p <- getPosition - NamedVar <$> (annotated <$> nixSelector) - <*> (equals *> nixToplevelForm) - <*> pure p - "variable binding" + p <- getSourcePos + NamedVar + <$> (annotated <$> nixSelector) + <*> (equals *> nixToplevelForm) + <*> pure p + "variable binding" scope = parens nixToplevelForm "inherit scope" keyName :: Parser (NKeyName NExprLoc) keyName = dynamicKey <+> staticKey where - staticKey = StaticKey <$> identifier - dynamicKey = DynamicKey <$> nixAntiquoted nixString + staticKey = StaticKey <$> identifier + dynamicKey = DynamicKey <$> nixAntiquoted nixString' nixSet :: Parser NExprLoc -nixSet = annotateLocation1 ((isRec <*> braces nixBinders) "set") where - isRec = (reserved "rec" $> NRecSet "recursive set") - <+> pure NSet +nixSet = annotateLocation1 ((isRec <*> braces nixBinders) "set") + where isRec = (reserved "rec" $> NRecSet "recursive set") <+> pure NSet -parseNixFile :: MonadIO m => FilePath -> m (Result NExpr) +parseNixFile :: MonadFile m => FilePath -> m (Result NExpr) parseNixFile = - parseFromFileEx $ stripAnnotation <$> (whiteSpace *> nixToplevelForm <* eof) + parseFromFileEx $ stripAnnotation <$> (whiteSpace *> nixToplevelForm <* eof) -parseNixFileLoc :: MonadIO m => FilePath -> m (Result NExprLoc) +parseNixFileLoc :: MonadFile m => FilePath -> m (Result NExprLoc) parseNixFileLoc = parseFromFileEx (whiteSpace *> nixToplevelForm <* eof) parseNixText :: Text -> Result NExpr parseNixText = - parseFromText $ stripAnnotation <$> (whiteSpace *> nixToplevelForm <* eof) + parseFromText $ stripAnnotation <$> (whiteSpace *> nixToplevelForm <* eof) parseNixTextLoc :: Text -> Result NExprLoc parseNixTextLoc = parseFromText (whiteSpace *> nixToplevelForm <* eof) @@ -354,15 +437,14 @@ {- Parser.Library -} skipLineComment' :: Tokens Text -> Parser () -skipLineComment' prefix = - string prefix - *> void (takeWhileP (Just "character") (\x -> x /= '\n' && x /= '\r')) +skipLineComment' prefix = string prefix + *> void (takeWhileP (Just "character") (\x -> x /= '\n' && x /= '\r')) whiteSpace :: Parser () whiteSpace = L.space space1 lineCmnt blockCmnt - where - lineCmnt = skipLineComment' "#" - blockCmnt = L.skipBlockComment "/*" "*/" + where + lineCmnt = skipLineComment' "#" + blockCmnt = L.skipBlockComment "/*" "*/" lexeme :: Parser a -> Parser a lexeme p = p <* whiteSpace @@ -371,34 +453,57 @@ symbol = lexeme . string reservedEnd :: Char -> Bool -reservedEnd x = isSpace x || - x == '{' || x == '(' || x == '[' || - x == '}' || x == ')' || x == ']' || - x == ';' || x == ':' || x == '.' || - x == '"' || x == '\'' || x == ',' +reservedEnd x = + isSpace x + || x + == '{' + || x + == '(' + || x + == '[' + || x + == '}' + || x + == ')' + || x + == ']' + || x + == ';' + || x + == ':' + || x + == '.' + || x + == '"' + || x + == '\'' + || x + == ',' reserved :: Text -> Parser () -reserved n = lexeme $ try $ - string n *> lookAhead (void (satisfy reservedEnd) <|> eof) +reserved n = + lexeme $ try $ string n *> lookAhead (void (satisfy reservedEnd) <|> eof) identifier = lexeme $ try $ do - ident <- cons <$> satisfy (\x -> isAlpha x || x == '_') - <*> takeWhileP Nothing identLetter - guard (not (ident `HashSet.member` reservedNames)) - return ident - where - identLetter x = isAlpha x || isDigit x || x == '_' || x == '\'' || x == '-' + ident <- + cons + <$> satisfy (\x -> isAlpha x || x == '_') + <*> takeWhileP Nothing identLetter + guard (not (ident `HashSet.member` reservedNames)) + return ident + where + identLetter x = isAlpha x || isDigit x || x == '_' || x == '\'' || x == '-' -parens = between (symbol "(") (symbol ")") -braces = between (symbol "{") (symbol "}") +parens = between (symbol "(") (symbol ")") +braces = between (symbol "{") (symbol "}") -- angles = between (symbol "<") (symbol ">") -brackets = between (symbol "[") (symbol "]") -semi = symbol ";" -comma = symbol "," +brackets = between (symbol "[") (symbol "]") +semi = symbol ";" +comma = symbol "," -- colon = symbol ":" -- dot = symbol "." -equals = symbol "=" -question = symbol "?" +equals = symbol "=" +question = symbol "?" integer :: Parser Integer integer = lexeme L.decimal @@ -408,28 +513,22 @@ reservedNames :: HashSet Text reservedNames = HashSet.fromList - [ "let", "in" - , "if", "then", "else" - , "assert" - , "with" - , "rec" - , "inherit" - , "true", "false" ] + ["let", "in", "if", "then", "else", "assert", "with", "rec", "inherit"] type Parser = ParsecT Void Text Identity -data Result a = Success a | Failure Doc deriving Show +data Result a = Success a | Failure (Doc Void) deriving (Show, Functor) -parseFromFileEx :: MonadIO m => Parser a -> FilePath -> m (Result a) +parseFromFileEx :: MonadFile m => Parser a -> FilePath -> m (Result a) parseFromFileEx p path = do - txt <- liftIO (T.readFile path) - return $ either (Failure . text . parseErrorPretty' txt) Success - $ parse p path txt + txt <- decodeUtf8 <$> readFile path + return $ either (Failure . pretty . errorBundlePretty) Success $ parse p + path + txt parseFromText :: Parser a -> Text -> Result a parseFromText p txt = - either (Failure . text . parseErrorPretty' txt) Success $ - parse p "" txt + either (Failure . pretty . errorBundlePretty) Success $ parse p "" txt {- Parser.Operators -} @@ -447,9 +546,9 @@ annotateLocation :: Parser a -> Parser (Ann SrcSpan a) annotateLocation p = do - begin <- getPosition + begin <- getSourcePos res <- p - end <- getPosition + end <- getSourcePos pure $ Ann (SrcSpan begin end) res annotateLocation1 :: Parser (NExprF NExprLoc) -> Parser NExprLoc @@ -465,23 +564,24 @@ opWithLoc :: Text -> o -> (Ann SrcSpan o -> a) -> Parser a opWithLoc name op f = do - Ann ann _ <- annotateLocation $ {- dbg (unpack name) $ -} operator name - return $ f (Ann ann op) + Ann ann _ <- annotateLocation $ {- dbg (unpack name) $ -} + operator name + return $ f (Ann ann op) -binaryN name op = (NBinaryDef name op NAssocNone, - InfixN (opWithLoc name op nBinary)) -binaryL name op = (NBinaryDef name op NAssocLeft, - InfixL (opWithLoc name op nBinary)) -binaryR name op = (NBinaryDef name op NAssocRight, - InfixR (opWithLoc name op nBinary)) -prefix name op = (NUnaryDef name op, - Prefix (manyUnaryOp (opWithLoc name op nUnary))) +binaryN name op = + (NBinaryDef name op NAssocNone, InfixN (opWithLoc name op nBinary)) +binaryL name op = + (NBinaryDef name op NAssocLeft, InfixL (opWithLoc name op nBinary)) +binaryR name op = + (NBinaryDef name op NAssocRight, InfixR (opWithLoc name op nBinary)) +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)]] + :: 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 @@ -495,28 +595,40 @@ -- mor <- optional (reserved "or" *> term) -- return $ \x -> nSelectLoc x sel mor) ] - {- 2 -} [ (NBinaryDef " " NApp NAssocLeft, + {- 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 -} [ binaryN "->" NImpl ] + 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 -} + [binaryN "->" NImpl] ] data OperatorInfo = OperatorInfo @@ -527,25 +639,36 @@ getUnaryOperator :: NUnaryOp -> OperatorInfo getUnaryOperator = (m Map.!) where - m = Map.fromList $ concat $ zipWith buildEntry [1..] - (nixOperators (error "unused")) + m = Map.fromList $ concat $ zipWith buildEntry + [1 ..] + (nixOperators (error "unused")) buildEntry i = concatMap $ \case (NUnaryDef name op, _) -> [(op, OperatorInfo i NAssocNone name)] - _ -> [] + _ -> [] getBinaryOperator :: NBinaryOp -> OperatorInfo getBinaryOperator = (m Map.!) where - m = Map.fromList $ concat $ zipWith buildEntry [1..] - (nixOperators (error "unused")) + m = Map.fromList $ concat $ zipWith buildEntry + [1 ..] + (nixOperators (error "unused")) buildEntry i = concatMap $ \case (NBinaryDef name op assoc, _) -> [(op, OperatorInfo i assoc name)] - _ -> [] + _ -> [] getSpecialOperator :: NSpecialOp -> OperatorInfo getSpecialOperator NSelectOp = OperatorInfo 1 NAssocLeft "." -getSpecialOperator o = m Map.! o where - m = Map.fromList $ concat $ zipWith buildEntry [1..] - (nixOperators (error "unused")) +getSpecialOperator o = m Map.! o where + m = Map.fromList $ concat $ zipWith buildEntry + [1 ..] + (nixOperators (error "unused")) buildEntry i = concatMap $ \case (NSpecialDef name op assoc, _) -> [(op, OperatorInfo i assoc name)] - _ -> [] + _ -> [] + + + + + + + + diff --git a/src/Nix/Pretty.hs b/src/Nix/Pretty.hs --- a/src/Nix/Pretty.hs +++ b/src/Nix/Pretty.hs @@ -1,9 +1,13 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ViewPatterns #-} @@ -12,36 +16,49 @@ module Nix.Pretty where -import Control.Monad +import Control.Applicative ( (<|>) ) +import Control.Comonad import Data.Fix -import Data.HashMap.Lazy (toList) -import qualified Data.HashMap.Lazy as M -import qualified Data.HashSet as HashSet -import Data.List (isPrefixOf, sort) -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NE -import Data.Maybe (isJust, fromMaybe) -import Data.Text (pack, unpack, replace, strip) -import qualified Data.Text as Text +import Data.HashMap.Lazy ( toList ) +import qualified Data.HashMap.Lazy as M +import qualified Data.HashSet as HashSet +import Data.List ( isPrefixOf + , sort + ) +import Data.List.NonEmpty ( NonEmpty(..) ) +import qualified Data.List.NonEmpty as NE +import Data.Maybe ( isJust + , fromMaybe + ) +import Data.Text ( pack + , unpack + , replace + , strip + ) +import qualified Data.Text as Text +import Data.Text.Prettyprint.Doc import Nix.Atoms +import Nix.Cited import Nix.Expr +import Nix.Normal import Nix.Parser +import Nix.String import Nix.Strings import Nix.Thunk #if ENABLE_TRACING import Nix.Utils #else -import Nix.Utils hiding ((<$>)) +import Nix.Utils hiding ( (<$>) ) #endif import Nix.Value -import Prelude hiding ((<$>)) -import Text.PrettyPrint.ANSI.Leijen +import Prelude hiding ( (<$>) ) +import Text.Read ( readMaybe ) -- | This type represents a pretty printed nix expression -- together with some information about the expression. -data NixDoc = NixDoc +data NixDoc ann = NixDoc { -- | The rendered expression, without any parentheses. - withoutParens :: Doc + withoutParens :: 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 @@ -52,16 +69,16 @@ -- we can add brackets appropiately } -mkNixDoc :: Doc -> OperatorInfo -> NixDoc +mkNixDoc :: Doc ann -> OperatorInfo -> NixDoc ann mkNixDoc d o = NixDoc { withoutParens = 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 -> NixDoc +simpleExpr :: Doc ann -> NixDoc ann simpleExpr d = mkNixDoc d (OperatorInfo minBound NAssocNone "simple expr") -pathExpr :: Doc -> NixDoc +pathExpr :: Doc ann -> NixDoc ann pathExpr d = (simpleExpr d) { wasPath = True } -- | An expression that behaves as if its root operator had a precedence lower @@ -69,9 +86,9 @@ -- parantheses in almost always, but it's still rendered without parentheses -- in cases where parentheses are never required (such as in the LHS of a -- binding). -leastPrecedence :: Doc -> NixDoc +leastPrecedence :: Doc ann -> NixDoc ann leastPrecedence = - flip mkNixDoc $ OperatorInfo maxBound NAssocNone "least precedence" + flip mkNixDoc $ OperatorInfo maxBound NAssocNone "least precedence" appOp :: OperatorInfo appOp = getBinaryOperator NApp @@ -85,221 +102,322 @@ hasAttrOp :: OperatorInfo hasAttrOp = getSpecialOperator NHasAttrOp -wrapParens :: OperatorInfo -> NixDoc -> Doc +wrapParens :: OperatorInfo -> NixDoc ann -> Doc ann wrapParens op sub - | precedence (rootOp sub) < precedence op = withoutParens sub - | precedence (rootOp sub) == precedence op - && associativity (rootOp sub) == associativity op - && associativity op /= NAssocNone = withoutParens sub - | otherwise = parens $ withoutParens sub + | precedence (rootOp sub) < precedence op + = withoutParens sub + | precedence (rootOp sub) + == precedence op + && associativity (rootOp sub) + == associativity op + && associativity op + /= NAssocNone + = withoutParens sub + | otherwise + = parens $ withoutParens sub -- Used in the selector case to print a path in a selector as -- "${./abc}" -wrapPath :: OperatorInfo -> NixDoc -> Doc -wrapPath op sub = - if wasPath sub then dquotes (text "$" <> braces (withoutParens sub)) - else wrapParens op sub +wrapPath :: OperatorInfo -> NixDoc ann -> Doc ann +wrapPath op sub = if wasPath sub + then dquotes $ "$" <> braces (withoutParens sub) + else wrapParens op sub -prettyString :: NString NixDoc -> Doc +prettyString :: NString (NixDoc ann) -> Doc ann prettyString (DoubleQuoted parts) = dquotes . hcat . map prettyPart $ parts - where prettyPart (Plain t) = text . concatMap escape . unpack $ t - prettyPart EscapedNewline = text "''\\n" - prettyPart (Antiquoted r) = text "$" <> braces (withoutParens r) - escape '"' = "\\\"" - escape x = maybe [x] (('\\':) . (:[])) $ toEscapeCode x -prettyString (Indented _ parts) - = group $ nest 2 (squote <> squote <$$> content) <$$> squote <> squote where + prettyPart (Plain t) = pretty . concatMap escape . unpack $ t + prettyPart EscapedNewline = "''\\n" + prettyPart (Antiquoted r) = "$" <> braces (withoutParens r) + escape '"' = "\\\"" + escape x = maybe [x] (('\\' :) . (: [])) $ toEscapeCode x +prettyString (Indented _ parts) = group $ nest 2 $ vcat + [dsquote, content, dsquote] + where + dsquote = squote <> squote content = vsep . map prettyLine . stripLastIfEmpty . splitLines $ parts - stripLastIfEmpty = reverse . f . reverse where + stripLastIfEmpty = reverse . f . reverse where f ([Plain t] : xs) | Text.null (strip t) = xs f xs = xs prettyLine = hcat . map prettyPart - prettyPart (Plain t) = text . unpack . replace "${" "''${" . replace "''" "'''" $ t - prettyPart EscapedNewline = text "\\n" - prettyPart (Antiquoted r) = text "$" <> braces (withoutParens r) + prettyPart (Plain t) = + pretty . unpack . replace "${" "''${" . replace "''" "'''" $ t + prettyPart EscapedNewline = "\\n" + prettyPart (Antiquoted r) = "$" <> braces (withoutParens r) -prettyParams :: Params NixDoc -> Doc -prettyParams (Param n) = text $ unpack n +prettyParams :: Params (NixDoc ann) -> Doc ann +prettyParams (Param n ) = pretty $ unpack n prettyParams (ParamSet s v mname) = prettyParamSet s v <> case mname of - Nothing -> empty - Just name | Text.null name -> empty - | otherwise -> text "@" <> text (unpack name) + Nothing -> mempty + Just name | Text.null name -> mempty + | otherwise -> "@" <> pretty (unpack name) -prettyParamSet :: ParamSet NixDoc -> Bool -> Doc -prettyParamSet args var = - encloseSep (lbrace <> space) (align (space <> rbrace)) sep (map prettySetArg args ++ prettyVariadic) - where - prettySetArg (n, maybeDef) = case maybeDef of - Nothing -> text (unpack n) - Just v -> text (unpack n) <+> text "?" <+> withoutParens v - prettyVariadic = [text "..." | var] - sep = align (comma <> space) +prettyParamSet :: ParamSet (NixDoc ann) -> Bool -> Doc ann +prettyParamSet args var = encloseSep + (lbrace <> space) + (align (space <> rbrace)) + sep + (map prettySetArg args ++ prettyVariadic) + where + prettySetArg (n, maybeDef) = case maybeDef of + Nothing -> pretty (unpack n) + Just v -> pretty (unpack n) <+> "?" <+> withoutParens v + prettyVariadic = [ "..." | var ] + sep = align (comma <> space) -prettyBind :: Binding NixDoc -> Doc +prettyBind :: Binding (NixDoc ann) -> Doc ann prettyBind (NamedVar n v _p) = - prettySelector n <+> equals <+> withoutParens v <> semi -prettyBind (Inherit s ns _p) - = text "inherit" <+> scope <> align (fillSep (map prettyKeyName ns)) <> semi - where scope = maybe empty ((<> space) . parens . withoutParens) s + prettySelector n <+> equals <+> withoutParens v <> semi +prettyBind (Inherit s ns _p) = + "inherit" <+> scope <> align (fillSep (map prettyKeyName ns)) <> semi + where scope = maybe mempty ((<> space) . parens . withoutParens) s -prettyKeyName :: NKeyName NixDoc -> Doc -prettyKeyName (StaticKey "") = dquotes $ text "" -prettyKeyName (StaticKey key) - | HashSet.member key reservedNames = dquotes $ text $ unpack key -prettyKeyName (StaticKey key) = text . unpack $ key -prettyKeyName (DynamicKey key) = - runAntiquoted (DoubleQuoted [Plain "\n"]) - prettyString ((text "$" <>) . braces . withoutParens) key +prettyKeyName :: NKeyName (NixDoc ann) -> Doc ann +prettyKeyName (StaticKey "") = dquotes "" +prettyKeyName (StaticKey key) | HashSet.member key reservedNames = + dquotes $ pretty $ unpack key +prettyKeyName (StaticKey key) = pretty . unpack $ key +prettyKeyName (DynamicKey key) = runAntiquoted + (DoubleQuoted [Plain "\n"]) + prettyString + (("$" <>) . braces . withoutParens) + key -prettySelector :: NAttrPath NixDoc -> Doc +prettySelector :: NAttrPath (NixDoc ann) -> Doc ann prettySelector = hcat . punctuate dot . map prettyKeyName . NE.toList -prettyAtom :: NAtom -> NixDoc -prettyAtom atom = simpleExpr $ text $ unpack $ atomText atom +prettyAtom :: NAtom -> NixDoc ann +prettyAtom atom = simpleExpr $ pretty $ unpack $ atomText atom -prettyNix :: NExpr -> Doc +prettyNix :: NExpr -> Doc ann prettyNix = withoutParens . cata exprFNixDoc -prettyOriginExpr :: NExprLocF (Maybe (NValue m)) -> Doc +instance HasCitations1 t m v f + => HasCitations t m v (NValue' t f m a) where + citations (NValue f) = citations1 f + addProvenance x (NValue f) = NValue (addProvenance1 x f) + +prettyOriginExpr + :: forall t f m ann + . HasCitations1 t m (NValue t f m) f + => NExprLocF (Maybe (NValue t f m)) + -> Doc ann prettyOriginExpr = withoutParens . go - where - go = exprFNixDoc . annotated . getCompose . fmap render + where + go = exprFNixDoc . annotated . getCompose . fmap render - render Nothing = simpleExpr $ text "_" - render (Just (NValue (reverse -> p:_) _)) = go (_originExpr p) - render (Just (NValue _ _)) = simpleExpr $ text "?" - -- simpleExpr $ foldr ((<$>) . parens . indent 2 . withoutParens + render :: Maybe (NValue t f m) -> NixDoc ann + render Nothing = simpleExpr $ "_" + render (Just (reverse . citations @t @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) -exprFNixDoc :: NExprF NixDoc -> NixDoc +exprFNixDoc :: NExprF (NixDoc ann) -> NixDoc ann exprFNixDoc = \case - NConstant atom -> prettyAtom atom - NStr str -> simpleExpr $ prettyString str - NList [] -> simpleExpr $ lbracket <> rbracket - NList xs -> simpleExpr $ group $ - nest 2 (vsep $ lbracket : map (wrapParens appOpNonAssoc) xs) <$> rbracket - NSet [] -> simpleExpr $ lbrace <> rbrace - NSet xs -> simpleExpr $ group $ - nest 2 (vsep $ lbrace : map prettyBind xs) <$> rbrace - NRecSet [] -> simpleExpr $ recPrefix <> lbrace <> rbrace - NRecSet xs -> simpleExpr $ group $ - nest 2 (vsep $ recPrefix <> lbrace : map prettyBind xs) <$> rbrace - NAbs args body -> leastPrecedence $ - nest 2 ((prettyParams args <> colon) <$> withoutParens body) - NBinary NApp fun arg -> - mkNixDoc (wrapParens appOp fun <+> wrapParens appOpNonAssoc arg) appOp - NBinary op r1 r2 -> flip mkNixDoc opInfo $ hsep - [ wrapParens (f NAssocLeft) r1 - , text $ unpack $ operatorName opInfo - , wrapParens (f NAssocRight) r2 + NConstant atom -> prettyAtom atom + NStr str -> simpleExpr $ prettyString str + NList [] -> simpleExpr $ lbracket <> rbracket + NList xs -> + simpleExpr + $ group + $ nest 2 + $ vsep + $ concat + $ [[lbracket], map (wrapParens appOpNonAssoc) xs, [rbracket]] + NSet [] -> simpleExpr $ lbrace <> rbrace + NSet xs -> + simpleExpr + $ group + $ nest 2 + $ vsep + $ concat + $ [[lbrace], map prettyBind xs, [rbrace]] + NRecSet [] -> simpleExpr $ recPrefix <> lbrace <> rbrace + NRecSet xs -> + simpleExpr + $ group + $ nest 2 + $ vsep + $ concat + $ [[recPrefix <> lbrace], map prettyBind xs, [rbrace]] + NAbs args body -> + leastPrecedence + $ nest 2 + $ vsep + $ [prettyParams args <> colon, withoutParens body] + NBinary NApp fun arg -> + mkNixDoc (wrapParens appOp fun <+> wrapParens appOpNonAssoc arg) appOp + NBinary op r1 r2 -> flip mkNixDoc opInfo $ hsep + [ wrapParens (f NAssocLeft) r1 + , pretty $ unpack $ operatorName opInfo + , wrapParens (f NAssocRight) r2 + ] + where + opInfo = getBinaryOperator op + f x | associativity opInfo /= x = opInfo { associativity = NAssocNone } + | otherwise = opInfo + NUnary op r1 -> mkNixDoc + (pretty (unpack (operatorName opInfo)) <> wrapParens opInfo r1) + opInfo + where opInfo = getUnaryOperator op + NSelect r' attr o -> + (if isJust o then leastPrecedence else flip mkNixDoc selectOp) + $ wrapPath selectOp r + <> dot + <> prettySelector attr + <> ordoc + where + r = flip mkNixDoc selectOp $ wrapParens appOpNonAssoc r' + ordoc = maybe mempty (((space <> "or") <+>) . wrapParens appOpNonAssoc) o + NHasAttr r attr -> + mkNixDoc (wrapParens hasAttrOp r <+> "?" <+> prettySelector attr) hasAttrOp + NEnvPath p -> simpleExpr $ pretty ("<" ++ p ++ ">") + NLiteralPath p -> pathExpr $ pretty $ case p of + "./" -> "./." + "../" -> "../." + ".." -> "../." + txt | "/" `isPrefixOf` txt -> txt + | "~/" `isPrefixOf` txt -> txt + | "./" `isPrefixOf` txt -> txt + | "../" `isPrefixOf` txt -> txt + | otherwise -> "./" ++ txt + NSym name -> simpleExpr $ pretty (unpack name) + NLet binds body -> + leastPrecedence + $ group + $ vsep + $ [ "let" + , indent 2 (vsep (map prettyBind binds)) + , "in" <+> withoutParens body ] - where - opInfo = getBinaryOperator op - f x | associativity opInfo /= x = opInfo { associativity = NAssocNone } - | otherwise = opInfo - NUnary op r1 -> - mkNixDoc (text (unpack (operatorName opInfo)) <> wrapParens opInfo r1) opInfo - where opInfo = getUnaryOperator op - NSelect r attr o -> - (if isJust o then leastPrecedence else flip mkNixDoc selectOp) $ - wrapPath selectOp r <> dot <> prettySelector attr <> ordoc - where ordoc = maybe empty (((space <> text "or") <+>) . wrapParens selectOp) o - NHasAttr r attr -> - mkNixDoc (wrapParens hasAttrOp r <+> text "?" <+> prettySelector attr) hasAttrOp - NEnvPath p -> simpleExpr $ text ("<" ++ p ++ ">") - NLiteralPath p -> pathExpr $ text $ case p of - "./" -> "./." - "../" -> "../." - ".." -> "../." - txt | "/" `isPrefixOf` txt -> txt - | "~/" `isPrefixOf` txt -> txt - | "./" `isPrefixOf` txt -> txt - | "../" `isPrefixOf` txt -> txt - | otherwise -> "./" ++ txt - NSym name -> simpleExpr $ text (unpack name) - NLet binds body -> leastPrecedence $ group $ text "let" <$> indent 2 ( - vsep (map prettyBind binds)) <$> text "in" <+> withoutParens body - NIf cond trueBody falseBody -> leastPrecedence $ - group $ nest 2 $ (text "if" <+> withoutParens cond) <$> - ( align (text "then" <+> withoutParens trueBody) - <$> align (text "else" <+> withoutParens falseBody) - ) - NWith scope body -> leastPrecedence $ - text "with" <+> withoutParens scope <> semi <$> align (withoutParens body) - NAssert cond body -> leastPrecedence $ - text "assert" <+> withoutParens cond <> semi <$> align (withoutParens body) - where - recPrefix = text "rec" <> space + NIf cond trueBody falseBody -> + leastPrecedence + $ group + $ nest 2 + $ vsep + $ [ "if" <+> withoutParens cond + , align ("then" <+> withoutParens trueBody) + , align ("else" <+> withoutParens falseBody) + ] + NWith scope body -> + leastPrecedence + $ vsep + $ ["with" <+> withoutParens scope <> semi, align $ withoutParens body] + NAssert cond body -> + leastPrecedence + $ vsep + $ ["assert" <+> withoutParens cond <> semi, align $ withoutParens body] + NSynHole name -> simpleExpr $ pretty ("^" <> unpack name) + where recPrefix = "rec" <> space -prettyNValueNF :: Functor m => NValueNF m -> Doc +valueToExpr :: forall t f m . MonadDataContext f m => NValueNF t f m -> NExpr +valueToExpr = iterNValueNF + (const (mkStr (principledMakeNixStringWithoutContext ""))) + phi + where + phi :: NValue' t f m NExpr -> NExpr + phi (NVConstant a ) = Fix $ NConstant a + phi (NVStr ns) = mkStr ns + phi (NVList l ) = Fix $ NList l + phi (NVSet s p ) = Fix $ NSet + [ NamedVar (StaticKey k :| []) v (fromMaybe nullPos (M.lookup k p)) + | (k, v) <- toList s + ] + phi (NVClosure _ _ ) = Fix . NSym . pack $ "" + phi (NVPath p ) = Fix $ NLiteralPath p + phi (NVBuiltin name _) = Fix . NSym . pack $ "builtins." ++ name + phi _ = error "Pattern synonyms foil completeness check" + + mkStr ns = Fix $ NStr $ DoubleQuoted [Plain (hackyStringIgnoreContext ns)] + +prettyNValueNF :: MonadDataContext f m => NValueNF t f m -> Doc ann prettyNValueNF = prettyNix . valueToExpr - where valueToExpr :: Functor m => NValueNF m -> NExpr - valueToExpr = transport go - go (NVConstantF a) = NConstant a - go (NVStrF t _) = NStr (DoubleQuoted [Plain t]) - go (NVListF l) = NList l - go (NVSetF s p) = NSet - [ NamedVar (StaticKey k :| []) v (fromMaybe nullPos (M.lookup k p)) - | (k, v) <- toList s ] - go (NVClosureF _ _) = NSym . pack $ "" - go (NVPathF p) = NLiteralPath p - go (NVBuiltinF name _) = NSym $ Text.pack $ "builtins." ++ name +printNix :: forall t f m . MonadDataContext f m => NValueNF t f m -> String +printNix = iterNValueNF (const "") phi + where + phi :: NValue' t f m String -> String + phi (NVConstant a ) = unpack $ atomText a + phi (NVStr ns) = show $ hackyStringIgnoreContext ns + phi (NVList l ) = "[ " ++ unwords l ++ " ]" + phi (NVSet s _) = + "{ " + ++ concat + [ check (unpack k) ++ " = " ++ v ++ "; " + | (k, v) <- sort $ toList s + ] + ++ "}" + where + check v = fromMaybe + v + ( (fmap (surround . show) (readMaybe v :: Maybe Int)) + <|> (fmap (surround . show) (readMaybe v :: Maybe Float)) + ) + where surround s = "\"" ++ s ++ "\"" + phi NVClosure{} = "<>" + phi (NVPath fp ) = fp + phi (NVBuiltin name _) = "<>" + phi _ = error "Pattern synonyms foil completeness check" -printNix :: Functor m => NValueNF m -> String -printNix = cata phi - where phi :: NValueF m String -> String - phi (NVConstantF a) = unpack $ atomText a - phi (NVStrF t _) = show t - phi (NVListF l) = "[ " ++ unwords l ++ " ]" - phi (NVSetF s _) = - "{ " ++ concat [ unpack k ++ " = " ++ v ++ "; " - | (k, v) <- sort $ toList s ] ++ "}" - phi NVClosureF {} = "<>" - phi (NVPathF fp) = fp - phi (NVBuiltinF name _) = "<>" +prettyNValue + :: (MonadThunk t m (NValue t f m), MonadDataContext f m) + => NValue t f m + -> m (Doc ann) +prettyNValue = fmap prettyNValueNF . removeEffectsM -removeEffects :: Functor m => NValueF m (NThunk m) -> NValueNF m -removeEffects = Fix . fmap dethunk - where - dethunk (NThunk _ (Value v)) = removeEffects (_baseValue v) - dethunk (NThunk _ _) = Fix $ NVStrF "" mempty +prettyNValueProv + :: forall t f m ann + . ( HasCitations1 t m (NValue t f m) f + , MonadThunk t m (NValue t f m) + , MonadDataContext f m + ) + => NValue t f m + -> m (Doc ann) +prettyNValueProv v@(NValue nv) = do + let ps = citations1 @t @m @(NValue t f m) @f nv + case ps of + [] -> prettyNValue v + ps -> do + v' <- prettyNValue v + pure + $ fillSep + $ [ v' + , indent 2 + $ parens + $ mconcat + $ "from: " + : map (prettyOriginExpr . _originExpr) ps + ] -removeEffectsM :: MonadVar m => NValueF m (NThunk m) -> m (NValueNF m) -removeEffectsM = fmap Fix . traverse dethunk +prettyNThunk + :: forall t f m ann + . ( HasCitations t m (NValue t f m) t + , HasCitations1 t m (NValue t f m) f + , MonadThunk t m (NValue t f m) + , MonadDataContext f m + ) + => t + -> m (Doc ann) +prettyNThunk t = do + let ps = citations @t @m @(NValue t f m) @t t + v' <- prettyNValueNF <$> dethunk t + pure + $ fillSep + $ [ v' + , indent 2 + $ parens + $ mconcat + $ "thunk from: " + : map (prettyOriginExpr . _originExpr) ps + ] -prettyNValueF :: MonadVar m => NValueF m (NThunk m) -> m Doc -prettyNValueF = fmap prettyNValueNF . removeEffectsM -prettyNValue :: MonadVar m => NValue m -> m Doc -prettyNValue (NValue _ v) = prettyNValueF v -prettyNValueProv :: MonadVar m => NValue m -> m Doc -prettyNValueProv = \case - NValue [] v -> prettyNValueF v - NValue ps v -> do - v' <- prettyNValueF v - pure $ v' indent 2 (parens (mconcat - (text "from: " : map (prettyOriginExpr . _originExpr) ps))) -prettyNThunk :: MonadVar m => NThunk m -> m Doc -prettyNThunk = \case - t@(NThunk ps _) -> do - v' <- fmap prettyNValueNF (dethunk t) - pure $ v' indent 2 (parens (mconcat - (text "thunk from: " : map (prettyOriginExpr . _originExpr) ps))) -dethunk :: MonadVar m => NThunk m -> m (NValueNF m) -dethunk = \case - NThunk _ (Value v) -> removeEffectsM (_baseValue v) - NThunk _ (Thunk _ active ref) -> do - nowActive <- atomicModifyVar active (True,) - if nowActive - then pure $ Fix $ NVStrF "" mempty - else do - eres <- readVar ref - case eres of - Computed v -> removeEffectsM (_baseValue v) - _ -> pure $ Fix $ NVStrF "" mempty + + + diff --git a/src/Nix/Reduce.hs b/src/Nix/Reduce.hs --- a/src/Nix/Reduce.hs +++ b/src/Nix/Reduce.hs @@ -32,31 +32,39 @@ module Nix.Reduce (reduceExpr, reducingEvalExpr) where import Control.Applicative -import Control.Arrow (second) +import Control.Arrow ( second ) import Control.Monad import Control.Monad.Catch +import Control.Monad.Fail import Control.Monad.Fix import Control.Monad.IO.Class import Control.Monad.Reader import Control.Monad.State.Strict -import Control.Monad.Trans.Reader (ReaderT(..)) -import Control.Monad.Trans.State.Strict (StateT(..)) +import Control.Monad.Trans.Reader ( ReaderT(..) ) +import Control.Monad.Trans.State.Strict + ( StateT(..) ) import Data.Fix -- import Data.Foldable -import Data.HashMap.Lazy (HashMap) -import qualified Data.HashMap.Lazy as M +import Data.HashMap.Lazy ( HashMap ) +import qualified Data.HashMap.Lazy as M -- import Data.HashSet (HashSet) -- import qualified Data.HashSet as S import Data.IORef -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NE -import Data.Maybe (fromMaybe, mapMaybe, catMaybes) -import Data.Text (Text) +import Data.List.NonEmpty ( NonEmpty(..) ) +import qualified Data.List.NonEmpty as NE +import Data.Maybe ( fromMaybe + , mapMaybe + , catMaybes + ) +import Data.Text ( Text ) import Nix.Atoms import Nix.Exec import Nix.Expr import Nix.Frames -import Nix.Options (Options, reduceSets, reduceLists) +import Nix.Options ( Options + , reduceSets + , reduceLists + ) import Nix.Parser import Nix.Scope import Nix.Utils @@ -67,103 +75,116 @@ { runReducer :: ReaderT (Maybe FilePath, Scopes (Reducer m) NExprLoc) (StateT (HashMap FilePath NExprLoc) m) a } deriving (Functor, Applicative, Alternative, Monad, MonadPlus, - MonadFix, MonadIO, + MonadFix, MonadIO, MonadFail, MonadReader (Maybe FilePath, Scopes (Reducer m) NExprLoc), MonadState (HashMap FilePath NExprLoc)) staticImport - :: forall e m. - (MonadIO m, Scoped e NExprLoc m, - MonadReader (Maybe FilePath, Scopes m NExprLoc) m, - MonadState (HashMap FilePath NExprLoc) m) - => SrcSpan -> FilePath -> m NExprLoc + :: forall m + . ( MonadIO m + , Scoped NExprLoc m + , MonadFail m + , MonadReader (Maybe FilePath, Scopes m NExprLoc) m + , MonadState (HashMap FilePath NExprLoc) m + ) + => SrcSpan + -> FilePath + -> m NExprLoc staticImport pann path = do - mfile <- asks fst - path <- liftIO $ pathToDefaultNixFile path - path' <- liftIO $ pathToDefaultNixFile =<< canonicalizePath - (maybe path (\p -> takeDirectory p path) mfile) + mfile <- asks fst + path <- liftIO $ pathToDefaultNixFile path + path' <- liftIO $ pathToDefaultNixFile =<< canonicalizePath + (maybe path (\p -> takeDirectory p path) mfile) - imports <- get - case M.lookup path' imports of - Just expr -> pure expr - Nothing -> go path' - where - go path = do - liftIO $ putStrLn $ "Importing file " ++ path + imports <- get + case M.lookup path' imports of + Just expr -> pure expr + Nothing -> go path' + where + go path = do + liftIO $ putStrLn $ "Importing file " ++ path - eres <- liftIO $ parseNixFileLoc path - case eres of - Failure err -> error $ "Parse failed: " ++ show err - Success x -> do - let pos = SourcePos "Reduce.hs" (mkPos 1) (mkPos 1) - span = SrcSpan pos pos - cur = NamedVar (StaticKey "__cur_file" :| []) - (Fix (NLiteralPath_ pann path)) pos - x' = Fix (NLet_ span [cur] x) - modify (M.insert path x') - local (const (Just path, emptyScopes @m @NExprLoc)) $ do - x'' <- cata reduce x' - modify (M.insert path x'') - return x'' + eres <- liftIO $ parseNixFileLoc path + case eres of + Failure err -> error $ "Parse failed: " ++ show err + Success x -> do + let + pos = SourcePos "Reduce.hs" (mkPos 1) (mkPos 1) + span = SrcSpan pos pos + cur = NamedVar (StaticKey "__cur_file" :| []) + (Fix (NLiteralPath_ pann path)) + pos + x' = Fix (NLet_ span [cur] x) + modify (M.insert path x') + local (const (Just path, emptyScopes @m @NExprLoc)) $ do + x'' <- cata reduce x' + modify (M.insert path x'') + return x'' -- gatherNames :: NExprLoc -> HashSet VarName -- gatherNames = cata $ \case -- NSym_ _ var -> S.singleton var -- Compose (Ann _ x) -> fold x -reduceExpr :: MonadIO m => Maybe FilePath -> NExprLoc -> m NExprLoc -reduceExpr mpath expr - = (`evalStateT` M.empty) +reduceExpr + :: (MonadIO m, MonadFail m) => Maybe FilePath -> NExprLoc -> m NExprLoc +reduceExpr mpath expr = + (`evalStateT` M.empty) . (`runReaderT` (mpath, emptyScopes)) . runReducer $ cata reduce expr -reduce :: forall e m. - (MonadIO m, Scoped e NExprLoc m, - MonadReader (Maybe FilePath, Scopes m NExprLoc) m, - MonadState (HashMap FilePath NExprLoc) m) - => NExprLocF (m NExprLoc) -> m NExprLoc +reduce + :: forall m + . ( MonadIO m + , Scoped NExprLoc m + , MonadFail m + , MonadReader (Maybe FilePath, Scopes m NExprLoc) m + , MonadState (HashMap FilePath NExprLoc) m + ) + => NExprLocF (m NExprLoc) + -> m NExprLoc -- | Reduce the variable to its value if defined. -- Leave it as it is otherwise. reduce (NSym_ ann var) = lookupVar var <&> \case - Nothing -> Fix (NSym_ ann var) - Just v -> v + Nothing -> Fix (NSym_ ann var) + Just v -> v -- | Reduce binary and integer negation. reduce (NUnary_ uann op arg) = arg >>= \x -> case (op, x) of - (NNeg, Fix (NConstant_ cann (NInt n))) -> - return $ Fix $ NConstant_ cann (NInt (negate n)) - (NNot, Fix (NConstant_ cann (NBool b))) -> - return $ Fix $ NConstant_ cann (NBool (not b)) - _ -> return $ Fix $ NUnary_ uann op x + (NNeg, Fix (NConstant_ cann (NInt n))) -> + return $ Fix $ NConstant_ cann (NInt (negate n)) + (NNot, Fix (NConstant_ cann (NBool b))) -> + return $ Fix $ NConstant_ cann (NBool (not b)) + _ -> return $ Fix $ NUnary_ uann op x -- | Reduce function applications. -- -- * Reduce an import to the actual imported expression. -- -- * Reduce a lambda function by adding its name to the local --- scope and recursively reducing its body. +-- scope and recursively reducing its body. reduce (NBinary_ bann NApp fun arg) = fun >>= \case - f@(Fix (NSym_ _ "import")) -> arg >>= \case - -- Fix (NEnvPath_ pann origPath) -> staticImport pann origPath - Fix (NLiteralPath_ pann origPath) -> staticImport pann origPath - v -> return $ Fix $ NBinary_ bann NApp f v + f@(Fix (NSym_ _ "import")) -> arg >>= \case + -- Fix (NEnvPath_ pann origPath) -> staticImport pann origPath + Fix (NLiteralPath_ pann origPath) -> staticImport pann origPath + v -> return $ Fix $ NBinary_ bann NApp f v - Fix (NAbs_ _ (Param name) body) -> do - x <- arg - pushScope (M.singleton name x) (cata reduce body) + Fix (NAbs_ _ (Param name) body) -> do + x <- arg + pushScope (M.singleton name x) (cata reduce body) - f -> Fix . NBinary_ bann NApp f <$> arg + f -> Fix . NBinary_ bann NApp f <$> arg -- | Reduce an integer addition to its result. reduce (NBinary_ bann op larg rarg) = do - lval <- larg - rval <- rarg - case (op, lval, rval) of - (NPlus, Fix (NConstant_ ann (NInt x)), Fix (NConstant_ _ (NInt y))) -> - return $ Fix (NConstant_ ann (NInt (x + y))) - _ -> pure $ Fix $ NBinary_ bann op lval rval + lval <- larg + rval <- rarg + case (op, lval, rval) of + (NPlus, Fix (NConstant_ ann (NInt x)), Fix (NConstant_ _ (NInt y))) -> + return $ Fix (NConstant_ ann (NInt (x + y))) + _ -> pure $ Fix $ NBinary_ bann op lval rval -- | Reduce a select on a Set by substituing the set to the selected value. -- @@ -173,70 +194,69 @@ -- 2. The selection AttrPath is a list of StaticKeys. -- 3. The selected AttrPath exists in the set. reduce base@(NSelect_ _ _ attrs _) - | sAttrPath $ NE.toList attrs = do - (NSelect_ _ aset attrs _) <- sequence base - inspectSet (unFix aset) attrs - | otherwise = sId - where - sId = Fix <$> sequence base - -- The selection AttrPath is composed of StaticKeys. - sAttrPath (StaticKey _:xs) = sAttrPath xs - sAttrPath [] = True - sAttrPath _ = False - -- Find appropriate bind in set's binds. - findBind [] _ = Nothing - findBind (x:xs) attrs@(a:|_) = case x of - n@(NamedVar (a':|_) _ _) | a' == a -> Just n - _ -> findBind xs attrs - -- Follow the attrpath recursively in sets. - inspectSet (NSet_ _ binds) attrs = case findBind binds attrs of - Just (NamedVar _ e _) -> case NE.uncons attrs of - (_,Just attrs) -> inspectSet (unFix e) attrs - _ -> pure e - _ -> sId - inspectSet _ _ = sId + | sAttrPath $ NE.toList attrs = do + (NSelect_ _ aset attrs _) <- sequence base + inspectSet (unFix aset) attrs + | otherwise = sId + where + sId = Fix <$> sequence base + -- The selection AttrPath is composed of StaticKeys. + sAttrPath (StaticKey _ : xs) = sAttrPath xs + sAttrPath [] = True + sAttrPath _ = False + -- Find appropriate bind in set's binds. + findBind [] _ = Nothing + findBind (x : xs) attrs@(a :| _) = case x of + n@(NamedVar (a' :| _) _ _) | a' == a -> Just n + _ -> findBind xs attrs + -- Follow the attrpath recursively in sets. + inspectSet (NSet_ _ binds) attrs = case findBind binds attrs of + Just (NamedVar _ e _) -> case NE.uncons attrs of + (_, Just attrs) -> inspectSet (unFix e) attrs + _ -> pure e + _ -> sId + inspectSet _ _ = sId -- reduce (NHasAttr aset attr) = -- | Reduce a set by inlining its binds outside of the set -- if none of the binds inherit the super set. reduce e@(NSet_ ann binds) = do - let usesInherit = flip any binds $ \case - Inherit {} -> True - _ -> False - if usesInherit - then clearScopes @NExprLoc $ - Fix . NSet_ ann <$> traverse sequence binds - else Fix <$> sequence e + let usesInherit = flip any binds $ \case + Inherit{} -> True + _ -> False + if usesInherit + then clearScopes @NExprLoc $ Fix . NSet_ ann <$> traverse sequence binds + else Fix <$> sequence e -- Encountering a 'rec set' construction eliminates any hope of inlining -- definitions. reduce (NRecSet_ ann binds) = - clearScopes @NExprLoc $ Fix . NRecSet_ ann <$> traverse sequence binds + clearScopes @NExprLoc $ Fix . NRecSet_ ann <$> traverse sequence binds -- Encountering a 'with' construction eliminates any hope of inlining -- definitions. reduce (NWith_ ann scope body) = - clearScopes @NExprLoc $ fmap Fix $ NWith_ ann <$> scope <*> body + clearScopes @NExprLoc $ fmap Fix $ NWith_ ann <$> scope <*> body -- | Reduce a let binds section by pushing lambdas, -- constants and strings to the body scope. reduce (NLet_ ann binds body) = do - s <- fmap (M.fromList . catMaybes) $ forM binds $ \case - NamedVar (StaticKey name :| []) def _pos -> def >>= \case - d@(Fix NAbs_ {}) -> pure $ Just (name, d) - d@(Fix NConstant_ {}) -> pure $ Just (name, d) - d@(Fix NStr_ {}) -> pure $ Just (name, d) - _ -> pure Nothing - _ -> pure Nothing - body' <- pushScope s body - binds' <- traverse sequence binds - -- let names = gatherNames body' - -- binds' <- traverse sequence binds <&> \b -> flip filter b $ \case - -- NamedVar (StaticKey name _ :| []) _ -> - -- name `S.member` names - -- _ -> True - pure $ Fix $ NLet_ ann binds' body' + s <- fmap (M.fromList . catMaybes) $ forM binds $ \case + NamedVar (StaticKey name :| []) def _pos -> def >>= \case + d@(Fix NAbs_{} ) -> pure $ Just (name, d) + d@(Fix NConstant_{}) -> pure $ Just (name, d) + d@(Fix NStr_{} ) -> pure $ Just (name, d) + _ -> pure Nothing + _ -> pure Nothing + body' <- pushScope s body + binds' <- traverse sequence binds + -- let names = gatherNames body' + -- binds' <- traverse sequence binds <&> \b -> flip filter b $ \case + -- NamedVar (StaticKey name _ :| []) _ -> + -- name `S.member` names + -- _ -> True + pure $ Fix $ NLet_ ann binds' body' -- where -- go m [] = pure m -- go m (x:xs) = case x of @@ -248,24 +268,24 @@ -- | Reduce an if to the relevant path if -- the condition is a boolean constant. reduce e@(NIf_ _ b t f) = b >>= \case - Fix (NConstant_ _ (NBool b')) -> if b' then t else f - _ -> Fix <$> sequence e + Fix (NConstant_ _ (NBool b')) -> if b' then t else f + _ -> Fix <$> sequence e -- | Reduce an assert atom to its encapsulated -- symbol if the assertion is a boolean constant. reduce e@(NAssert_ _ b body) = b >>= \case - Fix (NConstant_ _ (NBool b')) | b' -> body - _ -> Fix <$> sequence e + Fix (NConstant_ _ (NBool b')) | b' -> body + _ -> Fix <$> sequence e reduce (NAbs_ ann params body) = do - params' <- sequence params - -- Make sure that variable definitions in scope do not override function - -- arguments. - let args = case params' of - Param name -> M.singleton name (Fix (NSym_ ann name)) - ParamSet pset _ _ -> - M.fromList $ map (\(k, _) -> (k, Fix (NSym_ ann k))) pset - Fix . NAbs_ ann params' <$> pushScope args body + params' <- sequence params + -- Make sure that variable definitions in scope do not override function + -- arguments. + let args = case params' of + Param name -> M.singleton name (Fix (NSym_ ann name)) + ParamSet pset _ _ -> + M.fromList $ map (\(k, _) -> (k, Fix (NSym_ ann k))) pset + Fix . NAbs_ ann params' <$> pushScope args body reduce v = Fix <$> sequence v @@ -274,136 +294,136 @@ deriving (Functor, Foldable, Traversable) instance Show (f r) => Show (FlaggedF f r) where - show (FlaggedF (_, x)) = show x + show (FlaggedF (_, x)) = show x type Flagged f = Fix (FlaggedF f) -flagExprLoc :: (MonadIO n, Traversable f) - => Fix f -> n (Flagged f) +flagExprLoc :: (MonadIO n, Traversable f) => Fix f -> n (Flagged f) flagExprLoc = cataM $ \x -> do - flag <- liftIO $ newIORef False - pure $ Fix $ FlaggedF (flag, x) + flag <- liftIO $ newIORef False + pure $ Fix $ FlaggedF (flag, x) -- stripFlags :: Functor f => Flagged f -> Fix f -- stripFlags = cata $ Fix . snd . flagged pruneTree :: MonadIO n => Options -> Flagged NExprLocF -> n (Maybe NExprLoc) pruneTree opts = cataM $ \(FlaggedF (b, Compose x)) -> do - used <- liftIO $ readIORef b - pure $ if used - then Fix . Compose <$> traverse prune x - else Nothing - where - prune :: NExprF (Maybe NExprLoc) -> Maybe (NExprF NExprLoc) - prune = \case - NStr str -> Just $ NStr (pruneString str) - NHasAttr (Just aset) attr -> Just $ NHasAttr aset (NE.map pruneKeyName attr) - NAbs params (Just body) -> Just $ NAbs (pruneParams params) body + used <- liftIO $ readIORef b + pure $ if used then Fix . Compose <$> traverse prune x else Nothing + where + prune :: NExprF (Maybe NExprLoc) -> Maybe (NExprF NExprLoc) + prune = \case + NStr str -> Just $ NStr (pruneString str) + NHasAttr (Just aset) attr -> + Just $ NHasAttr aset (NE.map pruneKeyName attr) + NAbs params (Just body) -> Just $ NAbs (pruneParams params) body - NList l | reduceLists opts -> Just $ NList (catMaybes l) - | otherwise -> Just $ NList (map (fromMaybe nNull) l) - NSet binds | reduceSets opts -> Just $ NSet (mapMaybe sequence binds) - | otherwise -> Just $ NSet (map (fmap (fromMaybe nNull)) binds) - NRecSet binds | reduceSets opts -> Just $ NRecSet (mapMaybe sequence binds) - | otherwise -> Just $ NRecSet (map (fmap (fromMaybe nNull)) binds) + NList l | reduceLists opts -> Just $ NList (catMaybes l) + | otherwise -> Just $ NList (map (fromMaybe nNull) l) + NSet binds | reduceSets opts -> Just $ NSet (mapMaybe sequence binds) + | otherwise -> Just $ NSet (map (fmap (fromMaybe nNull)) binds) + NRecSet binds + | reduceSets opts -> Just $ NRecSet (mapMaybe sequence binds) + | otherwise -> Just $ NRecSet (map (fmap (fromMaybe nNull)) binds) - NLet binds (Just body@(Fix (Compose (Ann _ x)))) -> - Just $ case mapMaybe pruneBinding binds of - [] -> x - xs -> NLet xs body + NLet binds (Just body@(Fix (Compose (Ann _ x)))) -> + Just $ case mapMaybe pruneBinding binds of + [] -> x + xs -> NLet xs body - NSelect (Just aset) attr alt -> - Just $ NSelect aset (NE.map pruneKeyName attr) (join alt) + NSelect (Just aset) attr alt -> + Just $ NSelect aset (NE.map pruneKeyName attr) (join alt) - -- These are the only short-circuiting binary operators - NBinary NAnd (Just (Fix (Compose (Ann _ larg)))) _ -> Just larg - NBinary NOr (Just (Fix (Compose (Ann _ larg)))) _ -> Just larg + -- These are the only short-circuiting binary operators + NBinary NAnd (Just (Fix (Compose (Ann _ larg)))) _ -> Just larg + NBinary NOr (Just (Fix (Compose (Ann _ larg)))) _ -> Just larg - -- If the function was never called, it means its argument was in a - -- thunk that was forced elsewhere. - NBinary NApp Nothing (Just _) -> Nothing + -- If the function was never called, it means its argument was in a + -- thunk that was forced elsewhere. + NBinary NApp Nothing (Just _) -> Nothing - -- The idea behind emitted a binary operator where one side may be - -- invalid is that we're trying to emit what will reproduce whatever - -- error the user encountered, which means providing all aspects of - -- the evaluation path they ultimately followed. - NBinary op Nothing (Just rarg) -> Just $ NBinary op nNull rarg - NBinary op (Just larg) Nothing -> Just $ NBinary op larg nNull + -- The idea behind emitted a binary operator where one side may be + -- invalid is that we're trying to emit what will reproduce whatever + -- error the user encountered, which means providing all aspects of + -- the evaluation path they ultimately followed. + NBinary op Nothing (Just rarg) -> Just $ NBinary op nNull rarg + NBinary op (Just larg) Nothing -> Just $ NBinary op larg nNull - -- If the scope of a with was never referenced, it's not needed - NWith Nothing (Just (Fix (Compose (Ann _ body)))) -> Just body + -- If the scope of a with was never referenced, it's not needed + NWith Nothing (Just (Fix (Compose (Ann _ body)))) -> Just body - NAssert Nothing _ -> - error "How can an assert be used, but its condition not?" + NAssert Nothing _ -> + error "How can an assert be used, but its condition not?" - NAssert _ (Just (Fix (Compose (Ann _ body)))) -> Just body - NAssert (Just cond) _ -> Just $ NAssert cond nNull + NAssert _ (Just (Fix (Compose (Ann _ body)))) -> Just body + NAssert (Just cond) _ -> Just $ NAssert cond nNull - NIf Nothing _ _ -> - error "How can an if be used, but its condition not?" + NIf Nothing _ _ -> error "How can an if be used, but its condition not?" - NIf _ Nothing (Just (Fix (Compose (Ann _ f)))) -> Just f - NIf _ (Just (Fix (Compose (Ann _ t)))) Nothing -> Just t + NIf _ Nothing (Just (Fix (Compose (Ann _ f)))) -> Just f + NIf _ (Just (Fix (Compose (Ann _ t)))) Nothing -> Just t - x -> sequence x + x -> sequence x - pruneString :: NString (Maybe NExprLoc) -> NString NExprLoc - pruneString (DoubleQuoted xs) = - DoubleQuoted (mapMaybe pruneAntiquotedText xs) - pruneString (Indented n xs) = - Indented n (mapMaybe pruneAntiquotedText xs) + pruneString :: NString (Maybe NExprLoc) -> NString NExprLoc + pruneString (DoubleQuoted xs) = + DoubleQuoted (mapMaybe pruneAntiquotedText xs) + pruneString (Indented n xs) = Indented n (mapMaybe pruneAntiquotedText xs) - pruneAntiquotedText - :: Antiquoted Text (Maybe NExprLoc) - -> Maybe (Antiquoted Text NExprLoc) - pruneAntiquotedText (Plain v) = Just (Plain v) - pruneAntiquotedText EscapedNewline = Just EscapedNewline - pruneAntiquotedText (Antiquoted Nothing) = Nothing - pruneAntiquotedText (Antiquoted (Just k)) = Just (Antiquoted k) + pruneAntiquotedText + :: Antiquoted Text (Maybe NExprLoc) -> Maybe (Antiquoted Text NExprLoc) + pruneAntiquotedText (Plain v) = Just (Plain v) + pruneAntiquotedText EscapedNewline = Just EscapedNewline + pruneAntiquotedText (Antiquoted Nothing ) = Nothing + pruneAntiquotedText (Antiquoted (Just k)) = Just (Antiquoted k) - pruneAntiquoted - :: Antiquoted (NString (Maybe NExprLoc)) (Maybe NExprLoc) - -> Maybe (Antiquoted (NString NExprLoc) NExprLoc) - pruneAntiquoted (Plain v) = Just (Plain (pruneString v)) - pruneAntiquoted EscapedNewline = Just EscapedNewline - pruneAntiquoted (Antiquoted Nothing) = Nothing - pruneAntiquoted (Antiquoted (Just k)) = Just (Antiquoted k) + pruneAntiquoted + :: Antiquoted (NString (Maybe NExprLoc)) (Maybe NExprLoc) + -> Maybe (Antiquoted (NString NExprLoc) NExprLoc) + pruneAntiquoted (Plain v) = Just (Plain (pruneString v)) + pruneAntiquoted EscapedNewline = Just EscapedNewline + pruneAntiquoted (Antiquoted Nothing ) = Nothing + pruneAntiquoted (Antiquoted (Just k)) = Just (Antiquoted k) - pruneKeyName :: NKeyName (Maybe NExprLoc) -> NKeyName NExprLoc - pruneKeyName (StaticKey n) = StaticKey n - pruneKeyName (DynamicKey k) - | Just k' <- pruneAntiquoted k = DynamicKey k' - | otherwise = StaticKey "" + pruneKeyName :: NKeyName (Maybe NExprLoc) -> NKeyName NExprLoc + pruneKeyName (StaticKey n) = StaticKey n + pruneKeyName (DynamicKey k) | Just k' <- pruneAntiquoted k = DynamicKey k' + | otherwise = StaticKey "" - pruneParams :: Params (Maybe NExprLoc) -> Params NExprLoc - pruneParams (Param n) = Param n - pruneParams (ParamSet xs b n) - | reduceSets opts = - ParamSet (map (second (maybe (Just nNull) Just - . fmap (fromMaybe nNull))) xs) b n - | otherwise = - ParamSet (map (second (fmap (fromMaybe nNull))) xs) b n + pruneParams :: Params (Maybe NExprLoc) -> Params NExprLoc + pruneParams (Param n) = Param n + pruneParams (ParamSet xs b n) + | reduceSets opts = ParamSet + (map (second (maybe (Just nNull) Just . fmap (fromMaybe nNull))) xs) + b + n + | otherwise = ParamSet (map (second (fmap (fromMaybe nNull))) xs) b n - pruneBinding :: Binding (Maybe NExprLoc) -> Maybe (Binding NExprLoc) - pruneBinding (NamedVar _ Nothing _) = Nothing - pruneBinding (NamedVar xs (Just x) pos) = - Just (NamedVar (NE.map pruneKeyName xs) x pos) - pruneBinding (Inherit _ [] _) = Nothing - pruneBinding (Inherit (join -> Nothing) _ _) = Nothing - pruneBinding (Inherit (join -> m) xs pos) = - Just (Inherit m (map pruneKeyName xs) pos) + pruneBinding :: Binding (Maybe NExprLoc) -> Maybe (Binding NExprLoc) + pruneBinding (NamedVar _ Nothing _) = Nothing + pruneBinding (NamedVar xs (Just x) pos) = + Just (NamedVar (NE.map pruneKeyName xs) x pos) + pruneBinding (Inherit _ [] _) = Nothing + pruneBinding (Inherit (join -> Nothing) _ _) = Nothing + pruneBinding (Inherit (join -> m) xs pos) = + Just (Inherit m (map pruneKeyName xs) pos) reducingEvalExpr - :: (Framed e m, Has e Options, Exception r, MonadCatch m, MonadIO m) - => (NExprLocF (m a) -> m a) - -> Maybe FilePath - -> NExprLoc - -> m (NExprLoc, Either r a) + :: (Framed e m, Has e Options, Exception r, MonadCatch m, MonadIO m) + => (NExprLocF (m a) -> m a) + -> Maybe FilePath + -> NExprLoc + -> m (NExprLoc, Either r a) reducingEvalExpr eval mpath expr = do - expr' <- flagExprLoc =<< liftIO (reduceExpr mpath expr) - eres <- catch (Right <$> cata (addEvalFlags eval) expr') (pure . Left) - opts :: Options <- asks (view hasLens) - expr'' <- pruneTree opts expr' - return (fromMaybe nNull expr'', eres) - where - addEvalFlags k (FlaggedF (b, x)) = liftIO (writeIORef b True) *> k x + expr' <- flagExprLoc =<< liftIO (reduceExpr mpath expr) + eres <- catch (Right <$> cata (addEvalFlags eval) expr') (pure . Left) + opts :: Options <- asks (view hasLens) + expr'' <- pruneTree opts expr' + return (fromMaybe nNull 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 diff --git a/src/Nix/Render.hs b/src/Nix/Render.hs --- a/src/Nix/Render.hs +++ b/src/Nix/Render.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} @@ -6,30 +7,120 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} module Nix.Render where -import Data.ByteString (ByteString) -import Data.List.NonEmpty (NonEmpty((:|))) -import qualified Data.Set as Set +import Prelude hiding ( readFile ) + +import Control.Monad.Trans +import Data.ByteString ( ByteString ) +import qualified Data.ByteString as BS +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Text.Prettyprint.Doc import Data.Void import Nix.Expr.Types.Annotated +import qualified System.Directory as S +import qualified System.Posix.Files as S import Text.Megaparsec.Error -import Text.Megaparsec.Pos (SourcePos(..)) -import Text.PrettyPrint.ANSI.Leijen +import Text.Megaparsec.Pos class Monad 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] + listDirectory = lift . listDirectory + getCurrentDirectory :: m FilePath + default getCurrentDirectory :: (MonadTrans t, MonadFile m', m ~ t m') => m FilePath + getCurrentDirectory = lift getCurrentDirectory + canonicalizePath :: FilePath -> m FilePath + default canonicalizePath :: (MonadTrans t, MonadFile m', m ~ t m') => FilePath -> m FilePath + canonicalizePath = lift . canonicalizePath + getHomeDirectory :: m FilePath + default getHomeDirectory :: (MonadTrans t, MonadFile m', m ~ t m') => m FilePath + getHomeDirectory = lift getHomeDirectory + doesPathExist :: FilePath -> m Bool + default doesPathExist :: (MonadTrans t, MonadFile m', m ~ t m') => FilePath -> m Bool + doesPathExist = lift . doesPathExist + doesFileExist :: FilePath -> m Bool + default doesFileExist :: (MonadTrans t, MonadFile m', m ~ t m') => FilePath -> m Bool + doesFileExist = lift . doesFileExist + doesDirectoryExist :: FilePath -> m Bool + default doesDirectoryExist :: (MonadTrans t, MonadFile m', m ~ t m') => FilePath -> m Bool + doesDirectoryExist = lift . doesDirectoryExist + getSymbolicLinkStatus :: FilePath -> m S.FileStatus + default getSymbolicLinkStatus :: (MonadTrans t, MonadFile m', m ~ t m') => FilePath -> m S.FileStatus + getSymbolicLinkStatus = lift . getSymbolicLinkStatus -posAndMsg :: SourcePos -> Doc -> ParseError t Void -posAndMsg beg msg = - FancyError (beg :| []) - (Set.fromList [ErrorFail (show msg) :: ErrorFancy Void]) +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 -renderLocation :: MonadFile m => SrcSpan -> Doc -> m Doc -renderLocation (SrcSpan beg@(SourcePos "" _ _) _) msg = - return $ text $ init $ parseErrorPretty @Char (posAndMsg beg msg) +posAndMsg :: SourcePos -> Doc a -> ParseError s Void +posAndMsg (SourcePos _ lineNo _) msg = FancyError + (unPos lineNo) + (Set.fromList [ErrorFail (show msg) :: ErrorFancy Void]) -renderLocation (SrcSpan beg@(SourcePos path _ _) _) msg = do - contents <- Nix.Render.readFile path - return $ text $ init $ parseErrorPretty' contents (posAndMsg beg msg) +renderLocation :: MonadFile m => SrcSpan -> Doc a -> m (Doc a) +renderLocation (SrcSpan (SourcePos file begLine begCol) (SourcePos file' endLine endCol)) msg + | file /= "" && file == file' + = do + exist <- doesFileExist file + if exist + then do + txt <- sourceContext file begLine begCol endLine endCol msg + return + $ vsep + [ "In file " + <> errorContext file begLine begCol endLine endCol + <> ":" + , txt + ] + else return msg +renderLocation (SrcSpan beg end) msg = + fail + $ "Don't know how to render range from " + ++ show beg + ++ " to " + ++ show end + ++ " for error: " + ++ show msg + +errorContext :: FilePath -> Pos -> Pos -> Pos -> Pos -> Doc a +errorContext path bl bc _el _ec = + pretty path <> ":" <> pretty (unPos bl) <> ":" <> pretty (unPos bc) + +sourceContext + :: MonadFile m => FilePath -> Pos -> Pos -> Pos -> Pos -> Doc a -> m (Doc a) +sourceContext path (unPos -> begLine) (unPos -> _begCol) (unPos -> endLine) (unPos -> _endCol) msg + = do + let beg' = max 1 (min begLine (begLine - 3)) + end' = max endLine (endLine + 3) + ls <- + map pretty + . take (end' - beg') + . drop (pred beg') + . T.lines + . T.decodeUtf8 + <$> readFile path + let + nums = map (show . fst) $ zip [beg' ..] ls + longest = maximum (map length nums) + nums' = flip map nums $ \n -> replicate (longest - length n) ' ' ++ n + pad n | read n == begLine = "==> " ++ n + | otherwise = " " ++ n + ls' = zipWith (<+>) + (map (pretty . pad) nums') + (zipWith (<+>) (repeat "| ") ls) + pure $ vsep $ ls' ++ [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 @@ -16,6 +16,7 @@ import Control.Monad.Reader import Data.Fix import Data.Typeable +import Data.Text.Prettyprint.Doc import Nix.Eval import Nix.Exec import Nix.Expr @@ -28,148 +29,208 @@ import Nix.Utils import Nix.Value import Text.Megaparsec.Pos -import qualified Text.PrettyPrint.ANSI.Leijen as P -import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) #ifdef MIN_VERSION_pretty_show import qualified Text.Show.Pretty as PS #endif -renderFrames :: forall v e m. - (MonadReader e m, Has e Options, - MonadVar m, MonadFile m, Typeable m, Typeable v) - => Frames -> m Doc -renderFrames [] = pure mempty -renderFrames (x:xs) = do - opts :: Options <- asks (view hasLens) - frames <- - if | verbose opts <= ErrorsOnly -> - renderFrame @v x - | verbose opts <= Informational -> do - f <- renderFrame @v x - pure $ concatMap go (reverse xs) ++ f - | otherwise -> - concat <$> mapM (renderFrame @v) (reverse (x:xs)) - pure $ case frames of - [] -> mempty - _ -> foldr1 (P.<$>) frames - where - go :: NixFrame -> [Doc] - go f = case framePos @v @m f of - Just pos -> - [text "While evaluating at " - <> text (sourcePosPretty pos) - <> colon] - Nothing -> [] +renderFrames + :: forall v t f e m ann + . ( MonadReader e m + , Has e Options + , MonadFile m + , MonadCitedThunks t f m + , Typeable v + ) + => Frames + -> m (Doc ann) +renderFrames [] = pure mempty +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 <$> mapM (renderFrame @v @t @f) (reverse (x : xs)) + pure $ case frames of + [] -> mempty + _ -> vsep frames + where + go :: NixFrame -> [Doc ann] + go f = case framePos @v @m f of + Just pos -> + ["While evaluating at " <> pretty (sourcePosPretty pos) <> colon] + Nothing -> [] -framePos :: forall v (m :: * -> *). (Typeable m, Typeable v) => NixFrame - -> Maybe SourcePos +framePos + :: forall v (m :: * -> *) + . (Typeable m, Typeable v) + => NixFrame + -> Maybe SourcePos framePos (NixFrame _ f) - | Just (e :: EvalFrame m v) <- fromException f = case e of - EvaluatingExpr _ (Fix (Compose (Ann (SrcSpan beg _) _))) -> - Just beg - _ -> Nothing - | otherwise = Nothing + | Just (e :: EvalFrame m v) <- fromException f = case e of + EvaluatingExpr _ (Fix (Compose (Ann (SrcSpan beg _) _))) -> Just beg + _ -> Nothing + | otherwise = Nothing -renderFrame :: forall v e m. - (MonadReader e m, Has e Options, MonadVar m, - MonadFile m, Typeable m, Typeable v) - => NixFrame -> m [Doc] +renderFrame + :: forall v t f e m ann + . ( MonadReader e m + , Has e Options + , MonadFile m + , MonadCitedThunks t f m + , Typeable v + ) + => NixFrame + -> m [Doc ann] renderFrame (NixFrame level f) - | Just (e :: EvalFrame m v) <- fromException f = renderEvalFrame level e - | Just (e :: ThunkLoop) <- fromException f = renderThunkLoop level e - | Just (e :: ValueFrame m) <- fromException f = renderValueFrame level e - | Just (_ :: NormalLoop m) <- fromException f = - pure [text "<>"] - | Just (e :: ExecFrame m) <- fromException f = renderExecFrame level e - | Just (e :: ErrorCall) <- fromException f = pure [text (show e)] - | otherwise = error $ "Unrecognized frame: " ++ show f + | Just (e :: EvalFrame m v) <- fromException f = renderEvalFrame level e + | Just (e :: ThunkLoop) <- fromException f = renderThunkLoop level e + | 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 (show e)] + | Just (e :: SynHoleInfo m v) <- fromException f = pure [pretty (show e)] + | otherwise = error $ "Unrecognized frame: " ++ show f wrapExpr :: NExprF r -> NExpr wrapExpr x = Fix (Fix (NSym "") <$ x) -renderEvalFrame :: (MonadReader e m, Has e Options, MonadFile m) - => NixLevel -> EvalFrame m v -> m [Doc] +renderEvalFrame + :: (MonadReader e m, Has e Options, MonadFile m) + => NixLevel + -> EvalFrame m v + -> m [Doc ann] renderEvalFrame level f = do - opts :: Options <- asks (view hasLens) - case f of - EvaluatingExpr _scope e@(Fix (Compose (Ann ann _))) -> - fmap (:[]) $ renderLocation ann - =<< renderExpr level "While evaluating" "Expression" e + opts :: Options <- asks (view hasLens) + case f of + EvaluatingExpr scope e@(Fix (Compose (Ann ann _))) -> do + let scopeInfo | scopes opts = [pretty $ show scope] + | otherwise = [] + fmap (\x -> scopeInfo ++ [x]) + $ renderLocation ann + =<< renderExpr level "While evaluating" "Expression" e - ForcingExpr _scope e@(Fix (Compose (Ann ann _))) - | thunks opts -> - fmap (:[]) $ renderLocation ann - =<< renderExpr level "While forcing thunk from" - "Forcing thunk" e + ForcingExpr _scope e@(Fix (Compose (Ann ann _))) | thunks opts -> + fmap (: []) + $ renderLocation ann + =<< renderExpr level "While forcing thunk from" "Forcing thunk" e - Calling name ann -> - fmap (:[]) $ renderLocation ann $ - text "While calling builtins." <> text name + Calling name ann -> + fmap (: []) + $ renderLocation ann + $ "While calling builtins." + <> pretty name - _ -> pure [] + SynHole synfo -> + sequence + $ let e@(Fix (Compose (Ann ann _))) = _synHoleInfo_expr synfo + in [ renderLocation ann + =<< renderExpr level "While evaluating" "Syntactic Hole" e + , pure $ pretty $ show (_synHoleInfo_scope synfo) + ] -renderExpr :: (MonadReader e m, Has e Options, MonadFile m) - => NixLevel -> String -> String -> NExprLoc -> m Doc + ForcingExpr _ _ -> pure [] + + +renderExpr + :: (MonadReader e m, Has e Options, MonadFile m) + => NixLevel + -> String + -> String + -> NExprLoc + -> m (Doc ann) renderExpr _level longLabel shortLabel e@(Fix (Compose (Ann _ x))) = do - opts :: Options <- asks (view hasLens) - let rendered - | verbose opts >= DebugInfo = + opts :: Options <- asks (view hasLens) + let rendered + | verbose opts >= DebugInfo = #ifdef MIN_VERSION_pretty_show - text (PS.ppShow (stripAnnotation e)) + pretty (PS.ppShow (stripAnnotation e)) #else - text (show (stripAnnotation e)) + pretty (show (stripAnnotation e)) #endif - | verbose opts >= Chatty = - prettyNix (stripAnnotation e) - | otherwise = - prettyNix (Fix (Fix (NSym "") <$ x)) - pure $ if verbose opts >= Chatty - then text (longLabel ++ ":\n>>>>>>>>") - P.<$> indent 2 rendered - P.<$> text "<<<<<<<<" - else text shortLabel <> text ": " rendered + | verbose opts >= Chatty = prettyNix (stripAnnotation e) + | otherwise = prettyNix (Fix (Fix (NSym "") <$ x)) + pure $ if verbose opts >= Chatty + then + vsep + $ [pretty (longLabel ++ ":\n>>>>>>>>"), indent 2 rendered, "<<<<<<<<"] + else pretty shortLabel <> fillSep [": ", rendered] -renderValueFrame :: (MonadReader e m, Has e Options, MonadFile m) - => NixLevel -> ValueFrame m -> m [Doc] -renderValueFrame level = pure . (:[]) . \case - ForcingThunk -> text "ForcingThunk" - ConcerningValue _v -> text "ConcerningValue" - Comparison _ _ -> text "Comparing" - Addition _ _ -> text "Adding" - Division _ _ -> text "Dividing" - Multiplication _ _ -> text "Multiplying" +renderValueFrame + :: (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m) + => NixLevel + -> ValueFrame t f m + -> m [Doc ann] +renderValueFrame level = fmap (: []) . \case + ForcingThunk -> pure "ForcingThunk" + ConcerningValue _v -> pure "ConcerningValue" + Comparison _ _ -> pure "Comparing" + Addition _ _ -> pure "Adding" + Division _ _ -> pure "Dividing" + Multiplication _ _ -> pure "Multiplying" - Coercion x y -> - text desc <> text (describeValue x) - <> text " to " <> text (describeValue y) - where - desc | level <= Error = "Cannot coerce " - | otherwise = "While coercing " + Coercion x y -> pure + $ mconcat [desc, pretty (describeValue x), " to ", pretty (describeValue y)] + where + desc | level <= Error = "Cannot coerce " + | otherwise = "While coercing " - CoercionToJsonNF _v -> text "CoercionToJsonNF" - CoercionFromJson _j -> text "CoercionFromJson" - ExpectationNF _t _v -> text "ExpectationNF" - Expectation _t _v -> text "Expectation" + CoercionToJson v -> do + v' <- renderValue level "" "" v + pure $ "CoercionToJson " <> v' + CoercionFromJson _j -> pure "CoercionFromJson" + ExpectationNF _t _v -> pure "ExpectationNF" + Expectation t v -> do + v' <- renderValue level "" "" v + pure $ "Saw " <> v' <> " but expected " <> pretty (describeValue t) -renderValue :: (MonadReader e m, Has e Options, MonadFile m, MonadVar m) - => NixLevel -> String -> String -> NValue m -> m Doc +renderValue + :: (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m) + => NixLevel + -> String + -> String + -> NValue t f m + -> m (Doc ann) renderValue _level _longLabel _shortLabel v = do - opts :: Options <- asks (view hasLens) - if values opts - then prettyNValueProv v - else prettyNValue v + opts :: Options <- asks (view hasLens) + if values opts then prettyNValueProv v else prettyNValue v -renderExecFrame :: (MonadReader e m, Has e Options, MonadVar m, MonadFile m) - => NixLevel -> ExecFrame m -> m [Doc] +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 (:[]) $ renderLocation ann - =<< ((text "Assertion failed:" ) - <$> renderValue level "" "" v) + Assertion ann v -> + fmap (: []) + $ renderLocation ann + =<< ( (\d -> fillSep ["Assertion failed:", d]) + <$> renderValue level "" "" v + ) -renderThunkLoop :: (MonadReader e m, Has e Options, MonadFile m) - => NixLevel -> ThunkLoop -> m [Doc] -renderThunkLoop _level = pure . (:[]) . \case - ThunkLoop Nothing -> text "<>" - ThunkLoop (Just n) -> - text $ "<>" +renderThunkLoop + :: (MonadReader e m, Has e Options, MonadFile m, Show (ThunkId m)) + => NixLevel + -> ThunkLoop + -> m [Doc ann] +renderThunkLoop _level = pure . (: []) . \case + ThunkLoop n -> 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 (: []) . \case + NormalLoop v -> do + v' <- renderValue level "" "" v + pure $ "Infinite recursion during normalization forcing " <> v' + + + + + + + + diff --git a/src/Nix/Scope.hs b/src/Nix/Scope.hs --- a/src/Nix/Scope.hs +++ b/src/Nix/Scope.hs @@ -1,10 +1,13 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -12,72 +15,84 @@ import Control.Applicative import Control.Monad.Reader -import qualified Data.HashMap.Lazy as M -import Data.Semigroup -import Data.Text (Text) +import qualified Data.HashMap.Lazy as M +import Data.Text ( Text ) import Lens.Family2 import Nix.Utils -newtype Scope a = Scope { getScope :: AttrSet a } - deriving (Functor, Foldable, Traversable) +newtype Scope t = Scope { getScope :: AttrSet t } + deriving (Functor, Foldable, Traversable, Eq) -instance Show (Scope a) where - show (Scope m) = show (M.keys m) +instance Show (Scope t) where + show (Scope m) = show (M.keys m) -newScope :: AttrSet a -> Scope a +newScope :: AttrSet t -> Scope t newScope = Scope -scopeLookup :: Text -> [Scope v] -> Maybe v +scopeLookup :: Text -> [Scope t] -> Maybe t scopeLookup key = foldr go Nothing - where - go (Scope m) rest = M.lookup key m <|> rest + where go (Scope m) rest = M.lookup key m <|> rest -data Scopes m v = Scopes - { lexicalScopes :: [Scope v] - , dynamicScopes :: [m (Scope v)] +data Scopes m t = Scopes + { lexicalScopes :: [Scope t] + , dynamicScopes :: [m (Scope t)] } -instance Show (Scopes m v) where - show (Scopes m v) = - "Scopes: " ++ show m ++ ", and " - ++ show (length v) ++ " with-scopes" - -instance Semigroup (Scopes m v) where - Scopes ls lw <> Scopes rs rw = Scopes (ls <> rs) (lw <> rw) +instance Show (Scopes m t) where + show (Scopes m t) = + "Scopes: " ++ show m ++ ", and " ++ show (length t) ++ " with-scopes" -instance Monoid (Scopes m v) where - mempty = emptyScopes - mappend = (<>) +instance Semigroup (Scopes m t) where + Scopes ls lw <> Scopes rs rw = Scopes (ls <> rs) (lw <> rw) -type Scoped e v m = (MonadReader e m, Has e (Scopes m v)) +instance Monoid (Scopes m t) where + mempty = emptyScopes + mappend = (<>) -emptyScopes :: Scopes m v +emptyScopes :: forall m t . Scopes m t emptyScopes = Scopes [] [] -currentScopes :: Scoped e v m => m (Scopes m v) -currentScopes = asks (view hasLens) +class Scoped t m | m -> t where + currentScopes :: m (Scopes m t) + clearScopes :: m a -> m a + pushScopes :: Scopes m t -> m a -> m a + lookupVar :: Text -> m (Maybe t) -clearScopes :: forall v m e r. Scoped e v m => m r -> m r -clearScopes = local (set hasLens (emptyScopes @m @v)) +currentScopesReader + :: forall m t e . (MonadReader e m, Has e (Scopes m t)) => m (Scopes m t) +currentScopesReader = asks (view hasLens) -pushScope :: forall v m e r. Scoped e v m => AttrSet v -> m r -> m r +clearScopesReader + :: forall m t e a . (MonadReader e m, Has e (Scopes m t)) => m a -> m a +clearScopesReader = local (set hasLens (emptyScopes @m @t)) + +pushScope :: Scoped t m => AttrSet t -> m a -> m a pushScope s = pushScopes (Scopes [Scope s] []) -pushWeakScope :: forall v m e r. Scoped e v m => m (AttrSet v) -> m r -> m r +pushWeakScope :: (Functor m, Scoped t m) => m (AttrSet t) -> m a -> m a pushWeakScope s = pushScopes (Scopes [] [Scope <$> s]) -pushScopes :: Scoped e v m => Scopes m v -> m r -> m r -pushScopes s = local (over hasLens (s <>)) +pushScopesReader + :: (MonadReader e m, Has e (Scopes m t)) => Scopes m t -> m a -> m a +pushScopesReader s = local (over hasLens (s <>)) -lookupVar :: forall e v m. (Scoped e v m, Monad m) => Text -> m (Maybe v) -lookupVar k = do - mres <- asks (scopeLookup k . lexicalScopes @m . view hasLens) - case mres of - Just sym -> return $ Just sym - Nothing -> do - ws <- asks (dynamicScopes . view hasLens) - foldr (\x -> liftM2 (<|>) (M.lookup k . getScope <$> x)) - (return Nothing) ws +lookupVarReader + :: forall m t e . (MonadReader e m, Has e (Scopes m t)) => Text -> m (Maybe t) +lookupVarReader k = do + mres <- asks (scopeLookup k . lexicalScopes @m . view hasLens) + case mres of + Just sym -> return $ Just sym + Nothing -> do + ws <- asks (dynamicScopes . view hasLens) + foldr + (\x rest -> do + mres' <- M.lookup k . getScope <$> x + case mres' of + Just sym -> return $ Just sym + Nothing -> rest + ) + (return Nothing) + ws -withScopes :: forall v m e a. Scoped e v m => Scopes m v -> m a -> m a -withScopes scope = clearScopes @v . pushScopes scope +withScopes :: Scoped t m => Scopes m t -> m a -> m a +withScopes scope = clearScopes . pushScopes scope diff --git a/src/Nix/String.hs b/src/Nix/String.hs new file mode 100644 --- /dev/null +++ b/src/Nix/String.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} +module Nix.String + ( NixString + , principledGetContext + , principledMakeNixString + , principledMempty + , StringContext(..) + , ContextFlavor(..) + , NixLikeContext(..) + , NixLikeContextValue(..) + , toNixLikeContext + , fromNixLikeContext + , stringHasContext + , principledIntercalateNixString + , hackyGetStringNoContext + , principledGetStringNoContext + , principledStringIgnoreContext + , hackyStringIgnoreContext + , hackyMakeNixStringWithoutContext + , principledMakeNixStringWithoutContext + , principledMakeNixStringWithSingletonContext + , principledModifyNixContents + , principledStringMappend + , principledStringMempty + , principledStringMConcat + , WithStringContext + , WithStringContextT(..) + , extractNixString + , addStringContext + , addSingletonStringContext + , runWithStringContextT + , runWithStringContext + ) +where + +import Control.Monad.Writer +import Data.Functor.Identity +import qualified Data.HashMap.Lazy as M +import qualified Data.HashSet as S +import Data.Hashable +import Data.Text ( Text ) +import qualified Data.Text as Text +import GHC.Generics + +-- {-# WARNING hackyGetStringNoContext, hackyStringIgnoreContext, hackyMakeNixStringWithoutContext "This NixString function needs to be replaced" #-} + +-- | A 'ContextFlavor' describes the sum of possible derivations for string contexts +data ContextFlavor = + DirectPath + | AllOutputs + | DerivationOutput !Text + deriving (Show, Eq, Ord, Generic) + +instance Hashable ContextFlavor + +-- | A 'StringContext' ... +data StringContext = + StringContext { scPath :: !Text + , scFlavor :: !ContextFlavor + } deriving (Eq, Ord, Show, Generic) + +instance Hashable StringContext + +data NixString = NixString + { nsContents :: !Text + , nsContext :: !(S.HashSet StringContext) + } deriving (Eq, Ord, Show, Generic) + +instance Hashable NixString + +newtype NixLikeContext = NixLikeContext + { getNixLikeContext :: M.HashMap Text NixLikeContextValue + } deriving (Eq, Ord, Show, Generic) + +data NixLikeContextValue = NixLikeContextValue + { nlcvPath :: !Bool + , nlcvAllOutputs :: !Bool + , nlcvOutputs :: ![Text] + } deriving (Show, Eq, Ord, Generic) + +instance Semigroup NixLikeContextValue where + a <> b = NixLikeContextValue + { nlcvPath = nlcvPath a || nlcvPath b + , nlcvAllOutputs = nlcvAllOutputs a || nlcvAllOutputs b + , nlcvOutputs = nlcvOutputs a <> nlcvOutputs b + } + +instance Monoid NixLikeContextValue where + mempty = NixLikeContextValue False False [] + +toStringContexts :: (Text, NixLikeContextValue) -> [StringContext] +toStringContexts (path, nlcv) = case nlcv of + NixLikeContextValue True _ _ -> StringContext path DirectPath + : toStringContexts (path, nlcv { nlcvPath = False }) + NixLikeContextValue _ True _ -> StringContext path AllOutputs + : toStringContexts (path, nlcv { nlcvAllOutputs = False }) + NixLikeContextValue _ _ ls | not (null ls) -> + map (StringContext path . DerivationOutput) ls + _ -> [] + +toNixLikeContextValue :: StringContext -> (Text, NixLikeContextValue) +toNixLikeContextValue sc = (,) (scPath sc) $ case scFlavor sc of + DirectPath -> NixLikeContextValue True False [] + AllOutputs -> NixLikeContextValue False True [] + DerivationOutput t -> NixLikeContextValue False False [t] + +toNixLikeContext :: S.HashSet StringContext -> NixLikeContext +toNixLikeContext stringContext = NixLikeContext + $ S.foldr go mempty stringContext + where + go sc hm = + let (t, nlcv) = toNixLikeContextValue sc in M.insertWith (<>) t nlcv hm + +fromNixLikeContext :: NixLikeContext -> S.HashSet StringContext +fromNixLikeContext = + S.fromList . join . map toStringContexts . M.toList . getNixLikeContext + +principledGetContext :: NixString -> S.HashSet StringContext +principledGetContext = nsContext + +-- | Combine two NixStrings using mappend +principledMempty :: NixString +principledMempty = NixString "" mempty + +-- | Combine two NixStrings using mappend +principledStringMappend :: NixString -> NixString -> NixString +principledStringMappend (NixString s1 t1) (NixString s2 t2) = + NixString (s1 <> s2) (t1 <> t2) + +-- | Combine two NixStrings using mappend +hackyStringMappend :: NixString -> NixString -> NixString +hackyStringMappend (NixString s1 t1) (NixString s2 t2) = + NixString (s1 <> s2) (t1 <> t2) + +-- | Combine NixStrings with a separator +principledIntercalateNixString :: NixString -> [NixString] -> NixString +principledIntercalateNixString _ [] = principledMempty +principledIntercalateNixString _ [ns] = ns +principledIntercalateNixString sep nss = NixString contents ctx + where + contents = Text.intercalate (nsContents sep) (map nsContents nss) + ctx = S.unions (nsContext sep : map nsContext nss) + +-- | Combine NixStrings using mconcat +hackyStringMConcat :: [NixString] -> NixString +hackyStringMConcat = foldr hackyStringMappend (NixString mempty mempty) + +-- | Empty string with empty context. +principledStringMempty :: NixString +principledStringMempty = NixString mempty mempty + +-- | Combine NixStrings using mconcat +principledStringMConcat :: [NixString] -> NixString +principledStringMConcat = + foldr principledStringMappend (NixString mempty mempty) + +--instance Semigroup NixString where + --NixString s1 t1 <> NixString s2 t2 = NixString (s1 <> s2) (t1 <> t2) + +--instance Monoid NixString where +-- mempty = NixString mempty mempty +-- mappend = (<>) + +-- | Extract the string contents from a NixString that has no context +hackyGetStringNoContext :: NixString -> Maybe Text +hackyGetStringNoContext (NixString s c) | null c = Just s + | otherwise = Nothing + +-- | Extract the string contents from a NixString that has no context +principledGetStringNoContext :: NixString -> Maybe Text +principledGetStringNoContext (NixString s c) | null c = Just s + | otherwise = Nothing + +-- | Extract the string contents from a NixString even if the NixString has an associated context +principledStringIgnoreContext :: NixString -> Text +principledStringIgnoreContext (NixString s _) = s + +-- | Extract the string contents from a NixString even if the NixString has an associated context +hackyStringIgnoreContext :: NixString -> Text +hackyStringIgnoreContext (NixString s _) = s + +-- | Returns True if the NixString has an associated context +stringHasContext :: NixString -> Bool +stringHasContext (NixString _ c) = not (null c) + +-- | Constructs a NixString without a context +hackyMakeNixStringWithoutContext :: Text -> NixString +hackyMakeNixStringWithoutContext = flip NixString mempty + +-- | Constructs a NixString without a context +principledMakeNixStringWithoutContext :: Text -> NixString +principledMakeNixStringWithoutContext = flip NixString mempty + +-- | Modify the string part of the NixString, leaving the context unchanged +principledModifyNixContents :: (Text -> Text) -> NixString -> NixString +principledModifyNixContents f (NixString s c) = NixString (f s) c + +-- | Create a NixString using a singleton context +principledMakeNixStringWithSingletonContext + :: Text -> StringContext -> NixString +principledMakeNixStringWithSingletonContext s c = NixString s (S.singleton c) + +-- | Create a NixString from a Text and context +principledMakeNixString :: Text -> S.HashSet StringContext -> NixString +principledMakeNixString s c = NixString s c + +-- | A monad for accumulating string context while producing a result string. +newtype WithStringContextT m a = WithStringContextT (WriterT (S.HashSet StringContext) m a) + deriving (Functor, Applicative, Monad, MonadTrans, MonadWriter (S.HashSet StringContext)) + +type WithStringContext = WithStringContextT Identity + +-- | Add 'StringContext's into the resulting set. +addStringContext + :: Monad m => S.HashSet StringContext -> WithStringContextT m () +addStringContext = WithStringContextT . tell + +-- | Add a 'StringContext' into the resulting set. +addSingletonStringContext :: Monad m => StringContext -> WithStringContextT m () +addSingletonStringContext = WithStringContextT . tell . S.singleton + +-- | 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) = WithStringContextT $ tell c >> return s + +-- | 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 + +-- | Run an action producing a string with a context and put those into a 'NixString'. +runWithStringContext :: WithStringContextT Identity Text -> NixString +runWithStringContext = runIdentity . runWithStringContextT diff --git a/src/Nix/Strings.hs b/src/Nix/Strings.hs --- a/src/Nix/Strings.hs +++ b/src/Nix/Strings.hs @@ -4,27 +4,30 @@ -- | Functions for manipulating nix strings. module Nix.Strings where -import Data.List (intercalate, dropWhileEnd, inits) -import Data.Monoid ((<>)) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Tuple (swap) +import Data.List ( intercalate + , dropWhileEnd + , inits + ) +import Data.Monoid ( (<>) ) +import Data.Text ( Text ) +import qualified Data.Text as T +import Data.Tuple ( swap ) import Nix.Expr -- | Merge adjacent 'Plain' values with 'mappend'. mergePlain :: [Antiquoted Text r] -> [Antiquoted Text r] mergePlain [] = [] -mergePlain (Plain a: EscapedNewline : Plain b: xs) = - mergePlain (Plain (a <> "\n" <> b) : xs) -mergePlain (Plain a: Plain b: xs) = mergePlain (Plain (a <> b) : xs) -mergePlain (x:xs) = x : mergePlain xs +mergePlain (Plain a : EscapedNewline : Plain b : xs) = + mergePlain (Plain (a <> "\n" <> b) : xs) +mergePlain (Plain a : Plain b : xs) = mergePlain (Plain (a <> b) : xs) +mergePlain (x : xs) = x : mergePlain xs -- | 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 f (Plain x) = x /= mempty - f _ = True + f _ = True -- trimEnd xs -- | null xs = xs @@ -41,12 +44,12 @@ -- | 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 - (l : ls) = T.split (=='\n') t + go (Plain t : xs) = (Plain l :) <$> foldr f (go xs) ls where + (l : ls) = T.split (== '\n') t f prefix (finished, current) = ((Plain prefix : current) : finished, []) - go (Antiquoted a : xs) = (Antiquoted a :) <$> go xs + go (Antiquoted a : xs) = (Antiquoted a :) <$> go xs go (EscapedNewline : xs) = (EscapedNewline :) <$> go xs - go [] = ([],[]) + go [] = ([], []) -- | Join a stream of strings containing antiquotes again. This is the inverse -- of 'splitLines'. @@ -58,52 +61,53 @@ stripIndent [] = Indented 0 [] stripIndent xs = Indented minIndent - . removePlainEmpty - . mergePlain - . map snd - . dropWhileEnd cleanup - . (\ys -> zip (map (\case [] -> Nothing - x -> Just (last x)) - (inits ys)) ys) - . unsplitLines $ ls' - where - ls = stripEmptyOpening $ splitLines xs - ls' = map (dropSpaces minIndent) ls + . removePlainEmpty + . mergePlain + . map snd + . dropWhileEnd cleanup + . (\ys -> zip + (map + (\case + [] -> Nothing + x -> Just (last x) + ) + (inits ys) + ) + ys + ) + . unsplitLines + $ ls' + where + ls = stripEmptyOpening $ splitLines xs + ls' = map (dropSpaces minIndent) ls - minIndent = case stripEmptyLines ls of - [] -> 0 - nonEmptyLs -> minimum $ map (countSpaces . mergePlain) nonEmptyLs + minIndent = case stripEmptyLines ls of + [] -> 0 + nonEmptyLs -> minimum $ map (countSpaces . mergePlain) nonEmptyLs - stripEmptyLines = filter $ \case - [Plain t] -> not $ T.null $ T.strip t - _ -> True + stripEmptyLines = filter $ \case + [Plain t] -> not $ T.null $ T.strip t + _ -> True - stripEmptyOpening ([Plain t]:ts) | T.null (T.strip t) = ts - stripEmptyOpening ts = ts + stripEmptyOpening ([Plain t] : ts) | T.null (T.strip t) = ts + stripEmptyOpening ts = ts - countSpaces (Antiquoted _:_) = 0 - countSpaces (EscapedNewline:_) = 0 - countSpaces (Plain t : _) = T.length . T.takeWhile (== ' ') $ t - countSpaces [] = 0 + countSpaces (Antiquoted _ : _) = 0 + countSpaces (EscapedNewline : _) = 0 + countSpaces (Plain t : _) = T.length . T.takeWhile (== ' ') $ t + countSpaces [] = 0 - dropSpaces 0 x = x - dropSpaces n (Plain t : cs) = Plain (T.drop n t) : cs - dropSpaces _ _ = error "stripIndent: impossible" + dropSpaces 0 x = x + dropSpaces n (Plain t : cs) = Plain (T.drop n t) : cs + dropSpaces _ _ = error "stripIndent: impossible" - cleanup (Nothing, Plain y) = T.all (== ' ') y - cleanup (Just (Plain x), Plain y) - | "\n" `T.isSuffixOf` x = T.all (== ' ') y - cleanup _ = False + cleanup (Nothing, Plain y) = T.all (== ' ') y + cleanup (Just (Plain x), Plain y) | "\n" `T.isSuffixOf` x = T.all (== ' ') y + cleanup _ = False escapeCodes :: [(Char, Char)] escapeCodes = - [ ('\n', 'n' ) - , ('\r', 'r' ) - , ('\t', 't' ) - , ('\\', '\\') - , ('$' , '$' ) - , ('"', '"') - ] + [('\n', 'n'), ('\r', 'r'), ('\t', 't'), ('\\', '\\'), ('$', '$'), ('"', '"')] fromEscapeCode :: Char -> Maybe Char fromEscapeCode = (`lookup` map swap escapeCodes) diff --git a/src/Nix/TH.hs b/src/Nix/TH.hs --- a/src/Nix/TH.hs +++ b/src/Nix/TH.hs @@ -9,11 +9,14 @@ module Nix.TH where import Data.Fix -import Data.Foldable import Data.Generics.Aliases -import Data.Set (Set) -import qualified Data.Set as Set -import qualified Data.Text as Text +import Data.Set ( Set + , (\\) + ) +import qualified Data.Set as Set +import qualified Data.Text as Text +import Data.List.NonEmpty ( NonEmpty(..) ) +import Data.Maybe ( mapMaybe ) import Language.Haskell.TH import Language.Haskell.TH.Quote import Nix.Atoms @@ -22,53 +25,103 @@ quoteExprExp :: String -> ExpQ quoteExprExp s = do - expr <- case parseNixTextLoc (Text.pack s) of - Failure err -> fail $ show err - Success e -> return e - dataToExpQ (const Nothing `extQ` metaExp (freeVars expr)) expr + expr <- case parseNixText (Text.pack s) of + Failure err -> fail $ show err + Success e -> return e + dataToExpQ (const Nothing `extQ` metaExp (freeVars expr)) expr quoteExprPat :: String -> PatQ quoteExprPat s = do - expr <- case parseNixTextLoc (Text.pack s) of - Failure err -> fail $ show err - Success e -> return e - dataToPatQ (const Nothing `extQ` metaPat (freeVars expr)) expr + expr <- case parseNixText (Text.pack s) of + Failure err -> fail $ show err + Success e -> return e + dataToPatQ (const Nothing `extQ` metaPat (freeVars expr)) expr -freeVars :: NExprLoc -> Set VarName -freeVars = cata $ \case - NSym_ _ var -> Set.singleton var - Compose (Ann _ x) -> fold x +freeVars :: NExpr -> Set VarName +freeVars e = case unFix e of + (NConstant _ ) -> Set.empty + (NStr string ) -> foldMap freeVars string + (NSym var ) -> Set.singleton var + (NList list ) -> foldMap freeVars list + (NSet bindings) -> foldMap bindFree bindings + (NRecSet bindings) -> foldMap bindFree bindings \\ foldMap bindDefs bindings + (NLiteralPath _ ) -> Set.empty + (NEnvPath _ ) -> Set.empty + (NUnary _ expr ) -> freeVars expr + (NBinary _ left right ) -> freeVars left `Set.union` freeVars right + (NSelect expr path orExpr) -> + freeVars expr + `Set.union` pathFree path + `Set.union` maybe Set.empty freeVars orExpr + (NHasAttr expr path) -> freeVars expr `Set.union` 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 + `Set.union` Set.unions (mapMaybe (fmap freeVars . snd) set) + -- But remove the argument name if existing, and all arguments in the parameter set + \\ maybe Set.empty Set.singleton varname + \\ Set.fromList (map fst set) + (NLet bindings expr) -> + freeVars expr + `Set.union` foldMap bindFree bindings + \\ foldMap bindDefs bindings + (NIf cond th el) -> + freeVars cond `Set.union` freeVars th `Set.union` freeVars 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) -> freeVars set `Set.union` freeVars expr + (NAssert assertion expr) -> freeVars assertion `Set.union` freeVars expr + (NSynHole _ ) -> Set.empty + where + + staticKey :: NKeyName r -> Maybe VarName + staticKey (StaticKey varname) = Just varname + staticKey (DynamicKey _ ) = Nothing + + bindDefs :: Binding r -> Set VarName + bindDefs (Inherit Nothing _ _) = Set.empty + bindDefs (Inherit (Just _) keys _) = Set.fromList $ mapMaybe staticKey keys + bindDefs (NamedVar (StaticKey varname :| _) _ _) = Set.singleton varname + bindDefs (NamedVar (DynamicKey _ :| _) _ _) = Set.empty + + bindFree :: Binding NExpr -> Set VarName + bindFree (Inherit Nothing keys _) = Set.fromList $ mapMaybe staticKey keys + bindFree (Inherit (Just scope) _ _) = freeVars scope + bindFree (NamedVar path expr _) = pathFree path `Set.union` freeVars expr + + pathFree :: NAttrPath NExpr -> Set VarName + pathFree = foldMap (foldMap freeVars) + + class ToExpr a where toExpr :: a -> NExprLoc instance ToExpr NExprLoc where - toExpr = id + toExpr = id instance ToExpr VarName where - toExpr = Fix . NSym_ nullSpan + toExpr = Fix . NSym_ nullSpan instance ToExpr Int where - toExpr = Fix . NConstant_ nullSpan . NInt . fromIntegral + toExpr = Fix . NConstant_ nullSpan . NInt . fromIntegral instance ToExpr Integer where - toExpr = Fix . NConstant_ nullSpan . NInt + toExpr = Fix . NConstant_ nullSpan . NInt instance ToExpr Float where - toExpr = Fix . NConstant_ nullSpan . NFloat + toExpr = Fix . NConstant_ nullSpan . NFloat metaExp :: Set VarName -> NExprLoc -> Maybe ExpQ metaExp fvs (Fix (NSym_ _ x)) | x `Set.member` fvs = - Just [| toExpr $(varE (mkName (Text.unpack x))) |] + Just [| toExpr $(varE (mkName (Text.unpack x))) |] metaExp _ _ = Nothing metaPat :: Set VarName -> NExprLoc -> Maybe PatQ metaPat fvs (Fix (NSym_ _ x)) | x `Set.member` fvs = - Just (varP (mkName (Text.unpack x))) + Just (varP (mkName (Text.unpack x))) metaPat _ _ = Nothing nix :: QuasiQuoter -nix = QuasiQuoter - { quoteExp = quoteExprExp - , quotePat = quoteExprPat - } +nix = QuasiQuoter { quoteExp = quoteExprExp, quotePat = quoteExprPat } diff --git a/src/Nix/Thunk.hs b/src/Nix/Thunk.hs --- a/src/Nix/Thunk.hs +++ b/src/Nix/Thunk.hs @@ -1,111 +1,51 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE CPP #-} - -#if ENABLE_TRACING -{-# LANGUAGE BangPatterns #-} -#endif - +{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Nix.Thunk where -import Control.Exception -import Control.Monad.Catch -import Data.Typeable - -#if ENABLE_TRACING -import Data.IORef -import System.IO.Unsafe -import Nix.Utils - -counter :: IORef Int -counter = unsafePerformIO $ newIORef 0 -{-# NOINLINE counter #-} -#endif - -data Deferred m v = Deferred (m v) | Computed v - deriving (Functor, Foldable, Traversable) +import Control.Exception ( Exception ) +import Control.Monad.Trans.Class ( MonadTrans(..) ) +import Data.Typeable ( Typeable ) -class Monad m => MonadVar m where - type Var m :: * -> * - newVar :: a -> m (Var m a) - readVar :: Var m a -> m a - writeVar :: Var m a -> a -> m () - atomicModifyVar :: Var m a -> (a -> (a, b)) -> m b +class ( Monad m + , Eq (ThunkId m) + , Ord (ThunkId m) + , Show (ThunkId m) + , Typeable (ThunkId m) + ) + => MonadThunkId m where + type ThunkId m :: * + freshId :: m (ThunkId m) + default freshId + :: ( MonadThunkId m' + , MonadTrans t + , m ~ t m' + , ThunkId m ~ ThunkId m' + ) + => m (ThunkId m) + freshId = lift freshId -class Monad m => MonadThunk v t m | v -> m, v -> t, t -> m, t -> v where +class MonadThunkId m => MonadThunk t m v | t -> m, t -> v where thunk :: m v -> m t + -- | Return an identifier for the thunk unless it is a pure value (i.e., + -- strictly an encapsulation of some 'v' without any additional + -- structure). For pure values represented as thunks, returns Nothing. + thunkId :: t -> Maybe (ThunkId m) + query :: t -> r -> (v -> r) -> r + queryM :: t -> m r -> (v -> m r) -> m r force :: t -> (v -> m r) -> m r - value :: v -> t + forceEff :: t -> (v -> m r) -> m r + wrapValue :: v -> t + getValue :: t -> Maybe v -data Thunk m v - = Value v - | Thunk Int (Var m Bool) (Var m (Deferred m v)) +newtype ThunkLoop = ThunkLoop String -- contains rendering of ThunkId + deriving Typeable -newtype ThunkLoop = ThunkLoop (Maybe Int) - deriving (Show, Typeable) +instance Show ThunkLoop where + show (ThunkLoop i) = "ThunkLoop " ++ i instance Exception ThunkLoop - -valueRef :: v -> Thunk m v -valueRef = Value - -buildThunk :: MonadVar m => m v -> m (Thunk m v) -buildThunk action = -#if ENABLE_TRACING - let !x = unsafePerformIO (atomicModifyIORef' counter (\c -> (succ c, c))) in - Thunk x -#else - Thunk 0 -#endif - <$> newVar False <*> newVar (Deferred action) - -forceThunk :: (MonadVar m, MonadThrow m) => Thunk m v -> (v -> m a) -> m a -forceThunk (Value ref) k = k ref -#if ENABLE_TRACING -forceThunk (Thunk n active ref) k = do -#else -forceThunk (Thunk _ active ref) k = do -#endif - eres <- readVar ref - case eres of - Computed v -> k v - Deferred action -> do - nowActive <- atomicModifyVar active (True,) - if nowActive - then -#if ENABLE_TRACING - throwM $ ThunkLoop (Just n) -#else - throwM $ ThunkLoop Nothing -#endif - else do -#if ENABLE_TRACING - traceM $ "Forcing " ++ show n -#endif - v <- action - writeVar ref (Computed v) - _ <- atomicModifyVar active (False,) - k v - -forceEffects :: MonadVar m => Thunk m v -> (v -> m a) -> m a -forceEffects (Value ref) k = k ref -forceEffects (Thunk _ active ref) k = do - nowActive <- atomicModifyVar active (True,) - if nowActive - then return $ error "forceEffects: a value was expected" - else do - eres <- readVar ref - case eres of - Computed v -> k v - Deferred action -> do - v <- action - writeVar ref (Computed v) - _ <- atomicModifyVar active (False,) - k v diff --git a/src/Nix/Thunk/Basic.hs b/src/Nix/Thunk/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Nix/Thunk/Basic.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Nix.Thunk.Basic (NThunkF(..), Deferred(..), MonadBasicThunk) where + +import Control.Exception hiding ( catch ) +import Control.Monad.Catch + +import Nix.Thunk +import Nix.Utils +import Nix.Var + +data Deferred m v = Deferred (m v) | Computed v + deriving (Functor, Foldable, Traversable) + +-- | The type of very basic thunks +data NThunkF m v + = Value v + | Thunk (ThunkId m) (Var m Bool) (Var m (Deferred m v)) + +instance (Eq v, Eq (ThunkId m)) => Eq (NThunkF m v) where + Value x == Value y = x == y + Thunk x _ _ == Thunk y _ _ = x == y + _ == _ = False -- jww (2019-03-16): not accurate... + +instance Show v => Show (NThunkF m v) where + show (Value v ) = show v + show (Thunk _ _ _) = "" + +type MonadBasicThunk m = (MonadThunkId m, MonadVar m) + +instance (MonadBasicThunk m, MonadCatch m) + => MonadThunk (NThunkF m v) m v where + thunk = buildThunk + thunkId = \case + Value _ -> Nothing + Thunk n _ _ -> Just n + query = queryValue + queryM = queryThunk + force = forceThunk + forceEff = forceEffects + wrapValue = valueRef + getValue = thunkValue + +valueRef :: v -> NThunkF m v +valueRef = Value + +thunkValue :: NThunkF m v -> Maybe v +thunkValue (Value v) = Just v +thunkValue _ = Nothing + +buildThunk :: MonadBasicThunk m => m v -> m (NThunkF m v) +buildThunk action = do + freshThunkId <- freshId + Thunk freshThunkId <$> newVar False <*> newVar (Deferred action) + +queryValue :: MonadVar m => NThunkF m v -> a -> (v -> a) -> a +queryValue (Value v) _ k = k v +queryValue _ n _ = n + +queryThunk :: MonadVar m => NThunkF m v -> m a -> (v -> m a) -> m a +queryThunk (Value v ) _ k = k v +queryThunk (Thunk _ active ref) n k = do + nowActive <- atomicModifyVar active (True, ) + if nowActive + then n + else do + eres <- readVar ref + res <- case eres of + Computed v -> k v + _ -> n + _ <- atomicModifyVar active (False, ) + return res + +forceThunk + :: forall m v a + . (MonadVar m, MonadThrow m, MonadCatch m, Show (ThunkId m)) + => NThunkF m v + -> (v -> m a) + -> m a +forceThunk (Value v ) k = k v +forceThunk (Thunk n active ref) k = do + eres <- readVar ref + case eres of + Computed v -> k v + Deferred action -> do + nowActive <- atomicModifyVar active (True, ) + if nowActive + then throwM $ ThunkLoop $ show n + else do + traceM $ "Forcing " ++ show n + v <- catch action $ \(e :: SomeException) -> do + _ <- atomicModifyVar active (False, ) + throwM e + _ <- atomicModifyVar active (False, ) + writeVar ref (Computed v) + k v + +forceEffects :: MonadVar m => NThunkF m v -> (v -> m r) -> m r +forceEffects (Value v ) k = k v +forceEffects (Thunk _ active ref) k = do + nowActive <- atomicModifyVar active (True, ) + if nowActive + then return $ error "Loop detected" + else do + eres <- readVar ref + case eres of + Computed v -> k v + Deferred action -> do + v <- action + writeVar ref (Computed v) + _ <- atomicModifyVar active (False, ) + k v diff --git a/src/Nix/Thunk/Standard.hs b/src/Nix/Thunk/Standard.hs new file mode 100644 --- /dev/null +++ b/src/Nix/Thunk/Standard.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Nix.Thunk.Standard where + +import Control.Comonad ( Comonad ) +import Control.Comonad.Env ( ComonadEnv ) +import Control.Monad.Catch hiding ( catchJust ) +import Control.Monad.Reader +import Control.Monad.Ref +import Data.Typeable +import GHC.Generics +import Nix.Cited +import Nix.Cited.Basic +import Nix.Exec +import Nix.Fresh +import Nix.Fresh.Basic +import Nix.Options +import Nix.Thunk +import Nix.Thunk.Basic +import Nix.Value +import Nix.Var + +newtype StdThunk (u :: (* -> *) -> * -> *) (m :: * -> *) = StdThunk + { _stdThunk :: StdCited u m (NThunkF (StdLazy u m) (StdValue u m)) } + +newtype StdCited u m a = StdCited + { _stdCited :: Cited (StdThunk u m) (StdCited u m) (StdLazy u m) a } + deriving + ( Generic + , Typeable + , Functor + , Applicative + , Foldable + , Traversable + , Comonad + , ComonadEnv [Provenance (StdThunk u m) (StdLazy u m) (StdValue u m)] + ) + +type StdValue u m = NValue (StdThunk u m) (StdCited u m) (StdLazy u m) +type StdValueNF u m = NValueNF (StdThunk u m) (StdCited u m) (StdLazy u m) +-- type StdIdT m = FreshIdT Int m + +type StdLazy u m = Lazy (StdThunk u m) (StdCited u m) (u m) + +instance Show (StdThunk u m) where + show _ = "" -- jww (2019-03-15): NYI + +type MonadStdThunk m + = (MonadVar m, MonadCatch m, MonadThrow m, Typeable m, MonadAtomicRef m) + +instance ( MonadStdThunk (u m) + , MonadThunkId (u m) + , MonadTrans u + , Typeable u + , Typeable m + ) + => MonadThunk (StdThunk u m) (StdLazy u m) (StdValue u m) where + thunk = fmap (StdThunk . StdCited) . thunk + thunkId = thunkId . _stdCited . _stdThunk + query x b f = query (_stdCited (_stdThunk x)) b f + queryM x b f = queryM (_stdCited (_stdThunk x)) b f + force = force . _stdCited . _stdThunk + forceEff = forceEff . _stdCited . _stdThunk + wrapValue = StdThunk . StdCited . wrapValue + getValue = getValue . _stdCited . _stdThunk + +instance HasCitations1 (StdThunk u m) (StdLazy u m) (StdValue u m) (StdCited u m) where + citations1 (StdCited c) = citations1 c + addProvenance1 x (StdCited c) = StdCited (addProvenance1 x c) + +runStdLazyM + :: (MonadVar m, MonadIO m, MonadIO (u m)) + => Options + -> (u m a -> m a) + -> StdLazy u m a + -> m a +runStdLazyM opts run action = run $ runLazyM opts action + +type StandardThunk m = StdThunk StdIdT m +type StandardValue m = StdValue StdIdT m +type StandardValueNF m = StdValueNF StdIdT m +type StandardT m = StdLazy StdIdT m + +runStandard :: (MonadVar m, MonadIO m) => Options -> StdLazy StdIdT m a -> m a +runStandard opts action = do + i <- newVar (1 :: Int) + runStdLazyM opts (runFreshIdT i) action + +runStandardIO :: Options -> StdLazy StdIdT IO a -> IO a +runStandardIO = runStandard 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,20 +1,21 @@ -module Nix.Type.Assumption ( - Assumption(..), - empty, - lookup, - remove, - extend, - keys, - merge, - mergeAssumptions, - singleton, -) where +module Nix.Type.Assumption + ( Assumption(..) + , empty + , lookup + , remove + , extend + , keys + , merge + , mergeAssumptions + , singleton + ) +where -import Prelude hiding (lookup) +import Prelude hiding ( lookup ) -import Nix.Type.Type +import Nix.Type.Type -import Data.Foldable +import Data.Foldable newtype Assumption = Assumption { assumptions :: [(Name, Type)] } deriving (Eq, Show) 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,25 +1,25 @@ -module Nix.Type.Env ( - Env(..), - empty, - lookup, - remove, - extend, - extends, - merge, - mergeEnvs, - singleton, - keys, - fromList, - toList, -) where +module Nix.Type.Env + ( Env(..) + , empty + , lookup + , remove + , extend + , extends + , merge + , mergeEnvs + , singleton + , keys + , fromList + , toList + ) +where -import Prelude hiding (lookup) +import Prelude hiding ( lookup ) import Nix.Type.Type -import Data.Foldable hiding (toList) -import qualified Data.Map as Map -import Data.Semigroup +import Data.Foldable hiding ( toList ) +import qualified Data.Map as Map ------------------------------------------------------------------------------- -- Typing Environment @@ -38,8 +38,7 @@ remove (TypeEnv env) var = TypeEnv (Map.delete var env) extends :: Env -> [(Name, [Scheme])] -> Env -extends env xs = - env { types = Map.union (Map.fromList xs) (types env) } +extends env xs = env { types = Map.union (Map.fromList xs) (types env) } lookup :: Name -> Env -> Maybe [Scheme] lookup key (TypeEnv tys) = Map.lookup key tys @@ -66,5 +65,5 @@ (<>) = merge instance Monoid Env where - mempty = empty + mempty = empty mappend = merge 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,3 +1,5 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -9,66 +11,92 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} -module Nix.Type.Infer ( - Constraint(..), - TypeError(..), - InferError(..), - Subst(..), - inferTop -) where +module Nix.Type.Infer + ( Constraint(..) + , TypeError(..) + , InferError(..) + , Subst(..) + , inferTop + ) +where import Control.Applicative import Control.Arrow import Control.Monad.Catch import Control.Monad.Except +import Control.Monad.Fail import Control.Monad.Logic import Control.Monad.Reader +import Control.Monad.Ref import Control.Monad.ST -import Control.Monad.State +import Control.Monad.State.Strict import Data.Fix import Data.Foldable -import qualified Data.HashMap.Lazy as M -import Data.List (delete, find, nub, intersect, (\\)) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe (fromJust) -import Data.STRef -import Data.Semigroup -import qualified Data.Set as Set -import Data.Text (Text) +import qualified Data.HashMap.Lazy as M +import Data.List ( delete + , find + , nub + , intersect + , (\\) + ) +import Data.Map ( Map ) +import qualified Data.Map as Map +import Data.Maybe ( fromJust ) +import qualified Data.Set as Set +import Data.Text ( Text ) import Nix.Atoms import Nix.Convert -import Nix.Eval (MonadEval(..)) -import qualified Nix.Eval as Eval +import Nix.Eval ( MonadEval(..) ) +import qualified Nix.Eval as Eval import Nix.Expr.Types import Nix.Expr.Types.Annotated +import Nix.Fresh +import Nix.String import Nix.Scope import Nix.Thunk -import qualified Nix.Type.Assumption as As +import Nix.Thunk.Basic +import qualified Nix.Type.Assumption as As import Nix.Type.Env -import qualified Nix.Type.Env as Env +import qualified Nix.Type.Env as Env import Nix.Type.Type import Nix.Utils +import Nix.Var ------------------------------------------------------------------------------- -- Classes ------------------------------------------------------------------------------- -- | Inference monad -newtype Infer s a = Infer +newtype InferT s m a = InferT { getInfer :: - ReaderT (Set.Set TVar, Scopes (Infer s) (JThunk s)) - (StateT InferState (ExceptT InferError (ST s))) a + ReaderT (Set.Set TVar, Scopes (InferT s m) (JThunkT s m)) + (StateT InferState (ExceptT InferError m)) a } - deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadFix, - MonadReader (Set.Set TVar, Scopes (Infer s) (JThunk s)), - MonadState InferState, MonadError InferError) + deriving + ( Functor + , Applicative + , Alternative + , Monad + , MonadPlus + , MonadFix + , MonadReader (Set.Set TVar, Scopes (InferT s m) (JThunkT s m)) + , MonadFail + , MonadState InferState + , MonadError InferError + ) +instance MonadTrans (InferT s) where + lift = InferT . lift . lift . lift + +instance MonadThunkId m => MonadThunkId (InferT s m) where + type ThunkId (InferT s m) = ThunkId m + -- | Inference state newtype InferState = InferState { count :: Int } @@ -90,25 +118,27 @@ instance Substitutable TVar where apply (Subst s) a = tv - where t = TVar a - (TVar tv) = Map.findWithDefault t a s + where + t = TVar a + (TVar tv) = Map.findWithDefault t a s instance Substitutable Type where - apply _ (TCon a) = TCon a - apply s (TSet b a) = TSet b (M.map (apply s) a) - apply s (TList a) = TList (map (apply s) a) - apply (Subst s) t@(TVar a) = Map.findWithDefault t a s - apply s (t1 :~> t2) = apply s t1 :~> apply s t2 - apply s (TMany ts) = TMany (map (apply s) ts) + apply _ ( TCon a ) = TCon a + apply s ( TSet b a ) = TSet b (M.map (apply s) a) + apply s ( TList a ) = TList (map (apply s) a) + apply (Subst s) t@(TVar a ) = Map.findWithDefault t a s + apply s ( t1 :~> t2) = apply s t1 :~> apply s t2 + apply s ( TMany ts ) = TMany (map (apply s) ts) instance Substitutable Scheme where apply (Subst s) (Forall as t) = Forall as $ apply s' t where 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 (ExpInstConst t sc) = ExpInstConst (apply s t) (apply s sc) - apply s (ImpInstConst t1 ms t2) = ImpInstConst (apply s t1) (apply s ms) (apply s t2) + apply s (EqConst t1 t2) = EqConst (apply s t1) (apply s t2) + apply s (ExpInstConst t sc) = ExpInstConst (apply s t) (apply s sc) + apply s (ImpInstConst t1 ms t2) = + ImpInstConst (apply s t1) (apply s ms) (apply s t2) instance Substitutable a => Substitutable [a] where apply = map . apply @@ -122,11 +152,11 @@ instance FreeTypeVars Type where ftv TCon{} = Set.empty - ftv (TVar a) = Set.singleton a - ftv (TSet _ a) = Set.unions (map ftv (M.elems a)) - ftv (TList a) = Set.unions (map ftv a) + ftv (TVar a ) = Set.singleton a + ftv (TSet _ a ) = Set.unions (map ftv (M.elems a)) + ftv (TList a ) = Set.unions (map ftv a) ftv (t1 :~> t2) = ftv t1 `Set.union` ftv t2 - ftv (TMany ts) = Set.unions (map ftv ts) + ftv (TMany ts ) = Set.unions (map ftv ts) instance FreeTypeVars TVar where ftv = Set.singleton @@ -135,19 +165,20 @@ ftv (Forall as t) = ftv t `Set.difference` Set.fromList as instance FreeTypeVars a => FreeTypeVars [a] where - ftv = foldr (Set.union . ftv) Set.empty + ftv = foldr (Set.union . ftv) Set.empty instance (Ord a, FreeTypeVars a) => FreeTypeVars (Set.Set a) where - ftv = foldr (Set.union . ftv) Set.empty + ftv = foldr (Set.union . ftv) Set.empty class ActiveTypeVars a where atv :: a -> Set.Set TVar instance ActiveTypeVars Constraint where - atv (EqConst t1 t2) = ftv t1 `Set.union` ftv t2 - atv (ImpInstConst t1 ms t2) = ftv t1 `Set.union` (ftv ms `Set.intersection` ftv t2) - atv (ExpInstConst t s) = ftv t `Set.union` ftv s + atv (EqConst t1 t2) = ftv t1 `Set.union` ftv t2 + atv (ImpInstConst t1 ms t2) = + ftv t1 `Set.union` (ftv ms `Set.intersection` ftv t2) + atv (ExpInstConst t s) = ftv t `Set.union` ftv s instance ActiveTypeVars a => ActiveTypeVars [a] where atv = foldr (Set.union . atv) Set.empty @@ -172,270 +203,322 @@ instance Exception InferError instance Semigroup InferError where - x <> _ = x + x <> _ = x instance Monoid InferError where - mempty = TypeInferenceAborted - mappend = (<>) + mempty = TypeInferenceAborted + mappend = (<>) ------------------------------------------------------------------------------- -- Inference ------------------------------------------------------------------------------- -- | Run the inference monad -runInfer' :: Infer s a -> ST s (Either InferError a) -runInfer' = runExceptT - . (`evalStateT` initInfer) - . (`runReaderT` (Set.empty, emptyScopes)) - . getInfer +runInfer' :: MonadInfer m => InferT s m a -> m (Either InferError a) +runInfer' = + runExceptT + . (`evalStateT` initInfer) + . (`runReaderT` (Set.empty, emptyScopes)) + . getInfer -runInfer :: (forall s. Infer s a) -> Either InferError a -runInfer m = runST (runInfer' m) +runInfer :: (forall s . InferT s (FreshIdT Int (ST s)) a) -> Either InferError a +runInfer m = runST $ do + i <- newVar (1 :: Int) + runFreshIdT i (runInfer' m) -inferType :: Env -> NExpr -> Infer s [(Subst, Type)] +inferType + :: forall s m . MonadInfer m => Env -> NExpr -> InferT s m [(Subst, Type)] inferType env ex = do Judgment as cs t <- infer ex - let unbounds = Set.fromList (As.keys as) `Set.difference` - Set.fromList (Env.keys env) - unless (Set.null unbounds) $ - typeError $ UnboundVariables (nub (Set.toList unbounds)) - let cs' = [ ExpInstConst t s - | (x, ss) <- Env.toList env - , s <- ss - , t <- As.lookup x as] + let unbounds = + Set.fromList (As.keys as) `Set.difference` Set.fromList (Env.keys env) + unless (Set.null unbounds) $ typeError $ UnboundVariables + (nub (Set.toList unbounds)) + let cs' = + [ ExpInstConst t s + | (x, ss) <- Env.toList env + , s <- ss + , t <- As.lookup x as + ] inferState <- get let eres = (`evalState` inferState) $ runSolver $ do - subst <- solve (cs ++ cs') - return (subst, subst `apply` t) + subst <- solve (cs ++ cs') + return (subst, subst `apply` t) case eres of - Left errs -> throwError $ TypeInferenceErrors errs - Right xs -> pure xs + Left errs -> throwError $ TypeInferenceErrors errs + Right xs -> pure xs -- | Solve for the toplevel type of an expression in a given environment inferExpr :: Env -> NExpr -> Either InferError [Scheme] inferExpr env ex = case runInfer (inferType env ex) of - Left err -> Left err - Right xs -> Right $ map (\(subst, ty) -> closeOver (subst `apply` ty)) xs + Left err -> Left err + Right xs -> Right $ map (\(subst, ty) -> closeOver (subst `apply` ty)) xs -- | Canonicalize and return the polymorphic toplevel type. closeOver :: Type -> Scheme closeOver = normalize . generalize Set.empty -extendMSet :: TVar -> Infer s a -> Infer s a -extendMSet x = Infer . local (first (Set.insert x)) . getInfer +extendMSet :: Monad m => TVar -> InferT s m a -> InferT s m a +extendMSet x = InferT . local (first (Set.insert x)) . getInfer letters :: [String] -letters = [1..] >>= flip replicateM ['a'..'z'] +letters = [1 ..] >>= flip replicateM ['a' .. 'z'] +freshTVar :: MonadState InferState m => m TVar +freshTVar = do + s <- get + put s { count = count s + 1 } + return $ TV (letters !! count s) + fresh :: MonadState InferState m => m Type -fresh = do - s <- get - put s{count = count s + 1} - return $ TVar $ TV (letters !! count s) +fresh = TVar <$> freshTVar instantiate :: MonadState InferState m => Scheme -> m Type instantiate (Forall as t) = do - as' <- mapM (const fresh) as - let s = Subst $ Map.fromList $ zip as as' - return $ apply s t + as' <- mapM (const fresh) as + let s = Subst $ Map.fromList $ zip as as' + return $ apply s t generalize :: Set.Set TVar -> Type -> Scheme -generalize free t = Forall as t - where as = Set.toList $ ftv t `Set.difference` free +generalize free t = Forall as t + where as = Set.toList $ ftv t `Set.difference` free unops :: Type -> NUnaryOp -> [Constraint] unops u1 = \case - NNot -> [ EqConst u1 (typeFun [typeBool, typeBool]) ] - NNeg -> [ EqConst u1 (TMany [ typeFun [typeInt, typeInt] - , typeFun [typeFloat, typeFloat] ]) ] + NNot -> [EqConst u1 (typeFun [typeBool, typeBool])] + NNeg -> + [ EqConst + u1 + (TMany [typeFun [typeInt, typeInt], typeFun [typeFloat, typeFloat]]) + ] binops :: Type -> NBinaryOp -> [Constraint] binops u1 = \case - NApp -> [] -- this is handled separately + NApp -> [] -- this is handled separately - -- Equality tells you nothing about the types, because any two types are - -- allowed. - NEq -> [] - NNEq -> [] + -- Equality tells you nothing about the types, because any two types are + -- allowed. + NEq -> [] + NNEq -> [] - NGt -> inequality - NGte -> inequality - NLt -> inequality - NLte -> inequality + NGt -> inequality + NGte -> inequality + NLt -> inequality + NLte -> inequality - NAnd -> [ EqConst u1 (typeFun [typeBool, typeBool, typeBool]) ] - NOr -> [ EqConst u1 (typeFun [typeBool, typeBool, typeBool]) ] - NImpl -> [ EqConst u1 (typeFun [typeBool, typeBool, typeBool]) ] + NAnd -> [EqConst u1 (typeFun [typeBool, typeBool, typeBool])] + NOr -> [EqConst u1 (typeFun [typeBool, typeBool, typeBool])] + NImpl -> [EqConst u1 (typeFun [typeBool, typeBool, typeBool])] - NConcat -> [ EqConst u1 (TMany [ typeFun [typeList, typeList, typeList] - , typeFun [typeList, typeNull, typeList] - , typeFun [typeNull, typeList, typeList] - ]) ] + NConcat -> + [ EqConst + u1 + (TMany + [ typeFun [typeList, typeList, typeList] + , typeFun [typeList, typeNull, typeList] + , typeFun [typeNull, typeList, typeList] + ] + ) + ] - NUpdate -> [ EqConst u1 (TMany [ typeFun [typeSet, typeSet, typeSet] - , typeFun [typeSet, typeNull, typeSet] - , typeFun [typeNull, typeSet, typeSet] - ]) ] + NUpdate -> + [ EqConst + u1 + (TMany + [ typeFun [typeSet, typeSet, typeSet] + , typeFun [typeSet, typeNull, typeSet] + , typeFun [typeNull, typeSet, typeSet] + ] + ) + ] - NPlus -> [ EqConst u1 (TMany [ typeFun [typeInt, typeInt, typeInt] - , typeFun [typeFloat, typeFloat, typeFloat] - , typeFun [typeInt, typeFloat, typeFloat] - , typeFun [typeFloat, typeInt, typeFloat] - , typeFun [typeString, typeString, typeString] - , typeFun [typePath, typePath, typePath] - , typeFun [typeString, typeString, typePath] - ]) ] - NMinus -> arithmetic - NMult -> arithmetic - NDiv -> arithmetic - where - inequality = - [ EqConst u1 (TMany [ typeFun [typeInt, typeInt, typeBool] - , typeFun [typeFloat, typeFloat, typeBool] - , typeFun [typeInt, typeFloat, typeBool] - , typeFun [typeFloat, typeInt, typeBool] - ]) ] + NPlus -> + [ EqConst + u1 + (TMany + [ typeFun [typeInt, typeInt, typeInt] + , typeFun [typeFloat, typeFloat, typeFloat] + , typeFun [typeInt, typeFloat, typeFloat] + , typeFun [typeFloat, typeInt, typeFloat] + , typeFun [typeString, typeString, typeString] + , typeFun [typePath, typePath, typePath] + , typeFun [typeString, typeString, typePath] + ] + ) + ] + NMinus -> arithmetic + NMult -> arithmetic + NDiv -> arithmetic + where + inequality = + [ EqConst + u1 + (TMany + [ typeFun [typeInt, typeInt, typeBool] + , typeFun [typeFloat, typeFloat, typeBool] + , typeFun [typeInt, typeFloat, typeBool] + , typeFun [typeFloat, typeInt, typeBool] + ] + ) + ] - arithmetic = - [ EqConst u1 (TMany [ typeFun [typeInt, typeInt, typeInt] - , typeFun [typeFloat, typeFloat, typeFloat] - , typeFun [typeInt, typeFloat, typeFloat] - , typeFun [typeFloat, typeInt, typeFloat] - ]) ] + arithmetic = + [ EqConst + u1 + (TMany + [ typeFun [typeInt, typeInt, typeInt] + , typeFun [typeFloat, typeFloat, typeFloat] + , typeFun [typeInt, typeFloat, typeFloat] + , typeFun [typeFloat, typeInt, typeFloat] + ] + ) + ] -instance MonadVar (Infer s) where - type Var (Infer s) = STRef s +liftInfer :: Monad m => m a -> InferT s m a +liftInfer = InferT . lift . lift . lift - newVar x = Infer $ lift $ lift $ lift $ newSTRef x - readVar x = Infer $ lift $ lift $ lift $ readSTRef x - writeVar x y = Infer $ lift $ lift $ lift $ writeSTRef x y - atomicModifyVar x f = Infer $ lift $ lift $ lift $ do - res <- snd . f <$> readSTRef x - _ <- modifySTRef x (fst . f) - return res +instance MonadRef m => MonadRef (InferT s m) where + type Ref (InferT s m) = Ref m + newRef x = liftInfer $ newRef x + readRef x = liftInfer $ readRef x + writeRef x y = liftInfer $ writeRef x y -newtype JThunk s = JThunk (Thunk (Infer s) (Judgment s)) +instance MonadAtomicRef m => MonadAtomicRef (InferT s m) where + atomicModifyRef x f = liftInfer $ do + res <- snd . f <$> readRef x + _ <- modifyRef x (fst . f) + return res -instance MonadThrow (Infer s) where - throwM = throwError . EvaluationError +newtype JThunkT s m = JThunk (NThunkF (InferT s m) (Judgment s)) -instance MonadCatch (Infer s) where - catch m h = catchError m $ \case - EvaluationError e -> - maybe (error $ "Exception was not an exception: " ++ show e) h - (fromException (toException e)) - err -> error $ "Unexpected error: " ++ show err +instance Monad m => MonadThrow (InferT s m) where + throwM = throwError . EvaluationError -instance MonadThunk (Judgment s) (JThunk s) (Infer s) where - thunk = fmap JThunk . buildThunk +instance Monad m => MonadCatch (InferT s m) where + catch m h = catchError m $ \case + EvaluationError e -> maybe + (error $ "Exception was not an exception: " ++ show e) + h + (fromException (toException e)) + err -> error $ "Unexpected error: " ++ show err - force (JThunk t) f = catch (forceThunk t f) $ \(_ :: ThunkLoop) -> - -- If we have a thunk loop, we just don't know the type. - f =<< Judgment As.empty [] <$> fresh +type MonadInfer m = (MonadThunkId m, MonadVar m, MonadFix m) - value = JThunk . valueRef +instance MonadInfer m + => MonadThunk (JThunkT s m) (InferT s m) (Judgment s) where + thunk = fmap JThunk . thunk + thunkId (JThunk x) = thunkId x -instance MonadEval (Judgment s) (Infer s) where - freeVariable var = do - tv <- fresh - return $ Judgment (As.singleton var tv) [] tv + query (JThunk x) b f = query x b f + queryM (JThunk x) b f = queryM x b f - -- If we fail to look up an attribute, we just don't know the type. - attrMissing _ _ = Judgment As.empty [] <$> fresh + force (JThunk t) f = catch (force t f) + $ \(_ :: ThunkLoop) -> +-- If we have a thunk loop, we just don't know the type. + f =<< Judgment As.empty [] <$> fresh + forceEff (JThunk t) f = catch (forceEff t f) + $ \(_ :: ThunkLoop) -> +-- If we have a thunk loop, we just don't know the type. + f =<< Judgment As.empty [] <$> fresh - evaledSym _ = pure + wrapValue = JThunk . wrapValue + getValue (JThunk x) = getValue x - evalCurPos = - return $ Judgment As.empty [] $ TSet False $ M.fromList - [ ("file", typePath) - , ("line", typeInt) - , ("col", typeInt) ] +instance MonadInfer m => MonadEval (Judgment s) (InferT s m) where + freeVariable var = do + tv <- fresh + return $ Judgment (As.singleton var tv) [] tv - evalConstant c = return $ Judgment As.empty [] (go c) - where - go = \case - NInt _ -> typeInt - NFloat _ -> typeFloat - NBool _ -> typeBool - NNull -> typeNull + synHole var = do + tv <- fresh + return $ Judgment (As.singleton var tv) [] tv - evalString = const $ return $ Judgment As.empty [] typeString - evalLiteralPath = const $ return $ Judgment As.empty [] typePath - evalEnvPath = const $ return $ Judgment As.empty [] typePath +-- If we fail to look up an attribute, we just don't know the type. + attrMissing _ _ = Judgment As.empty [] <$> fresh - evalUnary op (Judgment as1 cs1 t1) = do - tv <- fresh - return $ Judgment as1 (cs1 ++ unops (t1 :~> tv) op) tv + evaledSym _ = pure - evalBinary op (Judgment as1 cs1 t1) e2 = do - Judgment as2 cs2 t2 <- e2 - tv <- fresh - return $ Judgment - (as1 `As.merge` as2) - (cs1 ++ cs2 ++ binops (t1 :~> t2 :~> tv) op) - tv + evalCurPos = return $ Judgment As.empty [] $ TSet False $ M.fromList + [("file", typePath), ("line", typeInt), ("col", typeInt)] - evalWith = Eval.evalWithAttrSet + evalConstant c = return $ Judgment As.empty [] (go c) + where + go = \case + NInt _ -> typeInt + NFloat _ -> typeFloat + NBool _ -> typeBool + NNull -> typeNull - evalIf (Judgment as1 cs1 t1) t f = do - Judgment as2 cs2 t2 <- t - Judgment as3 cs3 t3 <- f - return $ Judgment - (as1 `As.merge` as2 `As.merge` as3) - (cs1 ++ cs2 ++ cs3 ++ [EqConst t1 typeBool, EqConst t2 t3]) - t2 + evalString = const $ return $ Judgment As.empty [] typeString + evalLiteralPath = const $ return $ Judgment As.empty [] typePath + evalEnvPath = const $ return $ Judgment As.empty [] typePath - evalAssert (Judgment as1 cs1 t1) body = do - Judgment as2 cs2 t2 <- body - return $ Judgment - (as1 `As.merge` as2) - (cs1 ++ cs2 ++ [EqConst t1 typeBool]) - t2 + evalUnary op (Judgment as1 cs1 t1) = do + tv <- fresh + return $ Judgment as1 (cs1 ++ unops (t1 :~> tv) op) tv - evalApp (Judgment as1 cs1 t1) e2 = do - Judgment as2 cs2 t2 <- e2 - tv <- fresh - return $ Judgment - (as1 `As.merge` as2) - (cs1 ++ cs2 ++ [EqConst t1 (t2 :~> tv)]) - tv + evalBinary op (Judgment as1 cs1 t1) e2 = do + Judgment as2 cs2 t2 <- e2 + tv <- fresh + return $ Judgment (as1 `As.merge` as2) + (cs1 ++ cs2 ++ binops (t1 :~> t2 :~> tv) op) + tv - evalAbs (Param x) k = do - tv@(TVar a) <- fresh - ((), Judgment as cs t) <- - extendMSet a (k (pure (Judgment (As.singleton x tv) [] tv)) - (\_ b -> ((),) <$> b)) - return $ Judgment - (as `As.remove` x) - (cs ++ [EqConst t' tv | t' <- As.lookup x as]) - (tv :~> t) + evalWith = Eval.evalWithAttrSet - evalAbs (ParamSet ps variadic _mname) k = do - js <- fmap concat $ forM ps $ \(name, _) -> do - tv <- fresh - pure [(name, tv)] + evalIf (Judgment as1 cs1 t1) t f = do + Judgment as2 cs2 t2 <- t + Judgment as3 cs3 t3 <- f + return $ Judgment + (as1 `As.merge` as2 `As.merge` as3) + (cs1 ++ cs2 ++ cs3 ++ [EqConst t1 typeBool, EqConst t2 t3]) + t2 - let (env, tys) = (\f -> foldl' f (As.empty, M.empty) js) - $ \(as1, t1) (k, t) -> - (as1 `As.merge` As.singleton k t, M.insert k t t1) - arg = pure $ Judgment env [] (TSet True tys) - call = k arg $ \args b -> (args,) <$> b - names = map fst js + evalAssert (Judgment as1 cs1 t1) body = do + Judgment as2 cs2 t2 <- body + return + $ Judgment (as1 `As.merge` as2) (cs1 ++ cs2 ++ [EqConst t1 typeBool]) t2 - (args, Judgment as cs t) <- - foldr (\(_, TVar a) -> extendMSet a) call js + evalApp (Judgment as1 cs1 t1) e2 = do + Judgment as2 cs2 t2 <- e2 + tv <- fresh + return $ Judgment (as1 `As.merge` as2) + (cs1 ++ cs2 ++ [EqConst t1 (t2 :~> tv)]) + tv - ty <- TSet variadic <$> traverse (inferredType <$>) args + evalAbs (Param x) k = do + a <- freshTVar + let tv = TVar a + ((), Judgment as cs t) <- extendMSet + a + (k (pure (Judgment (As.singleton x tv) [] tv)) (\_ b -> ((), ) <$> b)) + return $ Judgment (as `As.remove` x) + (cs ++ [ EqConst t' tv | t' <- As.lookup x as ]) + (tv :~> t) - return $ Judgment - (foldl' As.remove as names) - (cs ++ [ EqConst t' (tys M.! x) - | x <- names - , t' <- As.lookup x as]) - (ty :~> t) + evalAbs (ParamSet ps variadic _mname) k = do + js <- fmap concat $ forM ps $ \(name, _) -> do + tv <- fresh + pure [(name, tv)] - evalError = throwError . EvaluationError + let (env, tys) = + (\f -> foldl' f (As.empty, M.empty) js) $ \(as1, t1) (k, t) -> + (as1 `As.merge` As.singleton k t, M.insert k t t1) + arg = pure $ Judgment env [] (TSet True tys) + call = k arg $ \args b -> (args, ) <$> b + names = map fst js + (args, Judgment as cs t) <- foldr (\(_, TVar a) -> extendMSet a) call js + + ty <- TSet variadic <$> traverse (inferredType <$>) args + + return $ Judgment + (foldl' As.remove as names) + (cs ++ [ EqConst t' (tys M.! x) | x <- names, t' <- As.lookup x as ]) + (ty :~> t) + + evalError = throwError . EvaluationError + data Judgment s = Judgment { assumptions :: As.Assumption , typeConstraints :: [Constraint] @@ -443,68 +526,71 @@ } deriving Show -instance FromValue (Text, DList Text) (Infer s) (Judgment s) where - fromValueMay _ = return Nothing - fromValue _ = error "Unused" +instance Monad m => FromValue NixString (InferT s m) (Judgment s) where + fromValueMay _ = return Nothing + fromValue _ = error "Unused" -instance FromValue (AttrSet (JThunk s), AttrSet SourcePos) (Infer s) (Judgment s) where - fromValueMay (Judgment _ _ (TSet _ xs)) = do - let sing _ = Judgment As.empty [] - pure $ Just (M.mapWithKey (\k v -> value (sing k v)) xs, M.empty) - fromValueMay _ = pure Nothing - fromValue = fromValueMay >=> \case - Just v -> pure v - Nothing -> pure (M.empty, M.empty) +instance MonadInfer m + => FromValue (AttrSet (JThunkT s m), AttrSet SourcePos) + (InferT s m) (Judgment s) where + fromValueMay (Judgment _ _ (TSet _ xs)) = do + let sing _ = Judgment As.empty [] + pure $ Just (M.mapWithKey (\k v -> wrapValue (sing k v)) xs, M.empty) + fromValueMay _ = pure Nothing + fromValue = fromValueMay >=> \case + Just v -> pure v + Nothing -> pure (M.empty, M.empty) -instance ToValue (AttrSet (JThunk s), AttrSet SourcePos) (Infer s) (Judgment s) where - toValue (xs, _) = Judgment - <$> foldrM go As.empty xs - <*> (concat <$> traverse (`force` (pure . typeConstraints)) xs) - <*> (TSet True <$> traverse (`force` (pure . inferredType)) xs) - where - go x rest = force x $ \x' -> pure $ As.merge (assumptions x') rest +instance MonadInfer m + => ToValue (AttrSet (JThunkT s m), AttrSet SourcePos) + (InferT s m) (Judgment s) where + toValue (xs, _) = + Judgment + <$> foldrM go As.empty xs + <*> (concat <$> traverse (`force` (pure . typeConstraints)) xs) + <*> (TSet True <$> traverse (`force` (pure . inferredType)) xs) + where go x rest = force x $ \x' -> pure $ As.merge (assumptions x') rest -instance ToValue [JThunk s] (Infer s) (Judgment s) where - toValue xs = Judgment - <$> foldrM go As.empty xs - <*> (concat <$> traverse (`force` (pure . typeConstraints)) xs) - <*> (TList <$> traverse (`force` (pure . inferredType)) xs) - where - go x rest = force x $ \x' -> pure $ As.merge (assumptions x') rest +instance MonadInfer m => ToValue [JThunkT s m] (InferT s m) (Judgment s) where + toValue xs = + Judgment + <$> foldrM go As.empty xs + <*> (concat <$> traverse (`force` (pure . typeConstraints)) xs) + <*> (TList <$> traverse (`force` (pure . inferredType)) xs) + where go x rest = force x $ \x' -> pure $ As.merge (assumptions x') rest -instance ToValue Bool (Infer s) (Judgment s) where - toValue _ = pure $ Judgment As.empty [] typeBool +instance MonadInfer m => ToValue Bool (InferT s m) (Judgment s) where + toValue _ = pure $ Judgment As.empty [] typeBool -infer :: NExpr -> Infer s (Judgment s) +infer :: MonadInfer m => NExpr -> InferT s m (Judgment s) infer = cata Eval.eval inferTop :: Env -> [(Text, NExpr)] -> Either InferError Env -inferTop env [] = Right env -inferTop env ((name, ex):xs) = case inferExpr env ex of - Left err -> Left err - Right ty -> inferTop (extend env (name, ty)) xs +inferTop env [] = Right env +inferTop env ((name, ex) : xs) = case inferExpr env ex of + Left err -> Left err + Right ty -> inferTop (extend env (name, ty)) xs normalize :: Scheme -> Scheme normalize (Forall _ body) = Forall (map snd ord) (normtype body) - where - ord = zip (nub $ fv body) (map TV letters) + where + ord = zip (nub $ fv body) (map TV letters) - fv (TVar a) = [a] - fv (a :~> b) = fv a ++ fv b - fv (TCon _) = [] - fv (TSet _ a) = concatMap fv (M.elems a) - fv (TList a) = concatMap fv a - fv (TMany ts) = concatMap fv ts + fv (TVar a ) = [a] + fv (a :~> b ) = fv a ++ fv b + fv (TCon _ ) = [] + fv (TSet _ a) = concatMap fv (M.elems a) + fv (TList a ) = concatMap fv a + fv (TMany ts) = concatMap fv ts - normtype (a :~> b) = normtype a :~> normtype b - normtype (TCon a) = TCon a - normtype (TSet b a) = TSet b (M.map normtype a) - normtype (TList a) = TList (map normtype a) - normtype (TMany ts) = TMany (map normtype ts) - normtype (TVar a) = - case Prelude.lookup a ord of - Just x -> TVar x - Nothing -> error "type variable not in signature" + normtype (a :~> b ) = normtype a :~> normtype b + normtype (TCon a ) = TCon a + normtype (TSet b a) = TSet b (M.map normtype a) + normtype (TList a ) = TList (map normtype a) + normtype (TMany ts) = TMany (map normtype ts) + normtype (TVar a ) = case Prelude.lookup a ord of + Just x -> TVar x + Nothing -> error "type variable not in signature" ------------------------------------------------------------------------------- -- Constraint Solver @@ -515,18 +601,18 @@ MonadLogic, MonadState [TypeError]) instance MonadTrans Solver where - lift = Solver . lift . lift + lift = Solver . lift . lift instance Monad m => MonadError TypeError (Solver m) where - throwError err = Solver $ lift (modify (err:)) >> mzero - catchError _ _ = error "This is never used" + throwError err = Solver $ lift (modify (err :)) >> mzero + catchError _ _ = error "This is never used" runSolver :: Monad m => Solver m a -> m (Either [TypeError] [a]) runSolver (Solver s) = do - res <- runStateT (observeAllT s) [] - pure $ case res of - (x:xs, _) -> Right (x:xs) - (_, es) -> Left (nub es) + res <- runStateT (observeAllT s) [] + pure $ case res of + (x : xs, _ ) -> Right (x : xs) + (_ , es) -> Left (nub es) -- | The empty substitution emptySubst :: Subst @@ -535,62 +621,62 @@ -- | Compose substitutions compose :: Subst -> Subst -> Subst Subst s1 `compose` Subst s2 = - Subst $ Map.map (apply (Subst s1)) s2 `Map.union` s1 + Subst $ Map.map (apply (Subst s1)) s2 `Map.union` s1 unifyMany :: Monad m => [Type] -> [Type] -> Solver m Subst -unifyMany [] [] = return emptySubst -unifyMany (t1 : ts1) (t2 : ts2) = - do su1 <- unifies t1 t2 - su2 <- unifyMany (apply su1 ts1) (apply su1 ts2) - return (su2 `compose` su1) +unifyMany [] [] = return emptySubst +unifyMany (t1 : ts1) (t2 : ts2) = do + su1 <- unifies t1 t2 + su2 <- unifyMany (apply su1 ts1) (apply su1 ts2) + return (su2 `compose` su1) unifyMany t1 t2 = throwError $ UnificationMismatch t1 t2 allSameType :: [Type] -> Bool -allSameType [] = True -allSameType [_] = True -allSameType (x:y:ys) = x == y && allSameType (y:ys) +allSameType [] = True +allSameType [_ ] = True +allSameType (x : y : ys) = x == y && allSameType (y : ys) unifies :: Monad m => Type -> Type -> Solver m Subst -unifies t1 t2 | t1 == t2 = return emptySubst -unifies (TVar v) t = v `bind` t -unifies t (TVar v) = v `bind` t +unifies t1 t2 | t1 == t2 = return emptySubst +unifies (TVar v) t = v `bind` t +unifies t (TVar v) = v `bind` t unifies (TList xs) (TList ys) - | allSameType xs && allSameType ys = case (xs, ys) of - (x:_, y:_) -> unifies x y - _ -> return emptySubst - | length xs == length ys = unifyMany xs ys + | allSameType xs && allSameType ys = case (xs, ys) of + (x : _, y : _) -> unifies x y + _ -> return emptySubst + | length xs == length ys = unifyMany xs ys -- We assume that lists of different lengths containing various types cannot -- be unified. -unifies t1@(TList _) t2@(TList _) = throwError $ UnificationFail t1 t2 -unifies (TSet True _) (TSet True _) = return emptySubst +unifies t1@(TList _ ) t2@(TList _ ) = throwError $ UnificationFail t1 t2 +unifies ( TSet True _) ( TSet True _) = return emptySubst unifies (TSet False b) (TSet True s) - | M.keys b `intersect` M.keys s == M.keys s = return emptySubst + | M.keys b `intersect` M.keys s == M.keys s = return emptySubst unifies (TSet True s) (TSet False b) - | M.keys b `intersect` M.keys s == M.keys b = return emptySubst -unifies (TSet False s) (TSet False b) - | null (M.keys b \\ M.keys s) = return emptySubst + | M.keys b `intersect` M.keys s == M.keys b = return emptySubst +unifies (TSet False s) (TSet False b) | null (M.keys b \\ M.keys s) = + return emptySubst unifies (t1 :~> t2) (t3 :~> t4) = unifyMany [t1, t2] [t3, t4] -unifies (TMany t1s) t2 = considering t1s >>- unifies ?? t2 -unifies t1 (TMany t2s) = considering t2s >>- unifies t1 -unifies t1 t2 = throwError $ UnificationFail t1 t2 +unifies (TMany t1s) t2 = considering t1s >>- unifies ?? t2 +unifies t1 (TMany t2s) = considering t2s >>- unifies t1 +unifies t1 t2 = throwError $ UnificationFail t1 t2 bind :: Monad m => TVar -> Type -> Solver m Subst bind a t | t == TVar a = return emptySubst | occursCheck a t = throwError $ InfiniteType a t | otherwise = return (Subst $ Map.singleton a t) -occursCheck :: FreeTypeVars a => TVar -> a -> Bool +occursCheck :: FreeTypeVars a => TVar -> a -> Bool occursCheck a t = a `Set.member` ftv t nextSolvable :: [Constraint] -> (Constraint, [Constraint]) nextSolvable xs = fromJust (find solvable (chooseOne xs)) - where - chooseOne xs = [(x, ys) | x <- xs, let ys = delete x xs] + where + chooseOne xs = [ (x, ys) | x <- xs, let ys = delete x xs ] - solvable (EqConst{}, _) = True - solvable (ExpInstConst{}, _) = True - solvable (ImpInstConst _t1 ms t2, cs) = - Set.null ((ftv t2 `Set.difference` ms) `Set.intersection` atv cs) + solvable (EqConst{} , _) = True + solvable (ExpInstConst{}, _) = True + solvable (ImpInstConst _t1 ms t2, cs) = + Set.null ((ftv t2 `Set.difference` ms) `Set.intersection` atv cs) considering :: [a] -> Solver m a considering xs = Solver $ LogicT $ \c n -> foldr c n xs @@ -598,15 +684,19 @@ solve :: MonadState InferState m => [Constraint] -> Solver m Subst solve [] = return emptySubst solve cs = solve' (nextSolvable cs) - where - solve' (EqConst t1 t2, cs) = - unifies t1 t2 >>- \su1 -> - solve (apply su1 cs) >>- \su2 -> - return (su2 `compose` su1) + where + solve' (EqConst t1 t2, cs) = unifies t1 t2 + >>- \su1 -> solve (apply su1 cs) >>- \su2 -> return (su2 `compose` su1) - solve' (ImpInstConst t1 ms t2, cs) = - solve (ExpInstConst t1 (generalize ms t2) : cs) + 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' (ExpInstConst t s, cs) = do + s' <- lift $ instantiate s + solve (EqConst t s' : cs) + +instance Monad m => Scoped (JThunkT s m) (InferT s m) where + currentScopes = currentScopesReader + clearScopes = clearScopesReader @(InferT s m) @(JThunkT s m) + pushScopes = pushScopesReader + lookupVar = lookupVarReader 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 @@ -1,7 +1,7 @@ module Nix.Type.Type where -import qualified Data.HashMap.Lazy as M -import Data.Text (Text) +import qualified Data.HashMap.Lazy as M +import Data.Text ( Text ) import Nix.Utils newtype TVar = TV String @@ -32,11 +32,11 @@ typeFun = foldr1 (:~>) typeInt, typeFloat, typeBool, typeString, typePath, typeNull :: Type -typeInt = TCon "integer" -typeFloat = TCon "float" -typeBool = TCon "boolean" +typeInt = TCon "integer" +typeFloat = TCon "float" +typeBool = TCon "boolean" typeString = TCon "string" -typePath = TCon "path" -typeNull = TCon "null" +typePath = TCon "path" +typeNull = TCon "null" type Name = Text diff --git a/src/Nix/Utils.hs b/src/Nix/Utils.hs --- a/src/Nix/Utils.hs +++ b/src/Nix/Utils.hs @@ -2,37 +2,54 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} + module Nix.Utils (module Nix.Utils, module X) where -import Control.Arrow ((&&&)) +import Control.Arrow ( (&&&) ) import Control.Monad import Control.Monad.Fix -import qualified Data.Aeson as A -import qualified Data.Aeson.Encoding as A +import qualified Data.Aeson as A +import qualified Data.Aeson.Encoding as A import Data.Fix -import Data.HashMap.Lazy (HashMap) -import qualified Data.HashMap.Lazy as M -import Data.List (sortOn) -import Data.Monoid (Endo) -import Data.Text (Text) -import qualified Data.Vector as V -import Lens.Family2 as X -import Lens.Family2.Stock (_1, _2) +import Data.Hashable +import Data.HashMap.Lazy ( HashMap ) +import qualified Data.HashMap.Lazy as M +import Data.List ( sortOn ) +import Data.Monoid ( Endo + , (<>) + ) +import Data.Text ( Text ) +import qualified Data.Text as Text +import qualified Data.Vector as V +import Lens.Family2 as X +import Lens.Family2.Stock ( _1 + , _2 + ) +import Lens.Family2.TH #if ENABLE_TRACING import Debug.Trace as X #else -import Prelude as X +import Prelude as X + hiding ( putStr + , putStrLn + , print + ) trace :: String -> a -> a trace = const id traceM :: Monad m => String -> m () traceM = const (return ()) #endif +$(makeLensesBy (\n -> Just ("_" ++ n)) ''Fix) + type DList a = Endo [a] type AttrSet = HashMap Text @@ -62,7 +79,7 @@ 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 +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 @@ -70,7 +87,7 @@ 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 -transport :: Functor g => (forall x. f x -> g x) -> Fix f -> Fix g +transport :: Functor g => (forall x . f x -> g x) -> Fix f -> Fix g transport f (Fix x) = Fix $ fmap (transport f) (f x) -- | adi is Abstracting Definitional Interpreters: @@ -83,28 +100,67 @@ adi :: Functor f => (f a -> a) -> ((Fix f -> a) -> Fix f -> a) -> Fix f -> a adi f g = g (f . fmap (adi f g) . unFix) -adiM :: (Traversable t, Monad m) - => (t a -> m a) -> ((Fix t -> m a) -> Fix t -> m a) -> Fix t -> m a +adiM + :: (Traversable t, Monad m) + => (t a -> m a) + -> ((Fix t -> m a) -> Fix t -> m a) + -> Fix t + -> m a adiM f g = g ((f <=< traverse (adiM f g)) . unFix) class Has a b where hasLens :: Lens' a b instance Has a a where - hasLens f = f + hasLens f = f instance Has (a, b) a where - hasLens = _1 + hasLens = _1 instance Has (a, b) b where - hasLens = _2 + hasLens = _2 toEncodingSorted :: A.Value -> A.Encoding toEncodingSorted = \case - A.Object m -> - A.pairs . mconcat - . fmap (\(k, v) -> A.pair k $ toEncodingSorted v) - . sortOn fst - $ M.toList m - A.Array l -> A.list toEncodingSorted $ V.toList l - v -> A.toEncoding v + A.Object m -> + A.pairs + . mconcat + . fmap (\(k, v) -> A.pair k $ toEncodingSorted v) + . sortOn fst + $ M.toList 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 = go where + go str = case Text.break (== ':') str of + (e1, e2) + | Text.null e2 + -> [(e1, PathEntryPath)] + | Text.pack "://" `Text.isPrefixOf` e2 + -> let ((suffix, _) : path) = go (Text.drop 3 e2) + in (e1 <> Text.pack "://" <> suffix, PathEntryURI) : path + | otherwise + -> (e1, PathEntryPath) : go (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 = f (M.lookup k m) <&> \case + Nothing -> M.delete k m + Just v -> M.insert k v m + + + + + + + + diff --git a/src/Nix/Value.hs b/src/Nix/Value.hs --- a/src/Nix/Value.hs +++ b/src/Nix/Value.hs @@ -1,6 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} @@ -8,6 +9,7 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -15,29 +17,29 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} {-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-} module Nix.Value where +import Control.Comonad +import Control.Exception import Control.Monad -import Control.Monad.Catch +import Control.Monad.Free import Control.Monad.Trans.Class -import Control.Monad.Trans.Except -import qualified Data.Aeson as A -import Data.Align -import Data.Fix -import Data.HashMap.Lazy (HashMap) -import qualified Data.HashMap.Lazy as M -import Data.Hashable -import Data.Monoid (appEndo) -import Data.Text (Text) -import Data.These -import Data.Typeable (Typeable) +import qualified Data.Aeson as A +import Data.Functor.Classes +import Data.HashMap.Lazy ( HashMap ) +import Data.Text ( Text ) +import Data.Typeable ( Typeable ) import GHC.Generics import Lens.Family2 import Lens.Family2.Stock @@ -45,23 +47,22 @@ import Nix.Atoms import Nix.Expr.Types import Nix.Expr.Types.Annotated -import Nix.Frames -import Nix.Scope +import Nix.String import Nix.Thunk import Nix.Utils -- | An 'NValue' is the most reduced form of an 'NExpr' after evaluation is -- completed. 's' is related to the type of errors that might occur during -- construction or use of a value. -data NValueF m r +data NValueF p m r = NVConstantF NAtom -- | A string has a value and a context, which can be used to record what a -- string has been build from - | NVStrF Text (DList Text) + | NVStrF NixString | NVPathF FilePath | NVListF [r] | NVSetF (AttrSet r) (AttrSet SourcePos) - | NVClosureF (Params ()) (m (NValue m) -> m (NValue m)) + | NVClosureF (Params ()) (m 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 -- passed to the function. Since it supports default values which may @@ -73,201 +74,349 @@ -- 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 String (m (NValue m) -> m (NValue m)) + | NVBuiltinF String (m 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, Foldable, Traversable) + deriving (Generic, Typeable, Functor) --- | An 'NValueNF' is a fully evaluated value in normal form. An 'NValue m' is --- a value in head normal form, where only the "top layer" has been --- evaluated. An action of type 'm (NValue m)' is a pending evualation that --- has yet to be performed. An 'NThunk m' is either a pending evaluation, or --- a value in head normal form. A 'NThunkSet' is a set of mappings from keys --- to thunks. +-- | This 'Foldable' instance only folds what the value actually is known to +-- contain at time of fold. +instance Foldable (NValueF p m) where + foldMap f = \case + NVConstantF _ -> mempty + NVStrF _ -> mempty + NVPathF _ -> mempty + NVListF l -> foldMap f l + NVSetF s _ -> foldMap f s + NVClosureF _ _ -> mempty + NVBuiltinF _ _ -> mempty -type NValueNF m = Fix (NValueF m) -- normal form -type ValueSet m = AttrSet (NThunk m) +lmapNValueF :: Functor m => (b -> a) -> NValueF a m r -> NValueF b m r +lmapNValueF f = \case + NVConstantF a -> NVConstantF a + NVStrF s -> NVStrF s + NVPathF p -> NVPathF p + NVListF l -> NVListF l + NVSetF s p -> NVSetF s p + NVClosureF p g -> NVClosureF p (g . fmap f) + NVBuiltinF s g -> NVBuiltinF s (g . fmap f) -data Provenance m = Provenance - { _lexicalScope :: Scopes m (NThunk m) - , _originExpr :: NExprLocF (Maybe (NValue m)) - -- ^ 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 - -- result of the call, but what was called and with what arguments. - } +hoistNValueF + :: (forall x . n x -> m x) + -> (forall x . m x -> n x) + -> NValueF p m a + -> NValueF p n a +hoistNValueF run lft = \case + NVConstantF a -> NVConstantF a + NVStrF s -> NVStrF s + NVPathF p -> NVPathF p + NVListF l -> NVListF l + NVSetF s p -> NVSetF s p + NVClosureF p g -> NVClosureF p (lft . g . run) + NVBuiltinF s g -> NVBuiltinF s (lft . g . run) -data NThunk m = NThunk - { _thunkProvenance :: [Provenance m] - , _baseThunk :: Thunk m (NValue m) - } +sequenceNValueF + :: (Functor n, Monad m, Applicative n) + => (forall x . n x -> m x) + -> NValueF p m (n a) + -> n (NValueF p m a) +sequenceNValueF transform = \case + NVConstantF a -> pure $ NVConstantF a + NVStrF s -> pure $ NVStrF s + NVPathF p -> pure $ NVPathF p + NVListF l -> NVListF <$> sequenceA l + NVSetF s p -> NVSetF <$> sequenceA s <*> pure p + NVClosureF p g -> pure $ NVClosureF p (transform <=< g) + NVBuiltinF s g -> pure $ NVBuiltinF s (transform <=< g) -data NValue m = NValue - { _valueProvenance :: [Provenance m] - , _baseValue :: NValueF m (NThunk m) - } +bindNValueF + :: (Monad m, Monad n) + => (forall x . n x -> m x) + -> (a -> n b) + -> NValueF p m a + -> n (NValueF p m b) +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 -> NVSetF <$> traverse f s <*> pure p + NVClosureF p g -> pure $ NVClosureF p (transform . f <=< g) + NVBuiltinF s g -> pure $ NVBuiltinF s (transform . f <=< g) -addProvenance :: (NValue m -> Provenance m) -> NValue m -> NValue m -addProvenance f l@(NValue p v) = NValue (f l : p) v +liftNValueF + :: (MonadTrans u, Monad m) + => (forall x . u m x -> m x) + -> NValueF p m a + -> NValueF p (u m) a +liftNValueF run = hoistNValueF run lift -pattern NVConstant x <- NValue _ (NVConstantF x) +unliftNValueF + :: (MonadTrans u, Monad m) + => (forall x . u m x -> m x) + -> NValueF p (u m) a + -> NValueF p m a +unliftNValueF run = hoistNValueF lift run -nvConstant x = NValue [] (NVConstantF x) -nvConstantP p x = NValue [p] (NVConstantF x) +type MonadDataContext f (m :: * -> *) + = (Comonad f, Applicative f, Traversable f, Monad m) -pattern NVStr s d <- NValue _ (NVStrF s d) +-- | 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 = NValue { _nValue :: f (NValueF (NValue t f m) m a) } + deriving (Generic, Typeable, Functor, Foldable) -nvStr s d = NValue [] (NVStrF s d) -nvStrP p s d = NValue [p] (NVStrF s d) +instance Show r => Show (NValueF p m r) where + showsPrec = flip go where + go (NVConstantF atom ) = showsCon1 "NVConstant" atom + go (NVStrF ns ) = showsCon1 "NVStr" (hackyStringIgnoreContext ns) + go (NVListF lst ) = showsCon1 "NVList" lst + go (NVSetF attrs _) = showsCon1 "NVSet" attrs + go (NVClosureF p _) = showsCon1 "NVClosure" p + go (NVPathF p ) = showsCon1 "NVPath" p + go (NVBuiltinF name _ ) = showsCon1 "NVBuiltin" name -pattern NVPath x <- NValue _ (NVPathF x) + showsCon1 :: Show a => String -> a -> Int -> String -> String + showsCon1 con a d = + showParen (d > 10) $ showString (con ++ " ") . showsPrec 11 a -nvPath x = NValue [] (NVPathF x) -nvPathP p x = NValue [p] (NVPathF x) +instance (Comonad f, Show a) => Show (NValue' t f m a) where + show (NValue (extract -> v)) = show v -pattern NVList l <- NValue _ (NVListF l) +instance Comonad f => Show1 (NValue' t f m) where + liftShowsPrec sp sl p = \case + NVConstant atom -> showsUnaryWith showsPrec "NVConstantF" p atom + NVStr ns -> + showsUnaryWith showsPrec "NVStrF" p (hackyStringIgnoreContext 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 + _ -> error "Pattern synonyms mask coverage" -nvList l = NValue [] (NVListF l) -nvListP p l = NValue [p] (NVListF l) +type NValue t f m = NValue' t f m t -pattern NVSet s x <- NValue _ (NVSetF s x) +sequenceNValue + :: (Functor n, Traversable f, Monad m, Applicative n) + => (forall x . n x -> m x) + -> NValue' t f m (n a) + -> n (NValue' t f m a) +sequenceNValue transform (NValue v) = + NValue <$> traverse (sequenceNValueF transform) v -nvSet s x = NValue [] (NVSetF s x) -nvSetP p s x = NValue [p] (NVSetF s x) +bindNValue + :: (Traversable f, Monad m, Monad n) + => (forall x . n x -> m x) + -> (a -> n b) + -> NValue' t f m a + -> n (NValue' t f m b) +bindNValue transform f (NValue v) = + NValue <$> traverse (bindNValueF transform f) v -pattern NVClosure x f <- NValue _ (NVClosureF x f) +hoistNValue + :: (Functor m, Functor n, Functor f) + => (forall x . n x -> m x) + -> (forall x . m x -> n x) + -> NValue' t f m a + -> NValue' t f n a +hoistNValue run lft (NValue v) = + NValue (fmap (lmapNValueF (hoistNValue lft run) . hoistNValueF run lft) v) -nvClosure x f = NValue [] (NVClosureF x f) -nvClosureP p x f = NValue [p] (NVClosureF x f) +liftNValue + :: (MonadTrans u, Monad m, Functor (u m), Functor f) + => (forall x . u m x -> m x) + -> NValue' t f m a + -> NValue' t f (u m) a +liftNValue run = hoistNValue run lift -pattern NVBuiltin name f <- NValue _ (NVBuiltinF name f) +unliftNValue + :: (MonadTrans u, Monad m, Functor (u m), Functor f) + => (forall x . u m x -> m x) + -> NValue' t f (u m) a + -> NValue' t f m a +unliftNValue run = hoistNValue lift run -nvBuiltin name f = NValue [] (NVBuiltinF name f) -nvBuiltinP p name f = NValue [p] (NVBuiltinF name f) +-- | An 'NValueNF' is a fully evaluated value in normal form. An 'NValue f t m' is +-- a value in head normal form, where only the "top layer" has been +-- evaluated. An action of type 'm (NValue f t m)' is a pending evualation that +-- has yet to be performed. An 't' is either a pending evaluation, or +-- a value in head normal form. A 'NThunkSet' is a set of mappings from keys +-- to thunks. +-- +-- The 'Free' structure is used here to represent the possibility that +-- cycles may appear during normalization. -instance Show (NValueF m (Fix (NValueF m))) where - showsPrec = flip go where - go (NVConstantF atom) = showsCon1 "NVConstant" atom - go (NVStrF txt ctxt) = showsCon2 "NVStr" txt (appEndo ctxt []) - go (NVListF lst) = showsCon1 "NVList" lst - go (NVSetF attrs _) = showsCon1 "NVSet" attrs - go (NVClosureF p _) = showsCon1 "NVClosure" p - go (NVPathF p) = showsCon1 "NVPath" p - go (NVBuiltinF name _) = showsCon1 "NVBuiltin" name +type NValueNF t f m = Free (NValue' t f m) t - showsCon1 :: Show a => String -> a -> Int -> String -> String - showsCon1 con a d = - showParen (d > 10) $ showString (con ++ " ") . showsPrec 11 a +iterNValue + :: forall t f m a r + . MonadDataContext f m + => (a -> (NValue' t f m a -> r) -> r) + -> (NValue' t f m r -> r) + -> NValue' t f m a + -> r +iterNValue k f = f . fmap (\a -> k a (iterNValue k f)) - showsCon2 :: (Show a, Show b) - => String -> a -> b -> Int -> String -> String - showsCon2 con a b d = - showParen (d > 10) - $ showString (con ++ " ") - . showsPrec 11 a - . showString " " - . showsPrec 11 b +iterNValueM + :: (MonadDataContext f m, Monad n) + => (forall x . n x -> m x) + -> (a -> (NValue' t f m a -> n r) -> n r) + -> (NValue' t f m r -> n r) + -> NValue' t f m a + -> n r +iterNValueM transform k f = + f <=< bindNValue transform (\a -> k a (iterNValueM transform k f)) -instance Eq (NValue m) where - NVConstant (NFloat x) == NVConstant (NInt y) = x == fromInteger y - NVConstant (NInt x) == NVConstant (NFloat y) = fromInteger x == y - NVConstant (NInt x) == NVConstant (NInt y) = x == y - NVConstant (NFloat x) == NVConstant (NFloat y) = x == y - NVStr x _ == NVStr y _ = x < y - NVPath x == NVPath y = x < y - _ == _ = False +iterNValueNF + :: MonadDataContext f m + => (t -> r) + -> (NValue' t f m r -> r) + -> NValueNF t f m + -> r +iterNValueNF k f = iter f . fmap k -instance Ord (NValue m) where - NVConstant (NFloat x) <= NVConstant (NInt y) = x <= fromInteger y - NVConstant (NInt x) <= NVConstant (NFloat y) = fromInteger x <= y - NVConstant (NInt x) <= NVConstant (NInt y) = x <= y - NVConstant (NFloat x) <= NVConstant (NFloat y) = x <= y - NVStr x _ <= NVStr y _ = x < y - NVPath x <= NVPath y = x < y - _ <= _ = False +iterNValueNFM + :: forall f m n t r + . (MonadDataContext f m, Monad n) + => (forall x . n x -> m x) + -> (t -> n r) + -> (NValue' t f m (n r) -> n r) + -> NValueNF t f m + -> n r +iterNValueNFM transform k f v = + iterM f =<< go (fmap k v) + where + go (Pure a ) = Pure <$> a + go (Free fa) = Free <$> bindNValue transform go fa -checkComparable :: (Framed e m, Typeable m) => NValue m -> NValue m -> m () -checkComparable x y = case (x, y) of - (NVConstant (NFloat _), NVConstant (NInt _)) -> pure () - (NVConstant (NInt _), NVConstant (NFloat _)) -> pure () - (NVConstant (NInt _), NVConstant (NInt _)) -> pure () - (NVConstant (NFloat _), NVConstant (NFloat _)) -> pure () - (NVStr _ _, NVStr _ _) -> pure () - (NVPath _, NVPath _) -> pure () - _ -> throwError $ Comparison x y +nValueFromNF + :: (MonadThunk t m (NValue t f m), MonadDataContext f m) + => NValueNF t f m + -> NValue t f m +nValueFromNF = iterNValueNF f (fmap wrapValue) + where + f t = query t cyc id + cyc = nvStr (principledMakeNixStringWithoutContext "") -builtin :: Monad m - => String -> (m (NValue m) -> m (NValue m)) -> m (NValue m) -builtin name f = return $ nvBuiltin name f +nValueToNF + :: (MonadThunk t m (NValue t f m), MonadDataContext f m) + => (t -> (NValue t f m -> NValueNF t f m) -> NValueNF t f m) + -> NValue t f m + -> NValueNF t f m +nValueToNF k = iterNValue k Free -builtin2 :: Monad m - => String -> (m (NValue m) -> m (NValue m) -> m (NValue m)) - -> m (NValue m) -builtin2 name f = builtin name (builtin name . f) +nValueToNFM + :: (MonadDataContext f m, Monad n) + => (forall x . n x -> m x) + -> (t -> (NValue t f m -> n (NValueNF t f m)) -> n (NValueNF t f m)) + -> NValue t f m + -> n (NValueNF t f m) +nValueToNFM transform k = iterNValueM transform k $ pure . Free -builtin3 :: Monad m - => String - -> (m (NValue m) -> m (NValue m) -> m (NValue m) -> m (NValue m)) - -> m (NValue m) -builtin3 name f = - builtin name $ \a -> builtin name $ \b -> builtin name $ \c -> f a b c +pattern NVConstant x <- NValue (extract -> NVConstantF x) +pattern NVConstantNF x <- Free (NValue (extract -> NVConstantF x)) -isClosureNF :: Monad m => NValueNF m -> Bool -isClosureNF (Fix NVClosureF {}) = True -isClosureNF _ = False +nvConstant :: Applicative f => NAtom -> NValue t f m +nvConstant x = NValue (pure (NVConstantF x)) +nvConstantNF :: Applicative f => NAtom -> NValueNF t f m +nvConstantNF x = Free (NValue (pure (NVConstantF x))) -thunkEq :: MonadThunk (NValue m) (NThunk m) m - => NThunk m -> NThunk m -> m Bool -thunkEq lt rt = force lt $ \lv -> force rt $ \rv -> valueEq lv rv +pattern NVStr ns <- NValue (extract -> NVStrF ns) +pattern NVStrNF ns <- Free (NValue (extract -> NVStrF ns)) --- | Checks whether two containers are equal, using the given item equality --- predicate. If there are any item slots that don't match between the two --- containers, the result will be False. -alignEqM - :: (Align f, Traversable f, Monad m) - => (a -> b -> m Bool) - -> f a - -> f b - -> m Bool -alignEqM eq fa fb = fmap (either (const False) (const True)) $ runExceptT $ do - pairs <- forM (Data.Align.align fa fb) $ \case - These a b -> return (a, b) - _ -> throwE () - forM_ pairs $ \(a, b) -> guard =<< lift (eq a b) +nvStr :: Applicative f => NixString -> NValue t f m +nvStr ns = NValue (pure (NVStrF ns)) +nvStrNF :: Applicative f => NixString -> NValueNF t f m +nvStrNF ns = Free (NValue (pure (NVStrF ns))) -isDerivation :: MonadThunk (NValue m) (NThunk m) m - => AttrSet (NThunk m) -> m Bool -isDerivation m = case M.lookup "type" m of - Nothing -> pure False - Just t -> force t $ valueEq (nvStr "derivation" mempty) +pattern NVPath x <- NValue (extract -> NVPathF x) +pattern NVPathNF x <- Free (NValue (extract -> NVPathF x)) -valueEq :: MonadThunk (NValue m) (NThunk m) m - => NValue m -> NValue m -> m Bool -valueEq l r = case (l, r) of - (NVConstant lc, NVConstant rc) -> pure $ lc == rc - (NVStr ls _, NVStr rs _) -> pure $ ls == rs - (NVStr ls _, NVConstant NNull) -> pure $ ls == "" - (NVConstant NNull, NVStr rs _) -> pure $ "" == rs - (NVList ls, NVList rs) -> alignEqM thunkEq ls rs - (NVSet lm _, NVSet rm _) -> do - let compareAttrs = alignEqM thunkEq lm rm - isDerivation lm >>= \case - True -> isDerivation rm >>= \case - True | Just lp <- M.lookup "outPath" lm - , Just rp <- M.lookup "outPath" rm - -> thunkEq lp rp - _ -> compareAttrs - _ -> compareAttrs - (NVPath lp, NVPath rp) -> pure $ lp == rp - _ -> pure False +nvPath :: Applicative f => FilePath -> NValue t f m +nvPath x = NValue (pure (NVPathF x)) +nvPathNF :: Applicative f => FilePath -> NValueNF t f m +nvPathNF x = Free (NValue (pure (NVPathF x))) +pattern NVList l <- NValue (extract -> NVListF l) +pattern NVListNF l <- Free (NValue (extract -> NVListF l)) + +nvList :: Applicative f => [t] -> NValue t f m +nvList l = NValue (pure (NVListF l)) +nvListNF :: Applicative f => [NValueNF t f m] -> NValueNF t f m +nvListNF l = Free (NValue (pure (NVListF l))) + +pattern NVSet s x <- NValue (extract -> NVSetF s x) +pattern NVSetNF s x <- Free (NValue (extract -> NVSetF s x)) + +nvSet :: Applicative f + => HashMap Text t -> HashMap Text SourcePos -> NValue t f m +nvSet s x = NValue (pure (NVSetF s x)) +nvSetNF :: Applicative f + => HashMap Text (NValueNF t f m) -> HashMap Text SourcePos -> NValueNF t f m +nvSetNF s x = Free (NValue (pure (NVSetF s x))) + +pattern NVClosure x f <- NValue (extract -> NVClosureF x f) +pattern NVClosureNF x f <- Free (NValue (extract -> NVClosureF x f)) + +nvClosure :: Applicative f + => Params () -> (m (NValue t f m) -> m t) -> NValue t f m +nvClosure x f = NValue (pure (NVClosureF x f)) +nvClosureNF :: Applicative f + => Params () -> (m (NValue t f m) -> m (NValueNF t f m)) -> NValueNF t f m +nvClosureNF x f = Free (NValue (pure (NVClosureF x f))) + +pattern NVBuiltin name f <- NValue (extract -> NVBuiltinF name f) +pattern NVBuiltinNF name f <- Free (NValue (extract -> NVBuiltinF name f)) + +nvBuiltin :: Applicative f + => String -> (m (NValue t f m) -> m t) -> NValue t f m +nvBuiltin name f = NValue (pure (NVBuiltinF name f)) +nvBuiltinNF :: Applicative f + => String -> (m (NValue t f m) -> m (NValueNF t f m)) -> NValueNF t f m +nvBuiltinNF name f = Free (NValue (pure (NVBuiltinF name f))) + +builtin + :: forall m f t + . (MonadThunk t m (NValue t f m), MonadDataContext f m) + => String + -> (m (NValue t f m) -> m (NValue t f m)) + -> m (NValue t f m) +builtin name f = return $ nvBuiltin name $ \a -> thunk $ f a + +builtin2 + :: (MonadThunk t m (NValue t f m), MonadDataContext f m) + => String + -> (m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m)) + -> m (NValue t f m) +builtin2 name f = builtin name $ \a -> builtin name $ \b -> f a b + +builtin3 + :: (MonadThunk t m (NValue t f m), MonadDataContext f m) + => String + -> ( m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) + -> m (NValue t f m) + ) + -> m (NValue t f m) +builtin3 name f = + builtin name $ \a -> builtin name $ \b -> builtin name $ \c -> f a b c + +isClosureNF :: Comonad f => NValueNF t f m -> Bool +isClosureNF NVClosureNF{} = True +isClosureNF _ = False + +data TStringContext = NoContext | HasContext + deriving Show + data ValueType = TInt | TFloat | TBool | TNull - | TString + | TString TStringContext | TList | TSet | TClosure @@ -275,72 +424,59 @@ | TBuiltin deriving Show -valueType :: NValueF m r -> ValueType +valueType :: NValueF a m r -> ValueType valueType = \case - NVConstantF a -> case a of - NInt _ -> TInt - NFloat _ -> TFloat - NBool _ -> TBool - NNull -> TNull - NVStrF {} -> TString - NVListF {} -> TList - NVSetF {} -> TSet - NVClosureF {} -> TClosure - NVPathF {} -> TPath - NVBuiltinF {} -> TBuiltin + NVConstantF a -> case a of + NInt _ -> TInt + NFloat _ -> TFloat + NBool _ -> TBool + NNull -> TNull + NVStrF ns | stringHasContext ns -> TString HasContext + | otherwise -> TString NoContext + NVListF{} -> TList + NVSetF{} -> TSet + NVClosureF{} -> TClosure + NVPathF{} -> TPath + NVBuiltinF{} -> TBuiltin describeValue :: ValueType -> String describeValue = \case - TInt -> "an integer" - TFloat -> "a float" - TBool -> "a boolean" - TNull -> "a null" - TString -> "a string" - TList -> "a list" - TSet -> "an attr set" - TClosure -> "a function" - TPath -> "a path" - TBuiltin -> "a builtin function" - -instance Show (NValueF m (NThunk m)) where - show = show . describeValue . valueType - -instance Show (NValue m) where - show (NValue _ v) = show v - -instance Show (NThunk m) where - show (NThunk _ (Value v)) = show v - show (NThunk _ _) = "" + TInt -> "an integer" + TFloat -> "a float" + TBool -> "a boolean" + TNull -> "a null" + TString NoContext -> "a string" + TString HasContext -> "a string with context" + TList -> "a list" + TSet -> "an attr set" + TClosure -> "a function" + TPath -> "a path" + TBuiltin -> "a builtin function" -data ValueFrame m +data ValueFrame t f m = ForcingThunk - | ConcerningValue (NValue m) - | Comparison (NValue m) (NValue m) - | Addition (NValue m) (NValue m) - | Multiplication (NValue m) (NValue m) - | Division (NValue m) (NValue m) + | 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 - | CoercionToJsonNF (NValueNF m) + | CoercionToJson (NValue t f m) | CoercionFromJson A.Value - | ExpectationNF ValueType (NValueNF m) - | Expectation ValueType (NValue m) + | ExpectationNF ValueType (NValueNF t f m) + | Expectation ValueType (NValue t f m) deriving (Show, Typeable) -instance Typeable m => Exception (ValueFrame m) - -$(makeTraversals ''NValueF) -$(makeLenses ''Provenance) -$(makeLenses ''NThunk) -$(makeLenses ''NValue) +type MonadDataErrorContext t f m + = (Show t, Typeable t, Typeable m, Typeable f, MonadDataContext f m) -alterF :: (Eq k, Hashable k, Functor f) - => (Maybe v -> f (Maybe v)) -> k -> HashMap k v -> f (HashMap k v) -alterF f k m = f (M.lookup k m) <&> \case - Nothing -> M.delete k m - Just v -> M.insert k v m +instance MonadDataErrorContext t f m => Exception (ValueFrame t f m) -hashAt :: VarName -> Lens' (AttrSet v) (Maybe v) -hashAt = flip alterF +$(makeTraversals ''NValueF) +$(makeLenses ''NValue') -key :: Applicative f => VarName -> LensLike' f (NValue m) (Maybe (NThunk m)) -key k = baseValue._NVSetF._1.hashAt k +key + :: (Traversable f, Applicative g) + => VarName + -> LensLike' g (NValue' t f m a) (Maybe a) +key k = nValue . traverse . _NVSetF . _1 . hashAt k diff --git a/src/Nix/Value/Equal.hs b/src/Nix/Value/Equal.hs new file mode 100644 --- /dev/null +++ b/src/Nix/Value/Equal.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} +{-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-} + +module Nix.Value.Equal where + +import Control.Comonad +import Control.Monad +import Control.Monad.Free +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except +import Data.Align +import Data.Eq.Deriving +import Data.Functor.Classes +import Data.Functor.Identity +import qualified Data.HashMap.Lazy as M +import Data.These +import Nix.Atoms +import Nix.Frames +import Nix.String +import Nix.Thunk +import Nix.Utils +import Nix.Value + +checkComparable + :: (Framed e m, MonadDataErrorContext t f m) + => NValue t f m + -> NValue t f m + -> m () +checkComparable x y = case (x, y) of + (NVConstant (NFloat _), NVConstant (NInt _)) -> pure () + (NVConstant (NInt _), NVConstant (NFloat _)) -> pure () + (NVConstant (NInt _), NVConstant (NInt _)) -> pure () + (NVConstant (NFloat _), NVConstant (NFloat _)) -> pure () + (NVStr _, NVStr _) -> pure () + (NVPath _, NVPath _) -> pure () + _ -> throwError $ Comparison x y + +thunkEqM :: (MonadThunk t m (NValue t f m), Comonad f) => t -> t -> m Bool +thunkEqM lt rt = force lt $ \lv -> force rt $ \rv -> + let unsafePtrEq = case (lt, rt) of + (thunkId -> lid, thunkId -> rid) | lid == rid -> return True + _ -> valueEqM lv rv + in case (lv, rv) of + (NVClosure _ _, NVClosure _ _) -> unsafePtrEq + (NVList _ , NVList _ ) -> unsafePtrEq + (NVSet _ _ , NVSet _ _ ) -> unsafePtrEq + _ -> valueEqM lv rv + +-- | Checks whether two containers are equal, using the given item equality +-- predicate. If there are any item slots that don't match between the two +-- containers, the result will be False. +alignEqM + :: (Align f, Traversable f, Monad m) + => (a -> b -> m Bool) + -> f a + -> f b + -> m Bool +alignEqM eq fa fb = fmap (either (const False) (const True)) $ runExceptT $ do + pairs <- forM (Data.Align.align fa fb) $ \case + These a b -> return (a, b) + _ -> throwE () + forM_ pairs $ \(a, b) -> guard =<< lift (eq a b) + +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 + +isDerivationM :: Monad m => (t -> m (Maybe NixString)) -> AttrSet t -> m Bool +isDerivationM f m = case M.lookup "type" m of + Nothing -> pure False + Just t -> do + mres <- f t + case mres of + -- We should probably really make sure the context is empty here + -- but the C++ implementation ignores it. + Just s -> pure $ principledStringIgnoreContext s == "derivation" + Nothing -> pure False + +isDerivation :: Monad m => (t -> Maybe NixString) -> AttrSet t -> Bool +isDerivation f = runIdentity . isDerivationM (\x -> Identity (f x)) + +valueFEqM + :: Monad n + => (AttrSet a -> AttrSet a -> n Bool) + -> (a -> a -> n Bool) + -> NValueF p m a + -> NValueF p m a + -> n Bool +valueFEqM attrsEq eq = curry $ \case + (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 $ principledStringIgnoreContext ls == principledStringIgnoreContext rs + (NVListF ls , NVListF rs ) -> alignEqM eq ls rs + (NVSetF lm _, NVSetF rm _) -> attrsEq lm rm + (NVPathF lp , NVPathF rp ) -> pure $ lp == rp + _ -> pure False + +valueFEq + :: (AttrSet a -> AttrSet a -> Bool) + -> (a -> a -> Bool) + -> NValueF p m a + -> NValueF p m a + -> Bool +valueFEq attrsEq eq x y = runIdentity $ valueFEqM + (\x' y' -> Identity (attrsEq x' y')) + (\x' y' -> Identity (eq x' y')) + x + y + +compareAttrSetsM + :: Monad m + => (t -> m (Maybe NixString)) + -> (t -> t -> m Bool) + -> AttrSet t + -> AttrSet t + -> m Bool +compareAttrSetsM f eq lm rm = do + isDerivationM f lm >>= \case + True -> isDerivationM f rm >>= \case + True + | Just lp <- M.lookup "outPath" lm, Just rp <- M.lookup "outPath" rm -> eq + lp + rp + _ -> compareAttrs + _ -> compareAttrs + where compareAttrs = alignEqM eq lm rm + +compareAttrSets + :: (t -> Maybe NixString) + -> (t -> t -> Bool) + -> AttrSet t + -> AttrSet t + -> Bool +compareAttrSets f eq lm rm = runIdentity + $ compareAttrSetsM (\t -> Identity (f t)) (\x y -> Identity (eq x y)) lm rm + +valueEqM + :: (MonadThunk t m (NValue t f m), Comonad f) + => NValue t f m + -> NValue t f m + -> m Bool +valueEqM (NValue (extract -> x)) (NValue (extract -> y)) = valueFEqM + (compareAttrSetsM f thunkEqM) + thunkEqM + x + y + where + f t = force t $ \case + NVStr s -> pure $ Just s + _ -> pure Nothing + +valueNFEq :: Comonad f => NValueNF t f m -> NValueNF t f m -> Bool +valueNFEq (Pure _) (Pure _) = False +valueNFEq (Pure _) (Free _) = False +valueNFEq (Free _) (Pure _) = False +valueNFEq (Free (NValue (extract -> x))) (Free (NValue (extract -> y))) = + valueFEq (compareAttrSets f valueNFEq) valueNFEq x y + where + f (Pure _ ) = Nothing + f (Free (NVStr s)) = Just s + f _ = Nothing + +instance Eq1 (NValueF p m) where + liftEq _ (NVConstantF x) (NVConstantF y) = x == y + liftEq _ (NVStrF x) (NVStrF y) = x == y + liftEq eq (NVListF x) (NVListF y) = liftEq eq x y + liftEq eq (NVSetF x _ ) (NVSetF y _ ) = liftEq eq x y + liftEq _ (NVPathF x ) (NVPathF y ) = x == y + liftEq _ _ _ = False + +$(deriveEq1 ''NValue') diff --git a/src/Nix/Var.hs b/src/Nix/Var.hs new file mode 100644 --- /dev/null +++ b/src/Nix/Var.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Nix.Var where + +import Control.Monad.Ref +import Data.GADT.Compare +import Data.IORef +import Data.Maybe +import Data.STRef + +import Unsafe.Coerce + +type Var m = Ref m + +type MonadVar m = MonadAtomicRef m + +eqVar :: forall m a . GEq (Ref m) => Ref m a -> Ref m a -> Bool +eqVar a b = isJust $ geq a b + +newVar :: MonadRef m => a -> m (Ref m a) +newVar = newRef + +readVar :: MonadRef m => Ref m a -> m a +readVar = readRef + +writeVar :: MonadRef m => Ref m a -> a -> m () +writeVar = writeRef + +atomicModifyVar :: MonadAtomicRef m => Ref m a -> (a -> (a, b)) -> m b +atomicModifyVar = atomicModifyRef + +--TODO: Upstream GEq instances +instance GEq IORef where + a `geq` b = if a == unsafeCoerce b then Just $ unsafeCoerce Refl else Nothing + +instance GEq (STRef s) where + a `geq` b = if a == unsafeCoerce b then Just $ unsafeCoerce Refl else Nothing diff --git a/src/Nix/XML.hs b/src/Nix/XML.hs --- a/src/Nix/XML.hs +++ b/src/Nix/XML.hs @@ -1,54 +1,76 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} -module Nix.XML where +module Nix.XML (toXML) where -import Data.Fix -import qualified Data.HashMap.Lazy as M +import qualified Data.HashMap.Lazy as M import Data.List import Data.Ord -import qualified Data.Text as Text +import qualified Data.Text as Text import Nix.Atoms import Nix.Expr.Types +import Nix.String import Nix.Value import Text.XML.Light -toXML :: Functor m => NValueNF m -> String -toXML = (.) ((++ "\n") . - ("\n" ++) . - ppElement . - (\e -> Element (unqual "expr") [] [Elem e] Nothing)) - $ cata - $ \case - NVConstantF a -> case a of - NInt n -> mkElem "int" "value" (show n) - NFloat f -> mkElem "float" "value" (show f) - NBool b -> mkElem "bool" "value" (if b then "true" else "false") - NNull -> Element (unqual "null") [] [] Nothing +toXML :: forall t f m . MonadDataContext f m => NValueNF t f m -> NixString +toXML = + runWithStringContext + . fmap pp + . iterNValueNF (const (pure (mkElem "cycle" "value" ""))) phi + where + pp = + ("\n" <>) + . (<> "\n") + . Text.pack + . ppElement + . (\e -> Element (unqual "expr") [] [Elem e] Nothing) - NVStrF t _ -> mkElem "string" "value" (Text.unpack t) - NVListF l -> Element (unqual "list") [] (Elem <$> l) Nothing + phi :: NValue' t f m (WithStringContext Element) -> WithStringContext Element + phi = \case + NVConstant a -> case a of + NInt n -> return $ mkElem "int" "value" (show n) + NFloat f -> return $ mkElem "float" "value" (show f) + NBool b -> return $ mkElem "bool" "value" (if b then "true" else "false") + NNull -> return $ Element (unqual "null") [] [] Nothing - NVSetF s _ -> Element (unqual "attrs") [] - (map (\(k, v) -> Elem (Element (unqual "attr") - [Attr (unqual "name") (Text.unpack k)] - [Elem v] Nothing)) - (sortBy (comparing fst) $ M.toList s)) Nothing + NVStr str -> mkElem "string" "value" . Text.unpack <$> extractNixString str + NVList l -> sequence l + >>= \els -> return $ Element (unqual "list") [] (Elem <$> els) Nothing - NVClosureF p _ -> Element (unqual "function") [] (paramsXML p) Nothing - NVPathF fp -> mkElem "path" "value" fp - NVBuiltinF name _ -> mkElem "function" "name" name + NVSet s _ -> sequence s >>= \kvs -> return $ Element + (unqual "attrs") + [] + (map + (\(k, v) -> Elem + (Element (unqual "attr") + [Attr (unqual "name") (Text.unpack k)] + [Elem v] + Nothing + ) + ) + (sortBy (comparing fst) $ M.toList kvs) + ) + Nothing + NVClosure p _ -> + return $ Element (unqual "function") [] (paramsXML p) Nothing + NVPath fp -> return $ mkElem "path" "value" fp + NVBuiltin name _ -> return $ mkElem "function" "name" name + _ -> error "Pattern synonyms mask coverage" + mkElem :: String -> String -> String -> Element mkElem n a v = Element (unqual n) [Attr (unqual a) v] [] Nothing paramsXML :: Params r -> [Content] -paramsXML (Param name) = - [Elem $ mkElem "varpat" "name" (Text.unpack name)] +paramsXML (Param name) = [Elem $ mkElem "varpat" "name" (Text.unpack name)] paramsXML (ParamSet s b mname) = - [Elem $ Element (unqual "attrspat") (battr ++ nattr) (paramSetXML s) Nothing] - where - battr = [ Attr (unqual "ellipsis") "1" | b ] - nattr = maybe [] ((:[]) . Attr (unqual "name") . Text.unpack) mname + [Elem $ Element (unqual "attrspat") (battr <> nattr) (paramSetXML s) Nothing] + where + battr = [ Attr (unqual "ellipsis") "1" | b ] + nattr = maybe [] ((: []) . Attr (unqual "name") . Text.unpack) mname paramSetXML :: ParamSet r -> [Content] -paramSetXML = map (\(k,_) -> Elem $ mkElem "attr" "name" (Text.unpack k)) +paramSetXML = map (\(k, _) -> Elem $ mkElem "attr" "name" (Text.unpack k)) diff --git a/tests/EvalTests.hs b/tests/EvalTests.hs --- a/tests/EvalTests.hs +++ b/tests/EvalTests.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} @@ -8,15 +9,21 @@ module EvalTests (tests, genEvalCompareTests) where +import Control.Applicative ((<|>)) +import Control.Monad (when, unless) import Control.Monad.Catch -import Control.Monad (when) import Control.Monad.IO.Class -import qualified Data.HashMap.Lazy as M +-- import qualified Data.HashMap.Lazy as M +import Data.List ((\\)) import Data.Maybe (isJust) +import qualified Data.Set as S import Data.String.Interpolate.IsString import Data.Text (Text) import Data.Time import Nix +import Nix.TH +import Nix.Thunk.Standard +import Nix.Value.Equal import qualified System.Directory as D import System.Environment import System.FilePath @@ -37,6 +44,13 @@ assertNixEvalThrows "builtins.div 1 0.0" assertNixEvalThrows "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_basic_function = constantEqualText "2" "(a: a) 2" @@ -92,6 +106,9 @@ case_nested_with = constantEqualText "2" "with { x = 1; }; with { x = 2; }; x" +case_with_strictness = + constantEqualText "5" "let x = with x; with { a = 5; }; a; in x" + case_match_failure_null = constantEqualText "null" "builtins.match \"ab\" \"abc\"" @@ -119,6 +136,9 @@ case_find_file_failure_invalid_arg_no_path = assertNixEvalThrows "builtins.findFile [{ prefix=\"\"; }] \"files\"" +case_infinite_recursion = + assertNixEvalThrows "let foo = a: bar a; bar = a: foo a; in foo 3" + case_inherit_in_rec_set = constantEqualText "1" "let x = 1; in (rec { inherit x; }).x" @@ -142,6 +162,34 @@ )).success |] +-- github/orblivion (2018-08-05): Adding these failing tests so we fix this feature + +-- case_overrides = +-- constantEqualText' "2" [i| +-- let +-- +-- overrides = { a = 2; }; +-- +-- in (rec { +-- __overrides = overrides; +-- x = a; +-- a = 1; +-- }.__overrides.a) +-- |] + +-- case_inherit_overrides = +-- constantEqualText' "2" [i| +-- let +-- +-- __overrides = { a = 2; }; +-- +-- in (rec { +-- inherit __overrides; +-- x = a; +-- a = 1; +-- }.__overrides.a) +-- |] + case_unsafegetattrpos1 = constantEqualText "[ 6 20 ]" [i| let e = 1; @@ -277,44 +325,110 @@ 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_directory_pathexists = + constantEqualText "false" "builtins.pathExists \"/var/empty/invalid-directory\"" + -- jww (2018-05-02): This constantly changes! -- 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" + +case_mapattrs_builtin = + constantEqualText' "{ a = \"afoo\"; b = \"bbar\"; }" [i| + (builtins.mapAttrs (x: y: x + y) { + a = "foo"; + b = "bar"; + }) + |] + +-- 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_empty_string_equal_null_is_false = + constantEqualText "false" "\"\" == null" + +case_null_equal_empty_string_is_false = + constantEqualText "false" "null == \"\"" + +case_empty_string_not_equal_null_is_true = + constantEqualText "true" "\"\" != null" + +case_null_equal_not_empty_string_is_true = + constantEqualText "true" "null != \"\"" + +case_list_nested_bottom_diverges = + assertNixEvalThrows "let nested = [(let x = x; in x)]; in nested == nested" + +case_attrset_nested_bottom_diverges = + assertNixEvalThrows "let nested = { y = (let x = x; in x); }; in nested == nested" + +case_list_list_nested_bottom_equal = + constantEqualText "true" "let nested = [[(let x = x; in x)]]; in nested == nested" + +case_list_attrset_nested_bottom_equal = + constantEqualText "true" "let nested = [{ y = (let x = x; in x); }]; in nested == nested" + +case_list_function_nested_bottom_equal = + constantEqualText "true" "let nested = [(_: let x = x; in x)]; in nested == nested" + +case_attrset_list_nested_bottom_equal = + constantEqualText "true" "let nested = { y = [(let x = x; in x)];}; in nested == nested" + +case_attrset_attrset_nested_bottom_equal = + constantEqualText "true" "let nested = { y = { y = (let x = x; in x); }; }; in nested == nested" + +case_attrset_function_nested_bottom_equal = + constantEqualText "true" "let nested = { y = _: (let x = x; in x); }; in nested == nested" + ----------------------- tests :: TestTree tests = $testGroupGenerator genEvalCompareTests = do - files <- filter ((==".nix") . takeExtension) <$> D.listDirectory testDir - return $ testGroup "Eval comparison tests" $ map mkTestCase files - where - testDir = "tests/eval-compare" - mkTestCase f = testCase f $ assertEvalFileMatchesNix (testDir f) + td <- D.listDirectory testDir -instance (Show r, Show (NValueF m r), Eq r) => Eq (NValueF m r) where - NVConstantF x == NVConstantF y = x == y - NVStrF x _ == NVStrF y _ = x == y - NVListF x == NVListF y = and (zipWith (==) x y) - NVSetF x _ == NVSetF y _ = - M.keys x == M.keys y && - and (zipWith (==) (M.elems x) (M.elems y)) - NVPathF x == NVPathF y = x == y - x == y = error $ "Need to add comparison for values: " - ++ show x ++ " == " ++ show y + let unmaskedFiles = filter ((==".nix") . takeExtension) td + let files = unmaskedFiles \\ maskedFiles + return $ testGroup "Eval comparison tests" $ map (mkTestCase testDir) files + where + mkTestCase td f = testCase f $ assertEvalFileMatchesNix (td f) + constantEqual :: NExprLoc -> NExprLoc -> Assertion constantEqual a b = do - time <- liftIO getCurrentTime + time <- getCurrentTime let opts = defaultOptions time -- putStrLn =<< lint (stripAnnotation a) - a' <- runLazyM opts $ normalForm =<< nixEvalExprLoc Nothing a - -- putStrLn =<< lint (stripAnnotation b) - b' <- runLazyM opts $ normalForm =<< nixEvalExprLoc Nothing b - assertEqual "" a' b' + res <- runStandardIO opts $ do + a' <- normalForm =<< nixEvalExprLoc Nothing a + b' <- normalForm =<< nixEvalExprLoc Nothing b + return $ valueNFEq a' b' + assertBool "" res constantEqualText' :: Text -> Text -> Assertion constantEqualText' a b = do @@ -325,20 +439,32 @@ constantEqualText :: Text -> Text -> Assertion constantEqualText a b = do constantEqualText' a b - mres <- liftIO $ lookupEnv "MATCHING_TESTS" + mres <- liftIO $ lookupEnv "ALL_TESTS" <|> lookupEnv "MATCHING_TESTS" when (isJust mres) $ assertEvalMatchesNix b assertNixEvalThrows :: Text -> Assertion assertNixEvalThrows a = do - let Success a' = parseNixTextLoc a - time <- liftIO getCurrentTime - let opts = defaultOptions time - errored <- catch ((runLazyM opts $ normalForm =<< nixEvalExprLoc Nothing a') >> pure False) handler - if errored then - pure () - else - assertFailure "Did not catch nix exception" - where - handler :: NixException -> IO Bool - handler _ = pure True + let Success a' = parseNixTextLoc a + time <- getCurrentTime + let opts = defaultOptions time + errored <- catch + (False <$ runStandardIO opts + (normalForm =<< nixEvalExprLoc Nothing a')) + (\(_ :: NixException) -> pure True) + unless errored $ + assertFailure "Did not catch nix exception" + +freeVarsEqual :: Text -> [VarName] -> Assertion +freeVarsEqual a xs = do + let Success a' = parseNixText a + xs' = S.fromList xs + free = freeVars a' + assertEqual "" xs' free + +maskedFiles :: [FilePath] +maskedFiles = + [ "builtins.fetchurl-01.nix" ] + +testDir :: FilePath +testDir = "tests/eval-compare" diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -9,40 +9,32 @@ import qualified Control.Exception as Exc import Control.Applicative ((<|>)) import Control.Monad -import Control.Monad.IO.Class import Data.Fix -import Data.List (isInfixOf) +import Data.List (isSuffixOf) import Data.Maybe import Data.String.Interpolate.IsString import Data.Text (unpack) import Data.Time import qualified EvalTests import qualified Nix -import Nix.Exec import Nix.Expr.Types +import Nix.String import Nix.Options import Nix.Parser +import Nix.Thunk.Standard import Nix.Value import qualified NixLanguageTests import qualified ParserTests import qualified PrettyTests import qualified ReduceExprTests --- import qualified PrettyParseTests +import qualified PrettyParseTests import System.Directory import System.Environment import System.FilePath.Glob import System.Posix.Files -import System.Process import Test.Tasty import Test.Tasty.HUnit -cabalCorrectlyGenerated :: Assertion -cabalCorrectlyGenerated = do - output <- readCreateProcess (shell "hpack") "" - when ("modified manually" `isInfixOf` output) $ - errorWithoutStackTrace - "Edit package.yaml and re-generate hnix.cabal by running \"hpack\"" - ensureLangTestsPresent :: Assertion ensureLangTestsPresent = do exist <- fileExist "data/nix/tests/local.mk" @@ -63,14 +55,26 @@ url = "https://github.com/NixOS/nixpkgs/archive/#{rev}.tar.gz"; sha256 = "#{sha256}"; }|]) $ \expr -> do - NVStr dir _ <- do - time <- liftIO getCurrentTime - runLazyM (defaultOptions time) $ Nix.nixEvalExprLoc Nothing expr + NVStr ns <- do + time <- getCurrentTime + runStandardIO (defaultOptions time) $ + Nix.nixEvalExprLoc Nothing expr + let dir = hackyStringIgnoreContext ns + exists <- fileExist (unpack dir) + unless exists $ + errorWithoutStackTrace $ + "Directory " ++ show dir ++ " does not exist" files <- globDir1 (compile "**/*.nix") (unpack dir) - forM_ files $ \file -> - -- Parse and deepseq the resulting expression tree, to ensure the - -- parser is fully executed. - consider file (parseNixFileLoc file) $ Exc.evaluate . force + when (length files == 0) $ + errorWithoutStackTrace $ + "Directory " ++ show dir ++ " does not have any files" + forM_ 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 + return () v -> error $ "Unexpected parse from default.nix: " ++ show v where getExpr k m = let Just (Just r) = lookup k m in r @@ -88,24 +92,20 @@ evalComparisonTests <- EvalTests.genEvalCompareTests let allOrLookup var = lookupEnv "ALL_TESTS" <|> lookupEnv var nixpkgsTestsEnv <- allOrLookup "NIXPKGS_TESTS" - -- prettyTestsEnv <- lookupEnv "PRETTY_TESTS" - hpackTestsEnv <- allOrLookup "HPACK_TESTS" + prettyTestsEnv <- lookupEnv "PRETTY_TESTS" pwd <- getCurrentDirectory setEnv "NIX_REMOTE" ("local?root=" ++ pwd ++ "/") defaultMain $ testGroup "hnix" $ - [ testCase "hnix.cabal correctly generated" cabalCorrectlyGenerated - | isJust hpackTestsEnv ] ++ [ ParserTests.tests , EvalTests.tests , PrettyTests.tests , ReduceExprTests.tests] ++ - -- [ PrettyParseTests.tests - -- (fromIntegral (read (fromMaybe "0" prettyTestsEnv) :: Int)) ] ++ + [ PrettyParseTests.tests + (fromIntegral (read (fromMaybe "0" prettyTestsEnv) :: Int)) ] ++ [ evalComparisonTests ] ++ [ testCase "Nix language tests present" ensureLangTestsPresent , nixLanguageTests ] ++ [ testCase "Nixpkgs parses without errors" ensureNixpkgsCanParse | isJust nixpkgsTestsEnv ] - diff --git a/tests/NixLanguageTests.hs b/tests/NixLanguageTests.hs --- a/tests/NixLanguageTests.hs +++ b/tests/NixLanguageTests.hs @@ -4,17 +4,21 @@ module NixLanguageTests (genTests) where -import Control.Arrow ((&&&)) +import Control.Arrow ( (&&&) ) import Control.Exception import Control.Monad import Control.Monad.IO.Class import Control.Monad.ST -import Data.List (delete, sort) -import Data.List.Split (splitOn) -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.Text as Text -import qualified Data.Text.IO as Text +import Data.List ( delete + , sort + ) +import Data.List.Split ( splitOn ) +import Data.Map ( Map ) +import qualified Data.Map as Map +import Data.Set ( Set ) +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Text.IO as Text import Data.Time import GHC.Exts import Nix.Lint @@ -22,12 +26,15 @@ import Nix.Options.Parser import Nix.Parser import Nix.Pretty +import Nix.String import Nix.Utils import Nix.XML -import qualified Options.Applicative as Opts +import qualified Options.Applicative as Opts import System.Environment import System.FilePath -import System.FilePath.Glob (compile, globDir1) +import System.FilePath.Glob ( compile + , globDir1 + ) import Test.Tasty import Test.Tasty.HUnit import TestCommon @@ -55,105 +62,137 @@ groupBy :: Ord k => (v -> k) -> [v] -> Map k [v] groupBy key = Map.fromListWith (++) . map (key &&& pure) +-- | New tests, which have never yet passed. Once any of these is passing, +-- please remove it from this list. Do not add tests to this list if they have +-- previously passed. +newFailingTests :: Set String +newFailingTests = Set.fromList + [ "eval-okay-path" + , "eval-okay-fromTOML" + , "eval-okay-context-introspection" + , "eval-okay-concatmap" + , "eval-okay-builtins-add" + ] + genTests :: IO TestTree genTests = do - testFiles <- sort + testFiles <- + sort -- jww (2018-05-07): Temporarily disable this test until #128 is fixed. - . filter ((/= "eval-okay-path") . takeBaseName) - . filter ((/= ".xml") . takeExtension) - <$> globDir1 (compile "*-*-*.*") "data/nix/tests/lang" + . 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 = map mkTestGroup (Map.toList testsByType) - return $ localOption (mkTimeout 2000000) - $ testGroup "Nix (upstream) language tests" testGroups - where - testType (fullpath, _files) = - take 2 $ splitOn "-" $ takeFileName fullpath - mkTestGroup (kind, tests) = - testGroup (unwords kind) $ map (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 - _ -> error $ "Unexpected: " ++ show kind + return $ localOption (mkTimeout 2000000) $ testGroup + "Nix (upstream) language tests" + testGroups + where + testType (fullpath, _files) = take 2 $ splitOn "-" $ takeFileName fullpath + mkTestGroup (kind, tests) = + testGroup (unwords kind) $ map (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 + _ -> error $ "Unexpected: " ++ show kind assertParse :: Options -> FilePath -> Assertion assertParse _opts file = parseNixFileLoc file >>= \case Success _expr -> return () -- pure $! runST $ void $ lint opts expr - Failure err -> - assertFailure $ "Failed to parse " ++ file ++ ":\n" ++ show err + Failure err -> + assertFailure $ "Failed to parse " ++ file ++ ":\n" ++ show err assertParseFail :: Options -> FilePath -> Assertion assertParseFail opts file = do - eres <- parseNixFileLoc file - catch (case eres of - Success expr -> do - _ <- pure $! runST $ void $ lint opts expr - assertFailure $ "Unexpected success parsing `" - ++ file ++ ":\nParsed value: " ++ show expr - Failure _ -> return ()) $ \(_ :: SomeException) -> - return () + eres <- parseNixFileLoc file + catch + (case eres of + Success expr -> do + _ <- pure $! runST $ void $ lint opts expr + assertFailure + $ "Unexpected success parsing `" + ++ file + ++ ":\nParsed value: " + ++ show expr + Failure _ -> return () + ) + $ \(_ :: SomeException) -> return () assertLangOk :: Options -> FilePath -> Assertion assertLangOk opts file = do - actual <- printNix <$> hnixEvalFile opts (file ++ ".nix") + actual <- printNix <$> hnixEvalFile opts (file ++ ".nix") expected <- Text.readFile $ file ++ ".exp" assertEqual "" expected $ Text.pack (actual ++ "\n") assertLangOkXml :: Options -> FilePath -> Assertion assertLangOkXml opts file = do - actual <- toXML <$> hnixEvalFile opts (file ++ ".nix") + actual <- principledStringIgnoreContext . toXML <$> hnixEvalFile + opts + (file ++ ".nix") expected <- Text.readFile $ file ++ ".exp.xml" - assertEqual "" expected $ Text.pack actual + assertEqual "" expected actual assertEval :: Options -> [FilePath] -> Assertion assertEval _opts files = do - time <- liftIO getCurrentTime - let opts = defaultOptions time - case delete ".nix" $ sort $ map takeExtensions files of - [] -> () <$ hnixEvalFile opts (name ++ ".nix") - [".exp"] -> assertLangOk opts name - [".exp.xml"] -> assertLangOkXml opts name - [".exp.disabled"] -> return () - [".exp-disabled"] -> return () - [".exp", ".flags"] -> do - liftIO $ unsetEnv "NIX_PATH" - flags <- Text.readFile (name ++ ".flags") - let flags' | Text.last flags == '\n' = Text.init flags - | otherwise = flags - case Opts.execParserPure Opts.defaultPrefs (nixOptionsInfo time) - (fixup (map Text.unpack (Text.splitOn " " flags'))) of - Opts.Failure err -> errorWithoutStackTrace $ - "Error parsing flags from " ++ name ++ ".flags: " - ++ show err - Opts.Success opts' -> - assertLangOk - (opts' { include = include opts' ++ - [ "nix=../../../../data/nix/corepkgs" - , "lang/dir4" - , "lang/dir5" ] }) - name - Opts.CompletionInvoked _ -> error "unused" - _ -> assertFailure $ "Unknown test type " ++ show files - where - name = "data/nix/tests/lang/" - ++ the (map (takeFileName . dropExtensions) files) + time <- liftIO getCurrentTime + let opts = defaultOptions time + case delete ".nix" $ sort $ map takeExtensions files of + [] -> () <$ hnixEvalFile opts (name ++ ".nix") + [".exp" ] -> assertLangOk opts name + [".exp.xml" ] -> assertLangOkXml opts name + [".exp.disabled"] -> return () + [".exp-disabled"] -> return () + [".exp", ".flags"] -> do + liftIO $ unsetEnv "NIX_PATH" + flags <- Text.readFile (name ++ ".flags") + let flags' | Text.last flags == '\n' = Text.init flags + | otherwise = flags + case + Opts.execParserPure + Opts.defaultPrefs + (nixOptionsInfo time) + (fixup (map Text.unpack (Text.splitOn " " flags'))) + of + Opts.Failure err -> + errorWithoutStackTrace + $ "Error parsing flags from " + ++ name + ++ ".flags: " + ++ show err + Opts.Success opts' -> assertLangOk + (opts' + { include = include opts' + ++ [ "nix=../../../../data/nix/corepkgs" + , "lang/dir4" + , "lang/dir5" + ] + } + ) + name + Opts.CompletionInvoked _ -> error "unused" + _ -> assertFailure $ "Unknown test type " ++ show files + where + name = + "data/nix/tests/lang/" ++ the (map (takeFileName . dropExtensions) files) - 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 [] = [] + 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 [] = [] assertEvalFail :: FilePath -> Assertion assertEvalFail file = catch ?? (\(_ :: SomeException) -> return ()) $ do - time <- liftIO getCurrentTime + time <- liftIO getCurrentTime evalResult <- printNix <$> hnixEvalFile (defaultOptions time) file - evalResult `seq` assertFailure $ - file ++ " should not evaluate.\nThe evaluation result was `" - ++ evalResult ++ "`." + evalResult + `seq` assertFailure + $ file + ++ " should not evaluate.\nThe evaluation result was `" + ++ evalResult + ++ "`." diff --git a/tests/ParserTests.hs b/tests/ParserTests.hs --- a/tests/ParserTests.hs +++ b/tests/ParserTests.hs @@ -10,9 +10,10 @@ import Data.Fix import Data.List.NonEmpty (NonEmpty(..)) -import Data.Semigroup import Data.String.Interpolate.IsString -import Data.Text (Text, unpack, pack) +import Data.Text (Text, unpack) +import Data.Text.Prettyprint.Doc +import Data.Text.Prettyprint.Doc.Render.Text import Nix.Atoms import Nix.Expr import Nix.Parser @@ -20,7 +21,6 @@ import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.TH -import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>)) case_constant_int = assertParseText "234" $ mkInt 234 @@ -275,6 +275,9 @@ (mkPath False "./def") where select = Fix $ NSelect (mkSym "f") (mkSelector "b") Nothing +case_select_keyword = do + assertParseText "{ false = \"foo\"; }" $ Fix $ NSet [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 $ @@ -391,9 +394,9 @@ assertParsePrint :: Text -> Text -> Assertion assertParsePrint src expect = let Success expr = parseNixTextLoc src - result = displayS - . renderPretty 0.4 80 + result = renderStrict + . layoutPretty (LayoutOptions $ AvailablePerLine 80 0.4) . prettyNix . stripAnnotation $ expr - in assertEqual "" expect (pack (result "")) + in assertEqual "" expect result diff --git a/tests/PrettyParseTests.hs b/tests/PrettyParseTests.hs --- a/tests/PrettyParseTests.hs +++ b/tests/PrettyParseTests.hs @@ -9,27 +9,31 @@ {-# OPTIONS -Wno-orphans#-} -module PrettyParseTests where +module PrettyParseTests where import Data.Algorithm.Diff import Data.Algorithm.DiffOutput import Data.Char import Data.Fix -import qualified Data.List.NonEmpty as NE -import Data.Text (Text, pack) +import qualified Data.List.NonEmpty as NE +import Data.Text ( Text + , pack + ) +import Data.Text.Prettyprint.Doc import Hedgehog -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range import Nix.Atoms import Nix.Expr import Nix.Parser import Nix.Pretty import Test.Tasty import Test.Tasty.Hedgehog -import Text.Megaparsec (Pos, SourcePos, mkPos) -import Text.PrettyPrint.ANSI.Leijen ((), text) -import qualified Text.PrettyPrint.ANSI.Leijen as P -import qualified Text.Show.Pretty as PS +import Text.Megaparsec ( Pos + , SourcePos + , mkPos + ) +import qualified Text.Show.Pretty as PS asciiString :: MonadGen m => m String asciiString = Gen.list (Range.linear 1 15) Gen.lower @@ -45,95 +49,90 @@ genSourcePos = SourcePos <$> asciiString <*> genPos <*> genPos genKeyName :: Gen (NKeyName NExpr) -genKeyName = Gen.choice [ DynamicKey <$> genAntiquoted genString - , StaticKey <$> asciiText ] +genKeyName = + Gen.choice [DynamicKey <$> genAntiquoted genString, StaticKey <$> asciiText] genAntiquoted :: Gen a -> Gen (Antiquoted a NExpr) -genAntiquoted gen = Gen.choice - [ Plain <$> gen - , pure EscapedNewline - , Antiquoted <$> genExpr - ] +genAntiquoted gen = + Gen.choice [Plain <$> gen, pure EscapedNewline, Antiquoted <$> genExpr] genBinding :: Gen (Binding NExpr) genBinding = Gen.choice [ NamedVar <$> genAttrPath <*> genExpr <*> genSourcePos - , Inherit <$> Gen.maybe genExpr - <*> Gen.list (Range.linear 0 5) genKeyName - <*> genSourcePos + , Inherit + <$> Gen.maybe genExpr + <*> Gen.list (Range.linear 0 5) genKeyName + <*> genSourcePos ] genString :: Gen (NString NExpr) genString = Gen.choice [ DoubleQuoted <$> Gen.list (Range.linear 0 5) (genAntiquoted asciiText) - , Indented <$> Gen.int (Range.linear 0 10) - <*> Gen.list (Range.linear 0 5) (genAntiquoted asciiText) + , Indented <$> Gen.int (Range.linear 0 10) <*> Gen.list + (Range.linear 0 5) + (genAntiquoted asciiText) ] genAttrPath :: Gen (NAttrPath NExpr) -genAttrPath = (NE.:|) <$> genKeyName - <*> Gen.list (Range.linear 0 4) genKeyName +genAttrPath = (NE.:|) <$> genKeyName <*> Gen.list (Range.linear 0 4) genKeyName genParams :: Gen (Params NExpr) genParams = Gen.choice - [ Param <$> asciiText - , ParamSet <$> Gen.list (Range.linear 0 10) ((,) <$> asciiText - <*> Gen.maybe genExpr) - <*> Gen.bool - <*> Gen.choice [pure Nothing, Just <$> asciiText] + [ Param <$> asciiText + , ParamSet + <$> Gen.list (Range.linear 0 10) ((,) <$> asciiText <*> Gen.maybe genExpr) + <*> Gen.bool + <*> Gen.choice [pure Nothing, Just <$> asciiText] ] genAtom :: Gen NAtom genAtom = Gen.choice - [ NInt <$> Gen.integral (Range.linear 0 1000) + [ NInt <$> Gen.integral (Range.linear 0 1000) , NFloat <$> Gen.float (Range.linearFrac 0.0 1000.0) - , NBool <$> Gen.bool - , pure NNull ] + , NBool <$> Gen.bool + , pure NNull + ] -- This is written by hand so we can use `fairList` rather than the normal -- list Arbitrary instance which makes the generator terminate. The -- distribution is not scientifically chosen. 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 $ \(Size n) -> Fix <$> if n < 2 + then Gen.choice [genConstant, genStr, genSym, genLiteralPath, genEnvPath] + else Gen.frequency + [ (1 , genConstant) + , (1 , genSym) + , (4 , Gen.resize (Size (n `div` 3)) genIf) + , (10, genRecSet) + , (20, genSet) + , (5 , genList) + , (2 , genUnary) + , (2, Gen.resize (Size (n `div` 3)) genBinary) + , (3, Gen.resize (Size (n `div` 3)) genSelect) + , (20, Gen.resize (Size (n `div` 2)) genAbs) + , (2, Gen.resize (Size (n `div` 2)) genHasAttr) + , (10, Gen.resize (Size (n `div` 2)) genLet) + , (10, Gen.resize (Size (n `div` 2)) genWith) + , (1, Gen.resize (Size (n `div` 2)) genAssert) + ] where - genConstant = NConstant <$> genAtom - genStr = NStr <$> genString - genSym = NSym <$> asciiText - genList = NList <$> fairList genExpr - genSet = NSet <$> fairList genBinding - genRecSet = NRecSet <$> fairList genBinding + genConstant = NConstant <$> genAtom + genStr = NStr <$> genString + genSym = NSym <$> asciiText + genList = NList <$> fairList genExpr + genSet = NSet <$> fairList genBinding + genRecSet = NRecSet <$> fairList genBinding genLiteralPath = NLiteralPath . ("./" ++) <$> asciiString - genEnvPath = NEnvPath <$> asciiString - genUnary = NUnary <$> Gen.enumBounded <*> genExpr - genBinary = NBinary <$> Gen.enumBounded <*> genExpr <*> genExpr - genSelect = NSelect <$> genExpr <*> genAttrPath <*> Gen.maybe genExpr - genHasAttr = NHasAttr <$> genExpr <*> genAttrPath - genAbs = NAbs <$> genParams <*> genExpr - genLet = NLet <$> fairList genBinding <*> genExpr - genIf = NIf <$> genExpr <*> genExpr <*> genExpr - genWith = NWith <$> genExpr <*> genExpr - genAssert = NAssert <$> genExpr <*> genExpr + genEnvPath = NEnvPath <$> asciiString + genUnary = NUnary <$> Gen.enumBounded <*> genExpr + genBinary = NBinary <$> Gen.enumBounded <*> genExpr <*> genExpr + genSelect = NSelect <$> genExpr <*> genAttrPath <*> Gen.maybe genExpr + genHasAttr = NHasAttr <$> genExpr <*> genAttrPath + genAbs = NAbs <$> genParams <*> genExpr + genLet = NLet <$> fairList genBinding <*> genExpr + genIf = NIf <$> genExpr <*> genExpr <*> genExpr + genWith = NWith <$> genExpr <*> genExpr + genAssert = NAssert <$> genExpr <*> genExpr -- | Useful when there are recursive positions at each element of the list as -- it divides the size by the length of the generated list. @@ -148,86 +147,87 @@ normalize :: NExpr -> NExpr normalize = cata $ \case - NConstant (NInt n) | n < 0 -> Fix (NUnary NNeg (Fix (NConstant (NInt (negate n))))) - NConstant (NFloat n) | n < 0 -> Fix (NUnary NNeg (Fix (NConstant (NFloat (negate n))))) + NConstant (NInt n) | n < 0 -> + Fix (NUnary NNeg (Fix (NConstant (NInt (negate n))))) + NConstant (NFloat n) | n < 0 -> + Fix (NUnary NNeg (Fix (NConstant (NFloat (negate n))))) - NSet binds -> Fix (NSet (map normBinding binds)) - NRecSet binds -> Fix (NRecSet (map normBinding binds)) - NLet binds r -> Fix (NLet (map normBinding binds) r) + NSet binds -> Fix (NSet (map normBinding binds)) + NRecSet binds -> Fix (NRecSet (map normBinding binds)) + NLet binds r -> Fix (NLet (map normBinding binds) r) - NAbs params r -> Fix (NAbs (normParams params) r) + NAbs params r -> Fix (NAbs (normParams params) r) - r -> Fix r + r -> Fix r where - normBinding (NamedVar path r pos) = NamedVar (NE.map normKey path) r pos - normBinding (Inherit mr names pos) = Inherit mr (map normKey names) pos + normBinding (NamedVar path r pos) = NamedVar (NE.map normKey path) r pos + normBinding (Inherit mr names pos) = Inherit mr (map normKey names) pos normKey (DynamicKey quoted) = DynamicKey (normAntiquotedString quoted) - normKey (StaticKey name) = StaticKey name + normKey (StaticKey name ) = StaticKey name - normAntiquotedString :: Antiquoted (NString NExpr) NExpr - -> Antiquoted (NString NExpr) NExpr - normAntiquotedString (Plain (DoubleQuoted [EscapedNewline])) = - EscapedNewline + normAntiquotedString + :: Antiquoted (NString NExpr) NExpr -> Antiquoted (NString NExpr) NExpr + normAntiquotedString (Plain (DoubleQuoted [EscapedNewline])) = EscapedNewline normAntiquotedString (Plain (DoubleQuoted strs)) = - let strs' = map normAntiquotedText strs - in if strs == strs' - then Plain (DoubleQuoted strs) - else normAntiquotedString (Plain (DoubleQuoted strs')) + let strs' = map normAntiquotedText strs + in if strs == strs' + then Plain (DoubleQuoted strs) + else normAntiquotedString (Plain (DoubleQuoted strs')) normAntiquotedString r = r normAntiquotedText :: Antiquoted Text NExpr -> Antiquoted Text NExpr - normAntiquotedText (Plain "\n") = EscapedNewline + normAntiquotedText (Plain "\n" ) = EscapedNewline normAntiquotedText (Plain "''\n") = EscapedNewline - normAntiquotedText r = r + normAntiquotedText r = r normParams (ParamSet binds var (Just "")) = ParamSet binds var Nothing - normParams r = r + 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 (pretty p) + let prog = show (prettyNix p) case parse (pack prog) of Failure s -> do - footnote $ show $ - text "Parse failed:" text (show s) - P.<$> P.indent 2 (pretty p) - discard + footnote $ show $ vsep + [fillSep ["Parse failed:", pretty (show s)], indent 2 (prettyNix p)] + discard Success v - | equivUpToNormalization p v -> success - | otherwise -> do - let pp = normalise prog - pv = normalise (show (pretty v)) - footnote $ show $ - text "----------------------------------------" - P.<$> text "Expr before:" P.<$> P.indent 2 (text (PS.ppShow p)) - P.<$> text "----------------------------------------" - P.<$> text "Expr after:" P.<$> P.indent 2 (text (PS.ppShow v)) - P.<$> text "----------------------------------------" - P.<$> text "Pretty before:" P.<$> P.indent 2 (text prog) - P.<$> text "----------------------------------------" - P.<$> text "Pretty after:" P.<$> P.indent 2 (pretty v) - P.<$> text "----------------------------------------" - P.<$> text "Normalised before:" P.<$> P.indent 2 (text pp) - P.<$> text "----------------------------------------" - P.<$> text "Normalised after:" P.<$> P.indent 2 (text pv) - P.<$> text "========================================" - P.<$> text "Normalised diff:" - P.<$> text (ppDiff (diff pp pv)) - P.<$> text "========================================" - assert (pp == pv) - where - pretty = prettyNix - parse = parseNixText + | equivUpToNormalization p v -> success + | otherwise -> do + let pp = normalise prog + pv = normalise (show (prettyNix v)) + footnote + $ show + $ vsep + $ [ "----------------------------------------" + , vsep ["Expr before:", indent 2 (pretty (PS.ppShow p))] + , "----------------------------------------" + , vsep ["Expr after:", indent 2 (pretty (PS.ppShow v))] + , "----------------------------------------" + , vsep ["Pretty before:", indent 2 (pretty prog)] + , "----------------------------------------" + , vsep ["Pretty after:", indent 2 (prettyNix v)] + , "----------------------------------------" + , vsep ["Normalised before:", indent 2 (pretty pp)] + , "----------------------------------------" + , vsep ["Normalised after:", indent 2 (pretty pv)] + , "========================================" + , vsep ["Normalised diff:", pretty (ppDiff (diff pp pv))] + , "========================================" + ] + assert (pp == pv) + where + parse = parseNixText - normalise = unlines . map (reverse . dropWhile isSpace . reverse) . lines + normalise = unlines . map (reverse . dropWhile isSpace . reverse) . lines - diff :: String -> String -> [Diff [String]] - diff s1 s2 = getDiff (map (:[]) (lines s1)) (map (:[]) (lines s2)) + diff :: String -> String -> [Diff [String]] + diff s1 s2 = getDiff (map (: []) (lines s1)) (map (: []) (lines s2)) tests :: TestLimit -> TestTree tests n = testProperty "Pretty/Parse Property" $ withTests n $ property $ do - x <- forAll genExpr - prop_prettyparse x + x <- forAll genExpr + prop_prettyparse x diff --git a/tests/PrettyTests.hs b/tests/PrettyTests.hs --- a/tests/PrettyTests.hs +++ b/tests/PrettyTests.hs @@ -2,36 +2,37 @@ {-# LANGUAGE OverloadedStrings #-} module PrettyTests (tests) where -import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.TH +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.TH -import Nix.Expr -import Nix.Pretty +import Nix.Expr +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}''" + 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}\"" + assertPretty (mkStr "echo $foo") "\"echo \\$foo\"" + assertPretty (mkStr "echo ${foo}") "\"echo \\${foo}\"" case_function_params :: Assertion case_function_params = - assertPretty (mkFunction (mkParamset [] True) (mkInt 3)) "{ ... }:\n 3" + assertPretty (mkFunction (mkParamset [] True) (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" + 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 e s = assertEqual ("When pretty-printing " ++ show e) s . show $ prettyNix e +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,44 +1,45 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} module ReduceExprTests (tests) where -import Data.Fix -import Test.Tasty -import Test.Tasty.HUnit +import Data.Fix +import Test.Tasty +import Test.Tasty.HUnit -import Nix.Atoms -import Nix.Expr.Types -import Nix.Expr.Types.Annotated -import Nix.Parser -import Nix.Reduce (reduceExpr) +import Nix.Atoms +import Nix.Expr.Types +import Nix.Expr.Types.Annotated +import Nix.Parser +import Nix.Reduce ( reduceExpr ) tests :: TestTree -tests = testGroup "Expr Reductions" - [ testCase "Non nested NSelect on set should be reduced" $ - cmpReduceResult selectBasic selectBasicExpect, - testCase "Nested NSelect on set should be reduced" $ - cmpReduceResult selectNested selectNestedExpect, - testCase "Non nested NSelect with incorrect attrpath shouldn't be reduced" $ - shouldntReduce selectIncorrectAttrPath, - testCase "Nested NSelect with incorrect attrpath shouldn't be reduced" $ - shouldntReduce selectNestedIncorrectAttrPath - ] +tests = testGroup + "Expr Reductions" + [ testCase "Non nested NSelect on set should be reduced" + $ cmpReduceResult selectBasic selectBasicExpect + , testCase "Nested NSelect on set should be reduced" + $ cmpReduceResult selectNested selectNestedExpect + , testCase "Non nested NSelect with incorrect attrpath shouldn't be reduced" + $ shouldntReduce selectIncorrectAttrPath + , testCase "Nested NSelect with incorrect attrpath shouldn't be reduced" + $ shouldntReduce selectNestedIncorrectAttrPath + ] assertSucc :: Result a -> IO a assertSucc (Success a) = pure a assertSucc (Failure d) = assertFailure $ show d -cmpReduceResult :: Result NExprLoc -> NExpr -> Assertion +cmpReduceResult :: Result NExprLoc -> NExpr -> Assertion cmpReduceResult r e = do - r <- assertSucc r - r <- stripAnnotation <$> reduceExpr Nothing r - r @?= e + r <- assertSucc r + r <- stripAnnotation <$> reduceExpr Nothing r + r @?= e shouldntReduce :: Result NExprLoc -> Assertion shouldntReduce r = do - r <- assertSucc r - rReduced <- reduceExpr Nothing r - r @?= rReduced + r <- assertSucc r + rReduced <- reduceExpr Nothing r + r @?= rReduced selectBasic :: Result NExprLoc selectBasic = parseNixTextLoc "{b=2;a=42;}.a" diff --git a/tests/TestCommon.hs b/tests/TestCommon.hs --- a/tests/TestCommon.hs +++ b/tests/TestCommon.hs @@ -1,46 +1,54 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} module TestCommon where -import Control.Monad.Catch -import Control.Monad.IO.Class -import Data.Text (Text, unpack) -import Data.Time -import Nix -import System.Environment -import System.IO -import System.Posix.Files -import System.Posix.Temp -import System.Process -import Test.Tasty.HUnit +import Control.Monad.Catch +import Control.Monad.IO.Class +import Data.Text ( Text + , unpack + ) +import Data.Time +import Nix +import Nix.Exec ( ) +import Nix.Thunk.Standard +import System.Environment +import System.IO +import System.Posix.Files +import System.Posix.Temp +import System.Process +import Test.Tasty.HUnit -hnixEvalFile :: Options -> FilePath -> IO (NValueNF (Lazy IO)) +hnixEvalFile :: Options -> FilePath -> IO (StandardValueNF IO) hnixEvalFile opts file = do parseResult <- parseNixFileLoc file case parseResult of - Failure err -> - error $ "Parsing failed for file `" ++ file ++ "`.\n" ++ show err + Failure err -> + error $ "Parsing failed for file `" ++ file ++ "`.\n" ++ show err Success expr -> do - setEnv "TEST_VAR" "foo" - runLazyM opts $ - catch (evaluateExpression (Just file) nixEvalExprLoc - normalForm expr) $ \case - NixException frames -> - errorWithoutStackTrace . show - =<< renderFrames @(NThunk (Lazy IO)) frames + setEnv "TEST_VAR" "foo" + runStandardIO opts + $ catch (evaluateExpression (Just file) nixEvalExprLoc normalForm expr) + $ \case + NixException frames -> + errorWithoutStackTrace + . show + =<< renderFrames @(StandardValue IO) @(StandardThunk IO) frames -hnixEvalText :: Options -> Text -> IO (NValueNF (Lazy IO)) +hnixEvalText :: Options -> Text -> IO (StandardValueNF IO) hnixEvalText opts src = case parseNixText src of - Failure err -> - error $ "Parsing failed for expressien `" - ++ unpack src ++ "`.\n" ++ show err - Success expr -> - runLazyM opts $ normalForm =<< nixEvalExpr Nothing expr + Failure err -> + error + $ "Parsing failed for expressien `" + ++ unpack src + ++ "`.\n" + ++ show err + Success expr -> runStandardIO opts $ normalForm =<< nixEvalExpr Nothing expr nixEvalString :: String -> IO String nixEvalString expr = do - (fp,h) <- mkstemp "nix-test-eval" + (fp, h) <- mkstemp "nix-test-eval" hPutStr h expr hClose h res <- nixEvalFile fp @@ -52,16 +60,15 @@ assertEvalFileMatchesNix :: FilePath -> Assertion assertEvalFileMatchesNix fp = do - time <- liftIO getCurrentTime - hnixVal <- (++"\n") . printNix <$> hnixEvalFile (defaultOptions time) fp - nixVal <- nixEvalFile fp + time <- liftIO getCurrentTime + hnixVal <- (++ "\n") . printNix <$> hnixEvalFile (defaultOptions time) fp + nixVal <- nixEvalFile fp assertEqual fp nixVal hnixVal assertEvalMatchesNix :: Text -> Assertion assertEvalMatchesNix expr = do - time <- liftIO getCurrentTime - hnixVal <- (++"\n") . printNix <$> hnixEvalText (defaultOptions time) expr - nixVal <- nixEvalString expr' + time <- liftIO getCurrentTime + hnixVal <- (++ "\n") . printNix <$> hnixEvalText (defaultOptions time) expr + nixVal <- nixEvalString expr' assertEqual expr' nixVal hnixVal - where - expr' = unpack expr + where expr' = unpack expr diff --git a/tests/eval-compare/builtins.string.store.nix b/tests/eval-compare/builtins.string.store.nix new file mode 100644 --- /dev/null +++ b/tests/eval-compare/builtins.string.store.nix @@ -0,0 +1,1 @@ +"${builtins.storeDir}"