Skip to content

Commit a3efabc

Browse files
jeltschjeltsch
authored
Merge pull request #683 from IntersectMBO/jeltsch/find-missing-io-specialisations
Add script for finding missing `IO` specializations
2 parents 3b9f18f + a5f12f9 commit a3efabc

File tree

8 files changed

+289
-0
lines changed

8 files changed

+289
-0
lines changed

‎.github/workflows/ci.yml‎

Lines changed: 13 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -268,6 +268,19 @@ jobs:
268268
- name: 🎗️ Lint with stylish-haskell
269269
run: ./scripts/format-stylish-haskell.sh && git diff --exit-code
270270

271+
################################################################################
272+
# Lint for missing IO specialisations
273+
################################################################################
274+
lint-io-specialisations:
275+
name: Lint for missing IO specialisations
276+
runs-on: ubuntu-latest
277+
steps:
278+
- name: 📥 Checkout repository
279+
uses: actions/checkout@v4
280+
281+
- name: 🎗️ Lint for missing IO specialisations
282+
run: ./scripts/lint-io-specialisations.sh
283+
271284
################################################################################
272285
# Lint with generate-readme
273286
################################################################################

‎scripts/lint-io-specialisations.sh‎

Lines changed: 44 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,44 @@
1+
#! /usr/bin/env sh
2+
3+
absence_allowed_file=scripts/lint-io-specialisations/absence-allowed
4+
absence_finder=scripts/lint-io-specialisations/find-absent.sh
5+
6+
set -e
7+
8+
IFS='
9+
'
10+
11+
export LC_COLLATE=C LC_TYPE=C
12+
13+
printf 'Linting the main library for missing `IO` specialisations\n'
14+
15+
if ! [ -f "$absence_allowed_file" ]
16+
then
17+
printf 'There is no regular file `%s`.\n' "$absence_allowed_file"
18+
exit 2
19+
fi >&2
20+
if ! sort -C "$absence_allowed_file"
21+
then
22+
printf 'The entries in `%s` are not sorted.\n' "$absence_allowed_file"
23+
exit 2
24+
fi >&2
25+
26+
hs_files=$(
27+
git ls-files \
28+
--exclude-standard --no-deleted --deduplicate \
29+
'src/*.hs' 'src/**/*.hs'
30+
)
31+
absent=$(
32+
"$absence_finder" $hs_files
33+
)
34+
missing=$(
35+
printf '%s\n' "$absent" | sort | comm -23 - "$absence_allowed_file"
36+
)
37+
if [ -n "$missing" ]
38+
then
39+
printf '`IO` specialisations for the following operations are '
40+
printf 'missing:\n'
41+
printf '%s\n' "$missing" | sed -e 's/.*/ * `&`/'
42+
exit 1
43+
fi
44+
printf 'All required `IO` specialisations are present.\n'

‎scripts/lint-io-specialisations/absence-allowed‎

Whitespace-only changes.

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

