Skip to content

fourmolize #189

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 11 commits into from
Jul 5, 2025
Merged

fourmolize #189

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
11 commits
Select commit Hold shift + click to select a range
7dfe48f
Extract CPP into separate binding, so it plays well with fourmolu for…
lehins Jul 5, 2025
4500dd0
Adjust definitions, so CPP plays well with fourmolu formatter
lehins Jul 5, 2025
72825c9
Add fourmolu script and config
lehins Jul 5, 2025
71b7242
fourmolize
lehins Jul 5, 2025
b0c9430
Add fourmolu to CI
lehins Jul 5, 2025
ac8b076
Update instructions in legacy tests
lehins Jul 5, 2025
d7e5438
Disable haddock building and doctest on CI for ghc-8.4 and older
lehins Jul 5, 2025
4517e76
Remove redundant constraint
lehins Jul 5, 2025
f484e49
Fix legacy test
lehins Jul 5, 2025
a02eb70
Update tested ghc versions
lehins Jul 5, 2025
e34e106
Minor formatting fixups after running fourmolu
lehins Jul 5, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
61 changes: 41 additions & 20 deletions .github/workflows/ci.yaml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -23,47 +23,41 @@ jobs:
include:
# Linux
# haskell-actions/setup is having trouble installing from hvr/ppa for ghc-8.0 and 8.2
# - { os: ubuntu-latest, ghc: "8.0.2" }
# - { os: ubuntu-latest, ghc: "8.2.2" }
- { os: ubuntu-latest, ghc: "8.4.4" }
- { os: ubuntu-latest, ghc: "8.6.5" }
- { os: ubuntu-latest, ghc: "8.8.4" }
- { os: ubuntu-latest, ghc: "8.10.7" }
- { os: ubuntu-latest, ghc: "9.0.2" }
- { os: ubuntu-latest, ghc: "9.2.8" }
- { os: ubuntu-latest, ghc: "9.4.8" }
- { os: ubuntu-latest, ghc: "9.6.6" }
- { os: ubuntu-latest, ghc: "9.6.7" }
- { os: ubuntu-latest, ghc: "9.8.4" }
- { os: ubuntu-latest, ghc: "9.10.1" }
- { os: ubuntu-latest, ghc: "9.12.1" }
- { os: ubuntu-latest, ghc: "9.10.2" }
- { os: ubuntu-latest, ghc: "9.12.2" }
# MacOS
# - { os: macOS-latest, ghc: "8.0.2" }
# - { os: macOS-latest, ghc: "8.2.2" }
- { os: macOS-latest, ghc: "8.4.4" }
- { os: macOS-latest, ghc: "8.6.5" }
- { os: macOS-latest, ghc: "8.8.4" }
- { os: macOS-latest, ghc: "8.10.7" }
- { os: macOS-latest, ghc: "9.0.2" }
- { os: macOS-latest, ghc: "9.2.8" }
- { os: macOS-latest, ghc: "9.4.8" }
- { os: macOS-latest, ghc: "9.6.6" }
- { os: macOS-latest, ghc: "9.6.7" }
- { os: macOS-latest, ghc: "9.8.4" }
- { os: macOS-latest, ghc: "9.10.1" }
- { os: macOS-latest, ghc: "9.12.1" }
- { os: macOS-latest, ghc: "9.10.2" }
- { os: macOS-latest, ghc: "9.12.2" }
# Windows
# - { os: windows-latest, ghc: "8.0.2" }
# - { os: windows-latest, ghc: "8.2.2" }
- { os: windows-latest, ghc: "8.4.4" }
- { os: windows-latest, ghc: "8.6.5" }
- { os: windows-latest, ghc: "8.8.4" }
- { os: windows-latest, ghc: "8.10.7" }
- { os: windows-latest, ghc: "9.0.2" }
- { os: windows-latest, ghc: "9.2.8" }
- { os: windows-latest, ghc: "9.4.8" }
- { os: windows-latest, ghc: "9.6.6" }
- { os: windows-latest, ghc: "9.6.7" }
- { os: windows-latest, ghc: "9.8.4" }
- { os: windows-latest, ghc: "9.10.1" }
- { os: windows-latest, ghc: "9.12.1" }
- { os: windows-latest, ghc: "9.10.2" }
- { os: windows-latest, ghc: "9.12.2" }
steps:
- uses: actions/checkout@v4

Expand Down Expand Up @@ -94,6 +88,7 @@ jobs:
cabal $EXTRA_FLAGS build all --write-ghc-environment-files=always

