Find 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,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'

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
+    }
+' "$@"

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