Lines changed: 138 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,138 @@
1+
#! /usr/bin/env sh
2+
3+
# Usage notes:
4+
#
5+
# * The arguments to this utility specify the files to check. If no
6+
# arguments are given, standard input is checked. A typical usage of
7+
# this utility is with the `**` glob wildcard, supported in
8+
# particular by the Z Shell and by Bash with the `extglob` option
9+
# set. For example, the following command will check all Haskell
10+
# source files of the main library:
11+
#
12+
# scripts/io-specialisations/find-absent.sh src/**/*.hs
13+
#
14+
# * The results of this utility are not reliable, but should generally
15+
# be correct for “reasonably styled” code. One important restriction
16+
# is that, in order to be considered in need of having an `IO`
17+
# specialisation, an operation must have an application of a type
18+
# variable named `m` as its result type.
19+
#
20+
# * This utility requires GNU sed. If there is a command `gsed`
21+
# available, then this utility will consider it to be GNU sed and
22+
# use it. If there is no command `gsed` available but the operating
23+
# system is Linux, then this utility will assume that `sed` is GNU
24+
# sed and use it. In all other cases, this utility will fail.
25+
#
26+
# Implementation notes:
27+
#
28+
# * The `sed` script that essentially performs all the work uses the
29+
# hold space to hold the name of the current module and the name of
30+
# the operation to which the most recently found `IO` specialisation
31+
# or inlining directive refers. These two names are stored with a
32+
# space between them. The strings before and after the space can
33+
# also be empty:
34+
#
35+
# - The string before the space is empty when the module name is
36+
# not given on the same line as the `module` keyword. This
37+
# causes the module name to not appear in the output but
38+
# otherwise does not have any drawback.
39+
#
40+
# - The string after the space is empty when no `IO`
41+
# specialisation or inlining directive has been found yet in the
42+
# current module or the most recently found such directive is
43+
# considered to not be relevant for the remainder of the module.
44+
#
45+
# * This utility requires GNU sed because it uses a backreference in
46+
# an extended regular expression, something that the POSIX standard
47+
# does not guarantee to work.
48+
49+
set -e
50+
51+
export LC_COLLATE=C LC_CTYPE=C
52+
53+
if command -v gsed >/dev/null
54+
then
55+
gnu_sed=gsed
56+
elif [ $(uname) = Linux ]
57+
then
58+
gnu_sed=sed
59+
else
60+
printf 'GNU sed not found\n' >&2
61+
exit 1
62+
fi
63+
64+
specialise='SPECIALI[SZ]E'
65+
pragma_types="($specialise|INLINE)"
66+
hic='[[:alnum:]_#]' # Haskell identifier character
67+
68+
$gnu_sed -En -e '
69+
:start
70+
# Process the first line of a module header
71+
/^module / {
72+
s/module +([^ ]*).*/\1 /
73+
h
74+
}
75+
# Process a `SPECIALISE` or `INLINE` pragma
76+
/^\{-# *'"$pragma_types"'( |$)/ {
77+
# Remove any pragma operation name from the hold space
78+
x
79+
s/ .*//
80+
x
81+
# Add the pragma to the hold space
82+
:prag-add
83+
H
84+
/#-\}/ !{
85+
n
86+
b prag-add
87+
}
88+
# Get the contents of the hold space
89+
g
90+
# Skip a `SPECIALISE` pragma with a non-`IO` result type
91+
/\{-# *'"$specialise"'( |\n)/ {
92+
s/.*(::|=>|->)( |\n)*//
93+
/^IO / !{
94+
g
95+
s/\n.*/ /
96+
h
97+
d
98+
}
99+
g
100+
}
101+
# Store the operation name along with the module name
102+
s/\{-# *'"$pragma_types"'( |\n)+//
103+
s/\n('"$hic"'*).*/ \1/
104+
h
105+
}
106+
# Process a potential type signature
107+
/^[[:lower:]_]/ {
108+
# Add the potential type signature to the hold space
109+
:tsig-add
110+
s/ -- .*//
111+
H
112+
n
113+
/^ / b tsig-add
114+
# Get the persistent data and save the next line
115+
x
116+
# Process a type signature with a context
117+
/^[^ ]* '"$hic"'*\n'"$hic"'+( |\n)*::.+=>/ {
118+
# Place the result type next to the operation name
119+
s/([^ ]* '"$hic"'*\n'"$hic"'+).*(=>|->)( |\n)*/\1 /
120+
# Handle the case of a monadic result type
121+
/^[^ ]* '"$hic"'*\n[^ ]+ m / {
122+
# Handle the case of pragma absence
123+
/^[^ ]* ('"$hic"'*)\n\1 / !{
124+
s/([^ ]*) '"$hic"'*\n([^ ]+).*/\1.\2/p
125+
s/\.[^.]+$/ /
126+
b tsig-fin
127+
}
128+
}
129+
}
130+
# Clean up and forget about the pragma operation name if any
131+
s/ .*/ /
132+
# Get the saved next line and store the persistent data
133+
:tsig-fin
134+
x
135+
# Continue
136+
b start
137+
}
138+
' "$@"

