Skip to content

Commit ca8a869

Browse files
lehinslehins
authored
Merge pull request #189 from haskell/lehins/fourmolize
fourmolize
2 parents 1592c83 + e34e106 commit ca8a869

26 files changed

Lines changed: 1960 additions & 1538 deletions

‎.github/workflows/ci.yaml‎

Lines changed: 41 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -23,47 +23,41 @@ jobs:
2323
include:
2424
# Linux
2525
# haskell-actions/setup is having trouble installing from hvr/ppa for ghc-8.0 and 8.2
26-
# - { os: ubuntu-latest, ghc: "8.0.2" }
27-
# - { os: ubuntu-latest, ghc: "8.2.2" }
2826
- { os: ubuntu-latest, ghc: "8.4.4" }
2927
- { os: ubuntu-latest, ghc: "8.6.5" }
3028
- { os: ubuntu-latest, ghc: "8.8.4" }
3129
- { os: ubuntu-latest, ghc: "8.10.7" }
3230
- { os: ubuntu-latest, ghc: "9.0.2" }
3331
- { os: ubuntu-latest, ghc: "9.2.8" }
3432
- { os: ubuntu-latest, ghc: "9.4.8" }
35-
- { os: ubuntu-latest, ghc: "9.6.6" }
33+
- { os: ubuntu-latest, ghc: "9.6.7" }
3634
- { os: ubuntu-latest, ghc: "9.8.4" }
37-
- { os: ubuntu-latest, ghc: "9.10.1" }
38-
- { os: ubuntu-latest, ghc: "9.12.1" }
35+
- { os: ubuntu-latest, ghc: "9.10.2" }
36+
- { os: ubuntu-latest, ghc: "9.12.2" }
3937
# MacOS
40-
# - { os: macOS-latest, ghc: "8.0.2" }
41-
# - { os: macOS-latest, ghc: "8.2.2" }
4238
- { os: macOS-latest, ghc: "8.4.4" }
4339
- { os: macOS-latest, ghc: "8.6.5" }
4440
- { os: macOS-latest, ghc: "8.8.4" }
4541
- { os: macOS-latest, ghc: "8.10.7" }
4642
- { os: macOS-latest, ghc: "9.0.2" }
4743
- { os: macOS-latest, ghc: "9.2.8" }
4844
- { os: macOS-latest, ghc: "9.4.8" }
49-
- { os: macOS-latest, ghc: "9.6.6" }
45+
- { os: macOS-latest, ghc: "9.6.7" }
5046
- { os: macOS-latest, ghc: "9.8.4" }
51-
- { os: macOS-latest, ghc: "9.10.1" }
52-
- { os: macOS-latest, ghc: "9.12.1" }
47+
- { os: macOS-latest, ghc: "9.10.2" }
48+
- { os: macOS-latest, ghc: "9.12.2" }
5349
# Windows
54-
# - { os: windows-latest, ghc: "8.0.2" }
55-
# - { os: windows-latest, ghc: "8.2.2" }
5650
- { os: windows-latest, ghc: "8.4.4" }
5751
- { os: windows-latest, ghc: "8.6.5" }
5852
- { os: windows-latest, ghc: "8.8.4" }
5953
- { os: windows-latest, ghc: "8.10.7" }
6054
- { os: windows-latest, ghc: "9.0.2" }
6155
- { os: windows-latest, ghc: "9.2.8" }
6256
- { os: windows-latest, ghc: "9.4.8" }
63-
- { os: windows-latest, ghc: "9.6.6" }
57+
- { os: windows-latest, ghc: "9.6.7" }
6458
- { os: windows-latest, ghc: "9.8.4" }
65-
- { os: windows-latest, ghc: "9.10.1" }
66-
- { os: windows-latest, ghc: "9.12.1" }
59+
- { os: windows-latest, ghc: "9.10.2" }
60+
- { os: windows-latest, ghc: "9.12.2" }
6761
steps:
6862
- uses: actions/checkout@v4
6963

