Add script for finding missing IO specializations

.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
   ################################################################################

scripts/lint-io-specialisations.sh

@@ -0,0 +1,44 @@
+#! /usr/bin/env sh
+
+absence_allowed_file=scripts/lint-io-specialisations/absence-allowed
+absence_finder=scripts/lint-io-specialisations/find-absent.sh
+
+set -e
+
+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'
+)
+absent=$(
+    "$absence_finder" $hs_files
+)
+missing=$(
+    printf '%s\n' "$absent" | sort | comm -23 - "$absence_allowed_file"
+)
+if [ -n "$missing" ]
+then
+    printf '`IO` specialisations for the following operations are '
+    printf 'missing:\n'
+    printf '%s\n' "$missing" | sed -e 's/.*/  * `&`/'
+    exit 1
+fi
+printf 'All required `IO` specialisations are present.\n'

scripts/lint-io-specialisations/find-absent.sh

@@ -0,0 +1,138 @@
+#! /usr/bin/env 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.
+#
+#   * This utility requires GNU sed. If there is a command `gsed`
+#     available, then this utility will consider it to be GNU sed and
+#     use it. If there is no command `gsed` available but the operating
+#     system is Linux, then this utility will assume that `sed` is GNU
+#     sed and use it. In all other cases, this utility will fail.
+#
+# 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.
+#
+#   * This utility requires GNU sed because it uses a backreference in
+#     an extended regular expression, something that the POSIX standard
+#     does not guarantee to work.
+
+set -e
+
+export LC_COLLATE=C LC_CTYPE=C
+
+if command -v gsed >/dev/null
+then
+    gnu_sed=gsed
+elif [ $(uname) = Linux ]
+then
+    gnu_sed=sed
+else
+    printf 'GNU sed not found\n' >&2
+    exit 1
+fi
+
+specialise='SPECIALI[SZ]E'
+pragma_types="($specialise|INLINE)"
+hic='[[:alnum:]_#]' # Haskell identifier character
+
+$gnu_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
+    }
+' "$@"

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

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

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

src/Database/LSMTree/Internal/BloomFilter.hs

@@ -296,6 +296,11 @@ bloomFilterFromFile hfs h = do
                  ErrFileFormatInvalid
                    (fsErrorPath e) FormatBloomFilterFile msg)
 
+{-# SPECIALISE hGetByteArrayExactly ::
+     HasFS IO h
+  -> Handle h
+  -> Int
+  -> IO P.ByteArray #-}
 hGetByteArrayExactly ::
      (PrimMonad m, MonadThrow m)
   => HasFS m h