- name: Doctest
if: matrix.ghc != '8.4.4'
run: |
cabal install doctest --ignore-project --overwrite-policy=always
./scripts/doctest.sh
Expand Down Expand Up @@ -133,7 +128,7 @@ jobs:
ghc: '9.4.8'
stack-yaml: stack.yaml
- resolver: lts-22
ghc: '9.6.6'
ghc: '9.6.7'
stack-yaml: stack.yaml
- resolver: nightly
stack-yaml: stack.yaml
Expand All @@ -148,7 +143,7 @@ jobs:
stack-yaml: stack.yaml
- resolver: lts-22
os: macos-13
ghc: '9.6.6'
ghc: '9.6.7'
stack-yaml: stack.yaml
# Windows-latest
- resolver: lts-14
Expand All @@ -165,11 +160,12 @@ jobs:
stack-yaml: stack.yaml
- resolver: lts-22
os: windows-latest
ghc: '9.6.6'
ghc: '9.6.7'
stack-yaml: stack.yaml
env:
STACK_YAML: '${{ matrix.stack-yaml }}'
STACK_ARGS: '--resolver ${{ matrix.resolver }}'
HADDOCK: ${{ (matrix.resolver == 'lts-9' || matrix.resolver == 'lts-11' || matrix.resolver == 'lts-12') && '--no-haddock' || '--haddock --no-haddock-deps' }}
cache-version: v5 # bump up this version to invalidate currently stored cache
steps:
- uses: actions/checkout@v4
Expand Down Expand Up @@ -217,9 +213,9 @@ jobs:
set -ex
if [ "${{ matrix.os }}.${{ matrix.resolver }}" == "ubuntu-latest.lts-19" ] && [ -n "${COVERALLS_TOKEN}" ]; then
# Inspection tests aren't compatible with coverage
stack $STACK_ARGS build :spec :legacy-test --coverage --test --no-run-tests --haddock --no-haddock-deps
stack $STACK_ARGS build :spec :legacy-test --coverage --test --no-run-tests $HADDOCK
else
stack $STACK_ARGS build --test --no-run-tests --bench --no-run-benchmarks --haddock --no-haddock-deps
stack $STACK_ARGS build --test --no-run-tests --bench --no-run-benchmarks $HADDOCK
fi

- name: Test
Expand Down Expand Up @@ -309,3 +305,28 @@ jobs:
./legacy
ghc --make -isrc:test -o spec test/Spec.hs
./spec
fourmolu:
runs-on: ubuntu-latest

defaults:
run:
shell: bash

strategy:
fail-fast: false

steps:
- uses: actions/checkout@v4

- name: Install fourmolu
run: |
FOURMOLU_VERSION="0.18.0.0"
BINDIR=$HOME/.local/bin
mkdir -p "$BINDIR"
curl -sSfL "https://github.com/fourmolu/fourmolu/releases/download/v${FOURMOLU_VERSION}/fourmolu-${FOURMOLU_VERSION}-linux-x86_64" -o "$BINDIR/fourmolu"
chmod a+x "$BINDIR/fourmolu"
echo "$BINDIR" >> $GITHUB_PATH

- name: Run fourmolu
run: ./scripts/fourmolize.sh

1 change: 1 addition & 0 deletions .gitignore
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -2,3 +2,4 @@
/stack.yaml.lock
/.stack-work/
/cabal.project.local
/test-legacy/test
98 changes: 48 additions & 50 deletions bench-legacy/BinSearch.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,4 +1,3 @@

{-
Binary search over benchmark input sizes.

Expand All @@ -16,19 +15,15 @@
An alternative approach is to kill the computation after a certain
amount of time and observe how much work it has completed.
-}
module BinSearch
(
binSearch
)
where
module BinSearch (
binSearch,
) where

import Control.Monad
import Data.Time.Clock -- Not in 6.10
import Data.List
import Data.Time.Clock
import System.IO
import Prelude hiding (min,max,log)


import Prelude hiding (log, max, min)