@@ -94,6 +88,7 @@ jobs:
9488
cabal $EXTRA_FLAGS build all --write-ghc-environment-files=always
9589
9690
- name: Doctest
91+
if: matrix.ghc != '8.4.4'
9792
run: |
9893
cabal install doctest --ignore-project --overwrite-policy=always
9994
./scripts/doctest.sh
@@ -133,7 +128,7 @@ jobs:
133128
ghc: '9.4.8'
134129
stack-yaml: stack.yaml
135130
- resolver: lts-22
136-
ghc: '9.6.6'
131+
ghc: '9.6.7'
137132
stack-yaml: stack.yaml
138133
- resolver: nightly
139134
stack-yaml: stack.yaml
@@ -148,7 +143,7 @@ jobs:
148143
stack-yaml: stack.yaml
149144
- resolver: lts-22
150145
os: macos-13
151-
ghc: '9.6.6'
146+
ghc: '9.6.7'
152147
stack-yaml: stack.yaml
153148
# Windows-latest
154149
- resolver: lts-14
@@ -165,11 +160,12 @@ jobs:
165160
stack-yaml: stack.yaml
166161
- resolver: lts-22
167162
os: windows-latest
168-
ghc: '9.6.6'
163+
ghc: '9.6.7'
169164
stack-yaml: stack.yaml
170165
env:
171166
STACK_YAML: '${{ matrix.stack-yaml }}'
172167
STACK_ARGS: '--resolver ${{ matrix.resolver }}'
168+
HADDOCK: ${{ (matrix.resolver == 'lts-9' || matrix.resolver == 'lts-11' || matrix.resolver == 'lts-12') && '--no-haddock' || '--haddock --no-haddock-deps' }}
173169
cache-version: v5 # bump up this version to invalidate currently stored cache
174170
steps:
175171
- uses: actions/checkout@v4
@@ -217,9 +213,9 @@ jobs:
217213
set -ex
218214
if [ "${{ matrix.os }}.${{ matrix.resolver }}" == "ubuntu-latest.lts-19" ] && [ -n "${COVERALLS_TOKEN}" ]; then
219215
# Inspection tests aren't compatible with coverage
220-
stack $STACK_ARGS build :spec :legacy-test --coverage --test --no-run-tests --haddock --no-haddock-deps
216+
stack $STACK_ARGS build :spec :legacy-test --coverage --test --no-run-tests $HADDOCK
221217
else
222-
stack $STACK_ARGS build --test --no-run-tests --bench --no-run-benchmarks --haddock --no-haddock-deps
218+
stack $STACK_ARGS build --test --no-run-tests --bench --no-run-benchmarks $HADDOCK
223219
fi
224220
225221
- name: Test
@@ -309,3 +305,28 @@ jobs:
309305
./legacy
310306
ghc --make -isrc:test -o spec test/Spec.hs
311307
./spec
308+
fourmolu:
309+
runs-on: ubuntu-latest
310+
311+
defaults:
312+
run:
313+
shell: bash
314+
315+
strategy:
316+
fail-fast: false
317+
318+
steps:
319+
- uses: actions/checkout@v4
320+
321+
- name: Install fourmolu
322+
run: |
323+
FOURMOLU_VERSION="0.18.0.0"
324+
BINDIR=$HOME/.local/bin
325+
mkdir -p "$BINDIR"
326+
curl -sSfL "https://github.com/fourmolu/fourmolu/releases/download/v${FOURMOLU_VERSION}/fourmolu-${FOURMOLU_VERSION}-linux-x86_64" -o "$BINDIR/fourmolu"
327+
chmod a+x "$BINDIR/fourmolu"
328+
echo "$BINDIR" >> $GITHUB_PATH
329+
330+
- name: Run fourmolu
331+
run: ./scripts/fourmolize.sh
332+

‎.gitignore‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2,3 +2,4 @@
22
/stack.yaml.lock
33
/.stack-work/
44
/cabal.project.local
5+
/test-legacy/test

‎bench-legacy/BinSearch.hs‎

Lines changed: 48 additions & 50 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,3 @@
1-
21
{-
32
Binary search over benchmark input sizes.
43
@@ -16,19 +15,15 @@
1615
An alternative approach is to kill the computation after a certain
1716
amount of time and observe how much work it has completed.
1817
-}
19-
module BinSearch
20-
(
21-
binSearch
22-
)
23-
where
18+
module BinSearch (
19+
binSearch,
20+
) where
2421

2522
import Control.Monad
26-
import Data.Time.Clock -- Not in 6.10
2723
import Data.List
24+
import Data.Time.Clock
2825
import System.IO
29-
import Prelude hiding (min,max,log)
30-
31-
26+
import Prelude hiding (log, max, min)
3227

