diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 9b5b322dde..0faec4c9bd 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -128,7 +128,7 @@ jobs: # launch `stack exec`. The actual glob checks happen in a temporary directory. run: | apt-get install -y tree - ../ci/fix-home stack exec bash ../glob-test.sh + ../ci/fix-home stack --haddock --no-haddock-deps exec bash ../glob-test.sh - name: "(Linux only) Build the entire package set" if: startsWith(matrix.image, 'haskell') @@ -145,15 +145,16 @@ jobs: # We upgrade npm to fix this run: | apt-get install -y jq - ../ci/fix-home stack --haddock exec ../ci/build-package-set.sh + ../ci/fix-home stack --haddock --no-haddock-deps exec ../ci/build-package-set.sh - name: Verify that 'libtinfo' isn't in binary if: runner.os == 'Linux' working-directory: "sdist-test" run: | - if [ $(ldd $(../ci/fix-home stack path --local-doc-root)/../bin/purs | grep 'libtinfo' | wc -l) -ge 1 ]; then + purs_bin=$(../ci/fix-home stack --haddock --no-haddock-deps exec -- which purs) + if [ $(ldd "$purs_bin" | grep 'libtinfo' | wc -l) -ge 1 ]; then echo "libtinfo detected" - ldd $(../ci/fix-home stack path --local-doc-root)/../bin/purs | grep 'libtinfo' + ldd "$purs_bin" | grep 'libtinfo' exit 1 fi diff --git a/ci/build.sh b/ci/build.sh index b2ef51251e..2b0d925a7f 100755 --- a/ci/build.sh +++ b/ci/build.sh @@ -25,7 +25,7 @@ set -ex # We test with --haddock because haddock generation can fail if there is invalid doc-comment syntax, # and these failures are very easy to miss otherwise. -STACK="stack --no-terminal --haddock --jobs=2" +STACK="stack --no-terminal --haddock --no-haddock-deps --jobs=2" STACK_OPTS="--test" if [ "$CI_RELEASE" = "true" -o "$CI_PRERELEASE" = "true" ] diff --git a/glob-test.sh b/glob-test.sh index aba4432f31..23afffd448 100644 --- a/glob-test.sh +++ b/glob-test.sh @@ -13,7 +13,7 @@ set -eu -o pipefail shopt -s nullglob -PURS="$(stack path --local-doc-root)/../bin/purs" +PURS="$(command -v purs)" tmpdir=$(mktemp -d) trap 'rm -rf "$tmpdir"' EXIT diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 7895e541b1..8c9c5e8ec7 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -16,7 +16,7 @@ import Protolude (ordNub, headMay) import Control.Arrow (second, (&&&)) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State (MonadState(..), MonadTrans(..), StateT(..), evalStateT, execStateT, gets, modify) -import Control.Monad (foldM, guard, join, zipWithM, zipWithM_, (<=<)) +import Control.Monad (foldM, guard, join, unless, zipWithM, zipWithM_, (<=<)) import Control.Monad.Writer (MonadWriter(..), WriterT(..)) import Data.Monoid (Any(..)) @@ -293,9 +293,18 @@ entails SolverOptions{..} constraint context hints = let subst = fmap head substs currentSubst <- lift . lift $ gets checkSubstitution subst' <- lift . lift $ withFreshTypes tcd (fmap (substituteType currentSubst) subst) + -- Skip unification when inferredType and t2 are structurally equal: + -- identical types always unify with no new bindings, so the call + -- is a no-op. For wide row types (e.g. a 667-field record in a + -- HasField constraint), unifyTypes dispatches to unifyRows which + -- sorts both sides, allocates intermediate RowListItem lists, and + -- walks the merge-join — all wasted work. eqType walks the type + -- trees in lockstep without allocation and short-circuits on the + -- first mismatch. lift . lift $ zipWithM_ (\t1 t2 -> do let inferredType = replaceAllTypeVars (M.toList subst') t1 - unifyTypes inferredType t2) (tcdInstanceTypes tcd) tys'' + unless (eqType inferredType t2) $ + unifyTypes inferredType t2) (tcdInstanceTypes tcd) tys'' currentSubst' <- lift . lift $ gets checkSubstitution let subst'' = fmap (substituteType currentSubst') subst' -- Solve any necessary subgoals