‎scripts/lint-io-specialisations/find-absent.tests/Animals.Sheep.fake-hs‎

Lines changed: 57 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,57 @@
1+
{-
2+
Pronunciation note:
3+
4+
The identifiers in this module are somehow considered to be German. They
5+
used to contain the German ä and ö, but since the script only treats English
6+
letters as letters eligible to be part of identifiers, ä and ö were replaced
7+
by their standard alternatives ae and oe. This all should give some
8+
indication regarding how to pronounce the identifiers. The author of this
9+
module thought this note to be necessary, not least to justify the choice of
10+
module name. 😉
11+
-}
12+
module Animals.Sheep where
13+
14+
{-# SPECIALISE
15+
boerk
16+
::
17+
Show a => a -> m ()
18+
#-}
19+
boerk ::
20+
(Monad m, Show a) -- ^ The general way of constraining
21+
=> a -- ^ A value
22+
-> m a -- ^ An effectful computation
23+
{-# SPECIALISE
24+
schnoerk
25+
::
26+
Show a => m a
27+
#-}
28+
schnoerk
29+
:: (Monad, m, Show a) -- ^ The general way of constraining
30+
=> m a -- ^ An effectful computation
31+
32+
{-# SPECIALISE
33+
bloek
34+
::
35+
IO a
36+
#-}
37+
bloek ::
38+
IO a
39+
40+
lamb :: m a -> m a
41+
lamb = id
42+
43+
{-# INLINE baeh
44+
#-}
45+
baeh :: Monad m => m a -> m a
46+
baeh = id
47+
48+
{-# INLINE
49+
boo #-} -- maybe too large for inlining
50+
boo :: MonadSheep m => Scissors -> m Wool
51+
boo scissors = withScissors scissors $ \ capability -> cut capability (fur Boo)
52+
53+
maeh :: a -> (b -> IO (a, b))
54+
maeh = curry return
55+
56+
moeh :: Monad m => a -> (b -> m (a, b))
57+
moeh = curry return

‎scripts/lint-io-specialisations/find-absent.tests/Misc.fake-hs‎

Lines changed: 26 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,26 @@
1+
module Misc
2+
(
3+
conv,
4+
first
5+
)
6+
where
7+
8+
yield :: Monad m => a -> m a
9+
yield = return
10+
11+
{-# SPECIALISE first :: [a] -> IO (WeakPtr a) #-}
12+
-- | Get a weak pointer to the first element of a list.
13+
first :: MonadWeak m => [a] -> m (WeakPtr a)
14+
first = _
15+
16+
{-# SPECIALISE last :: [a] -> IO (WeakPtr a) #-}
17+
last :: [a] -> IO (WeakPtr a)
18+
last _ = _
19+
20+
{-# SPECIALISE conv :: MonadIO m => [a] -> m a #-}
21+
conv :: (Functor f, Monad m) => f a -> m a
22+
conv = id
23+
24+
{-# SPECIALISE mis :: MonadIO m => [a] -> IO a #-}
25+
match :: (Functor f, Monad m) => f a -> m a
26+
match = id

‎scripts/lint-io-specialisations/find-absent.tests/output‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,6 @@
1+
Animals.Sheep.boerk
2+
Animals.Sheep.schnoerk
3+
Animals.Sheep.moeh
4+
Misc.yield
5+
Misc.conv
6+
Misc.match

‎src/Database/LSMTree/Internal/BloomFilter.hs‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -296,6 +296,11 @@ bloomFilterFromFile hfs h = do
296296
ErrFileFormatInvalid
297297
(fsErrorPath e) FormatBloomFilterFile msg)
298298

299+
{-# SPECIALISE hGetByteArrayExactly ::
300+
HasFS IO h
301+
-> Handle h
302+
-> Int
303+
-> IO P.ByteArray #-}
299304
hGetByteArrayExactly ::
300305
(PrimMonad m, MonadThrow m)
301306
=> HasFS m h

0 commit comments

Comments
 (0)