-- | Binary search for the number of inputs to a computation that
-- results in a specified amount of execution time in seconds. For example:
Expand All @@ -38,28 +33,28 @@ import Prelude hiding (min,max,log)
-- ... will find the right input size that results in a time
-- between min and max, then it will then run for N trials and
-- return the median (input,time-in-seconds) pair.
binSearch :: Bool -> Integer -> (Double,Double) -> (Integer -> IO ()) -> IO (Integer, Double)
binSearch :: Bool -> Integer -> (Double, Double) -> (Integer -> IO ()) -> IO (Integer, Double)
binSearch verbose trials (min, max) kernel = do
when verbose $
putStrLn $
"[binsearch] Binary search for input size resulting in time in range " ++
show (min, max)
"[binsearch] Binary search for input size resulting in time in range "
++ show (min, max)
let desired_exec_length = 1.0
good_trial t =
(toRational t <= toRational max) && (toRational t >= toRational min)
-- At some point we must give up...
-- At some point we must give up...
loop n
| n > ((2 :: Integer) ^ (100 :: Integer)) =
error
"ERROR binSearch: This function doesn't seem to scale in proportion to its last argument."
-- Not allowed to have "0" size input, bump it back to one:
error
"ERROR binSearch: This function doesn't seem to scale in proportion to its last argument."
-- Not allowed to have "0" size input, bump it back to one:
loop 0 = loop 1
loop n = do
when verbose $ putStr $ "[binsearch:" ++ show n ++ "] "
time <- timeit $ kernel n
when verbose $ putStrLn $ "Time consumed: " ++ show time
let rate = fromIntegral n / time
-- [2010.06.09] Introducing a small fudge factor to help our guess get over the line:
-- [2010.06.09] Introducing a small fudge factor to help our guess get over the line:
let initial_fudge_factor = 1.10
fudge_factor = 1.01 -- Even in the steady state we fudge a little
guess = desired_exec_length * rate
Expand All @@ -73,62 +68,64 @@ binSearch verbose trials (min, max) kernel = do
"[binsearch] Time in range. LOCKING input size and performing remaining trials."
print_trial 1 n time
lockin (trials - 1) n [time]
else if time < 0.100
then loop (2 * n)
else do
when verbose $
putStrLn $
"[binsearch] Estimated rate to be " ++
show (round rate :: Integer) ++
" per second. Trying to scale up..."
-- Here we've exited the doubling phase, but we're making our
-- first guess as to how big a real execution should be:
if time > 0.100 && time < 0.33 * desired_exec_length
then do
when verbose $
putStrLn
"[binsearch] (Fudging first guess a little bit extra)"
loop (round $ guess * initial_fudge_factor)
else loop (round $ guess * fudge_factor)
-- Termination condition: Done with all trials.
else
if time < 0.100
then loop (2 * n)
else do
when verbose $
putStrLn $
"[binsearch] Estimated rate to be "
++ show (round rate :: Integer)
++ " per second. Trying to scale up..."
-- Here we've exited the doubling phase, but we're making our
-- first guess as to how big a real execution should be:
if time > 0.100 && time < 0.33 * desired_exec_length
then do
when verbose $
putStrLn
"[binsearch] (Fudging first guess a little bit extra)"
loop (round $ guess * initial_fudge_factor)
else loop (round $ guess * fudge_factor)
-- Termination condition: Done with all trials.
lockin 0 n log = do
when verbose $
putStrLn $
"[binsearch] Time-per-unit for all trials: " ++
concat
(intersperse " " (map (show . (/ toDouble n) . toDouble) $ sort log))
"[binsearch] Time-per-unit for all trials: "
++ concat
(intersperse " " (map (show . (/ toDouble n) . toDouble) $ sort log))
return (n, log !! (length log `quot` 2)) -- Take the median
lockin trials_left n log = do
when verbose $
putStrLn
"[binsearch]------------------------------------------------------------"
time <- timeit $ kernel n
-- hFlush stdout
-- hFlush stdout
print_trial (trials - trials_left + 1) n time
-- whenverbose$ hFlush stdout
-- whenverbose$ hFlush stdout
lockin (trials_left - 1) n (time : log)
print_trial :: Integer -> Integer -> NominalDiffTime -> IO ()
print_trial trialnum n time =
let rate = fromIntegral n / time
timeperunit = time / fromIntegral n
in when verbose $
putStrLn $
"[binsearch] TRIAL: " ++
show trialnum ++
" secPerUnit: " ++
showTime timeperunit ++
" ratePerSec: " ++ show rate ++ " seconds: " ++ showTime time
putStrLn $
"[binsearch] TRIAL: "
++ show trialnum
++ " secPerUnit: "
++ showTime timeperunit
++ " ratePerSec: "
++ show rate
++ " seconds: "
++ showTime time
(n, t) <- loop 1
return (n, fromRational $ toRational t)


showTime :: NominalDiffTime -> String
showTime :: NominalDiffTime -> String
showTime t = show ((fromRational $ toRational t) :: Double)

toDouble :: Real a => a -> Double
toDouble = fromRational . toRational


-- Could use cycle counters here.... but the point of this is to time
-- things on the order of a second.
timeit :: IO () -> IO NominalDiffTime
Expand All @@ -137,6 +134,7 @@ timeit io = do
io
end <- getCurrentTime
return (diffUTCTime end strt)

{-
test :: IO (Integer,Double)
test =
Expand Down
Loading