3328
-- | Binary search for the number of inputs to a computation that
3429
-- results in a specified amount of execution time in seconds. For example:
@@ -38,28 +33,28 @@ import Prelude hiding (min,max,log)
3833
-- ... will find the right input size that results in a time
3934
-- between min and max, then it will then run for N trials and
4035
-- return the median (input,time-in-seconds) pair.
41-
binSearch :: Bool -> Integer -> (Double,Double) -> (Integer -> IO ()) -> IO (Integer, Double)
36+
binSearch :: Bool -> Integer -> (Double, Double) -> (Integer -> IO ()) -> IO (Integer, Double)
4237
binSearch verbose trials (min, max) kernel = do
4338
when verbose $
4439
putStrLn $
45-
"[binsearch] Binary search for input size resulting in time in range " ++
46-
show (min, max)
40+
"[binsearch] Binary search for input size resulting in time in range "
41+
++ show (min, max)
4742
let desired_exec_length = 1.0
4843
good_trial t =
4944
(toRational t <= toRational max) && (toRational t >= toRational min)
50-
-- At some point we must give up...
45+
-- At some point we must give up...
5146
loop n
5247
| n > ((2 :: Integer) ^ (100 :: Integer)) =
53-
error
54-
"ERROR binSearch: This function doesn't seem to scale in proportion to its last argument."
55-
-- Not allowed to have "0" size input, bump it back to one:
48+
error
49+
"ERROR binSearch: This function doesn't seem to scale in proportion to its last argument."
50+
-- Not allowed to have "0" size input, bump it back to one:
5651
loop 0 = loop 1
5752
loop n = do
5853
when verbose $ putStr $ "[binsearch:" ++ show n ++ "] "
5954
time <- timeit $ kernel n
6055
when verbose $ putStrLn $ "Time consumed: " ++ show time
6156
let rate = fromIntegral n / time
62-
-- [2010.06.09] Introducing a small fudge factor to help our guess get over the line:
57+
-- [2010.06.09] Introducing a small fudge factor to help our guess get over the line:
6358
let initial_fudge_factor = 1.10
6459
fudge_factor = 1.01 -- Even in the steady state we fudge a little
6560
guess = desired_exec_length * rate
@@ -73,62 +68,64 @@ binSearch verbose trials (min, max) kernel = do
7368
"[binsearch] Time in range. LOCKING input size and performing remaining trials."
7469
print_trial 1 n time
7570
lockin (trials - 1) n [time]
76-
else if time < 0.100
77-
then loop (2 * n)
78-
else do
79-
when verbose $
80-
putStrLn $
81-
"[binsearch] Estimated rate to be " ++
82-
show (round rate :: Integer) ++
83-
" per second. Trying to scale up..."
84-
-- Here we've exited the doubling phase, but we're making our
85-
-- first guess as to how big a real execution should be:
86-
if time > 0.100 && time < 0.33 * desired_exec_length
87-
then do
88-
when verbose $
89-
putStrLn
90-
"[binsearch] (Fudging first guess a little bit extra)"
91-
loop (round $ guess * initial_fudge_factor)
92-
else loop (round $ guess * fudge_factor)
93-
-- Termination condition: Done with all trials.
71+
else
72+
if time < 0.100
73+
then loop (2 * n)
74+
else do
75+
when verbose $
76+
putStrLn $
77+
"[binsearch] Estimated rate to be "
78+
++ show (round rate :: Integer)
79+
++ " per second. Trying to scale up..."
80+
-- Here we've exited the doubling phase, but we're making our
81+
-- first guess as to how big a real execution should be:
82+
if time > 0.100 && time < 0.33 * desired_exec_length
83+
then do
84+
when verbose $
85+
putStrLn
86+
"[binsearch] (Fudging first guess a little bit extra)"
87+
loop (round $ guess * initial_fudge_factor)
88+
else loop (round $ guess * fudge_factor)
89+
-- Termination condition: Done with all trials.
9490
lockin 0 n log = do
9591
when verbose $
9692
putStrLn $
97-
"[binsearch] Time-per-unit for all trials: " ++
98-
concat
99-
(intersperse " " (map (show . (/ toDouble n) . toDouble) $ sort log))
93+
"[binsearch] Time-per-unit for all trials: "
94+
++ concat
95+
(intersperse " " (map (show . (/ toDouble n) . toDouble) $ sort log))
10096
return (n, log !! (length log `quot` 2)) -- Take the median
10197
lockin trials_left n log = do
10298
when verbose $
10399
putStrLn
104100
"[binsearch]------------------------------------------------------------"
105101
time <- timeit $ kernel n
106-
-- hFlush stdout
102+
-- hFlush stdout
107103
print_trial (trials - trials_left + 1) n time
108-
-- whenverbose$ hFlush stdout
104+
-- whenverbose$ hFlush stdout
109105
lockin (trials_left - 1) n (time : log)
110106
print_trial :: Integer -> Integer -> NominalDiffTime -> IO ()
111107
print_trial trialnum n time =
112108
let rate = fromIntegral n / time
113109
timeperunit = time / fromIntegral n
114110
in when verbose $
115-
putStrLn $
116-
"[binsearch] TRIAL: " ++
117-
show trialnum ++
118-
" secPerUnit: " ++
119-
showTime timeperunit ++
120-
" ratePerSec: " ++ show rate ++ " seconds: " ++ showTime time
111+
putStrLn $
112+
"[binsearch] TRIAL: "
113+
++ show trialnum
114+
++ " secPerUnit: "
115+
++ showTime timeperunit
116+
++ " ratePerSec: "
117+
++ show rate
118+
++ " seconds: "
119+
++ showTime time
121120
(n, t) <- loop 1
122121
return (n, fromRational $ toRational t)
123122

124-
125-
showTime :: NominalDiffTime -> String
123+
showTime :: NominalDiffTime -> String
126124
showTime t = show ((fromRational $ toRational t) :: Double)
127125

128126
toDouble :: Real a => a -> Double
129127
toDouble = fromRational . toRational
130128

131-
132129
-- Could use cycle counters here.... but the point of this is to time
133130
-- things on the order of a second.
134131
timeit :: IO () -> IO NominalDiffTime
@@ -137,6 +134,7 @@ timeit io = do
137134
io
138135
end <- getCurrentTime
139136
return (diffUTCTime end strt)
137+
140138
{-
141139
test :: IO (Integer,Double)
142140
test =

0 commit comments

Comments
 (0)