diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 77b88aca9..3cc22a78b 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -268,6 +268,19 @@ jobs: - name: 🎗️ Lint with stylish-haskell run: ./scripts/format-stylish-haskell.sh && git diff --exit-code + ################################################################################ + # Lint for missing IO specialisations + ################################################################################ + lint-io-specialisations: + name: Lint for missing IO specialisations + runs-on: ubuntu-latest + steps: + - name: 📥 Checkout repository + uses: actions/checkout@v4 + + - name: 🎗️ Lint for missing IO specialisations + run: ./scripts/lint-io-specialisations.sh + ################################################################################ # Lint with generate-readme ################################################################################ diff --git a/scripts/lint-io-specialisations.sh b/scripts/lint-io-specialisations.sh new file mode 100755 index 000000000..74d9d4226 --- /dev/null +++ b/scripts/lint-io-specialisations.sh @@ -0,0 +1,42 @@ +#!/bin/sh + +SCRIPTS_DIR="$(CDPATH= cd -- "$(dirname -- "$0")" && pwd -P)" +absence_allowed_file="${SCRIPTS_DIR}/lint-io-specialisations/absence-allowed" +absence_finder="${SCRIPTS_DIR}/lint-io-specialisations/find-absent.sh" + +IFS=' +' + +export LC_COLLATE=C LC_TYPE=C + +printf 'Linting the main library for missing `IO` specialisations\n' + +if ! [ -f "$absence_allowed_file" ] +then + printf 'There is no regular file `%s`.\n' "$absence_allowed_file" + exit 2 +fi >&2 +if ! sort -C "$absence_allowed_file" +then + printf 'The entries in `%s` are not sorted.\n' "$absence_allowed_file" + exit 2 +fi >&2 + +hs_files=$( + git ls-files \ + --exclude-standard --no-deleted --deduplicate \ + 'src/*.hs' 'src/**/*.hs' +) || exit 3 +absent=$( + "$absence_finder" $hs_files +) || exit 3 +missing=$( + printf '%s\n' "$absent" | sort | comm -23 - "$absence_allowed_file" +) || exit 3 +if [ -n "$missing" ] +then + printf '`IO` specialisations for the following operations are missing:\n' + printf '%s\n' "$missing" | sed -e 's/.*/ * `&`/' + exit 1 +fi +printf 'All required `IO` specialisations are present.\n' diff --git a/scripts/lint-io-specialisations/absence-allowed b/scripts/lint-io-specialisations/absence-allowed new file mode 100644 index 000000000..e69de29bb diff --git a/scripts/lint-io-specialisations/find-absent.sh b/scripts/lint-io-specialisations/find-absent.sh new file mode 100755 index 000000000..0df6b2f82 --- /dev/null +++ b/scripts/lint-io-specialisations/find-absent.sh @@ -0,0 +1,133 @@ +#!/bin/sh + +# Usage notes: +# +# * The arguments to this utility specify the files to check. If no +# arguments are given, standard input is checked. A typical usage of +# this utility is with the `**` glob wildcard, supported in +# particular by the Z Shell and by Bash with the `extglob` option +# set. For example, the following command will check all Haskell +# source files of the main library: +# +# scripts/io-specialisations/find-absent.sh src/**/*.hs +# +# * The results of this utility are not reliable, but should generally +# be correct for “reasonably styled” code. One important restriction +# is that, in order to be considered in need of having an `IO` +# specialisation, an operation must have an application of a type +# variable named `m` as its result type. +# +# Implementation notes: +# +# * The `sed` script that essentially performs all the work uses the +# hold space to hold the name of the current module and the name of +# the operation to which the most recently found `IO` specialisation +# or inlining directive refers. These two names are stored with a +# space between them. The strings before and after the space can +# also be empty: +# +# - The string before the space is empty when the module name is +# not given on the same line as the `module` keyword. This +# causes the module name to not appear in the output but +# otherwise does not have any drawback. +# +# - The string after the space is empty when no `IO` +# specialisation or inlining directive has been found yet in the +# current module or the most recently found such directive is +# considered to not be relevant for the remainder of the module. + +# Find sed: +case "$(uname)" in + Darwin) + sed="$(which gsed)" + if [ "${sed}" = "" ]; then + printf 'This script requires GNU sed, which can be installed with Homebrew:\n\n' >&2 + printf ' brew install gsed\n\n' >&2 + exit 1 + fi + ;; + *) + sed="$(which sed)" + ;; +esac + +sed=$(which gsed) +if [ "${sed}" = "" ]; then + sed=$(which sed) +fi + +specialise='SPECIALI[SZ]E' +pragma_types="($specialise|INLINE)" +hic='[[:alnum:]_#]' # Haskell identifier character + +LC_COLLATE=C LC_CTYPE=C $sed -En -e ' + :start + # Process the first line of a module header + /^module / { + s/module +([^ ]*).*/\1 / + h + } + # Process a `SPECIALISE` or `INLINE` pragma + /^\{-# *'"$pragma_types"'( |$)/ { + # Remove any pragma operation name from the hold space + x + s/ .*// + x + # Add the pragma to the hold space + :prag-add + H + /#-\}/ !{ + n + b prag-add + } + # Get the contents of the hold space + g + # Skip a `SPECIALISE` pragma with a non-`IO` result type + /\{-# *'"$specialise"'( |\n)/ { + s/.*(::|=>|->)( |\n)*// + /^IO / !{ + g + s/\n.*/ / + h + d + } + g + } + # Store the operation name along with the module name + s/\{-# *'"$pragma_types"'( |\n)+// + s/\n('"$hic"'*).*/ \1/ + h + } + # Process a potential type signature + /^[[:lower:]_]/ { + # Add the potential type signature to the hold space + :tsig-add + s/ -- .*// + H + n + /^ / b tsig-add + # Get the persistent data and save the next line + x + # Process a type signature with a context + /^[^ ]* '"$hic"'*\n'"$hic"'+( |\n)*::.+=>/ { + # Place the result type next to the operation name + s/([^ ]* '"$hic"'*\n'"$hic"'+).*(=>|->)( |\n)*/\1 / + # Handle the case of a monadic result type + /^[^ ]* '"$hic"'*\n[^ ]+ m / { + # Handle the case of pragma absence + /^[^ ]* ('"$hic"'*)\n\1 / !{ + s/([^ ]*) '"$hic"'*\n([^ ]+).*/\1.\2/p + s/\.[^.]+$/ / + b tsig-fin + } + } + } + # Clean up and forget about the pragma operation name if any + s/ .*/ / + # Get the saved next line and store the persistent data + :tsig-fin + x + # Continue + b start + } +' "$@" diff --git a/scripts/lint-io-specialisations/find-absent.tests/Animals.Sheep.fake-hs b/scripts/lint-io-specialisations/find-absent.tests/Animals.Sheep.fake-hs new file mode 100644 index 000000000..423ccb707 --- /dev/null +++ b/scripts/lint-io-specialisations/find-absent.tests/Animals.Sheep.fake-hs @@ -0,0 +1,57 @@ +{- + Pronunciation note: + + The identifiers in this module are somehow considered to be German. They + used to contain the German ä and ö, but since the script only treats English + letters as letters eligible to be part of identifiers, ä and ö were replaced + by their standard alternatives ae and oe. This all should give some + indication regarding how to pronounce the identifiers. The author of this + module thought this note to be necessary, not least to justify the choice of + module name. 😉 +-} +module Animals.Sheep where + +{-# SPECIALISE + boerk + :: + Show a => a -> m () + #-} +boerk :: + (Monad m, Show a) -- ^ The general way of constraining + => a -- ^ A value + -> m a -- ^ An effectful computation +{-# SPECIALISE + schnoerk + :: + Show a => m a + #-} +schnoerk + :: (Monad, m, Show a) -- ^ The general way of constraining + => m a -- ^ An effectful computation + +{-# SPECIALISE + bloek + :: + IO a + #-} +bloek :: + IO a + +lamb :: m a -> m a +lamb = id + +{-# INLINE baeh +#-} +baeh :: Monad m => m a -> m a +baeh = id + +{-# INLINE + boo #-} -- maybe too large for inlining +boo :: MonadSheep m => Scissors -> m Wool +boo scissors = withScissors scissors $ \ capability -> cut capability (fur Boo) + +maeh :: a -> (b -> IO (a, b)) +maeh = curry return + +moeh :: Monad m => a -> (b -> m (a, b)) +moeh = curry return diff --git a/scripts/lint-io-specialisations/find-absent.tests/Misc.fake-hs b/scripts/lint-io-specialisations/find-absent.tests/Misc.fake-hs new file mode 100644 index 000000000..f44f75077 --- /dev/null +++ b/scripts/lint-io-specialisations/find-absent.tests/Misc.fake-hs @@ -0,0 +1,26 @@ +module Misc +( + conv, + first +) +where + +yield :: Monad m => a -> m a +yield = return + +{-# SPECIALISE first :: [a] -> IO (WeakPtr a) #-} +-- | Get a weak pointer to the first element of a list. +first :: MonadWeak m => [a] -> m (WeakPtr a) +first = _ + +{-# SPECIALISE last :: [a] -> IO (WeakPtr a) #-} +last :: [a] -> IO (WeakPtr a) +last _ = _ + +{-# SPECIALISE conv :: MonadIO m => [a] -> m a #-} +conv :: (Functor f, Monad m) => f a -> m a +conv = id + +{-# SPECIALISE mis :: MonadIO m => [a] -> IO a #-} +match :: (Functor f, Monad m) => f a -> m a +match = id diff --git a/scripts/lint-io-specialisations/find-absent.tests/output b/scripts/lint-io-specialisations/find-absent.tests/output new file mode 100644 index 000000000..2066e283f --- /dev/null +++ b/scripts/lint-io-specialisations/find-absent.tests/output @@ -0,0 +1,6 @@ +Animals.Sheep.boerk +Animals.Sheep.schnoerk +Animals.Sheep.moeh +Misc.yield +Misc.conv +Misc.match