Skip to content
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.

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

Revert "Use a code generator for singletons-base's test suite" #624

Closed
wants to merge 1 commit into from
Closed
Show file tree
Hide file tree
Changes from all commits
Commits
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
10 changes: 1 addition & 9 deletions .github/workflows/haskell-ci.yml
Original file line number Diff line number Diff line change
Expand Up @@ -192,7 +192,6 @@ jobs:
echo "packages: $GITHUB_WORKSPACE/source/./singletons" >> cabal.project
if [ $((HCNUMVER >= 91200)) -ne 0 ] ; then echo "packages: $GITHUB_WORKSPACE/source/./singletons-th" >> cabal.project ; fi
if [ $((HCNUMVER >= 91200)) -ne 0 ] ; then echo "packages: $GITHUB_WORKSPACE/source/./singletons-base" >> cabal.project ; fi
if [ $((HCNUMVER >= 91200)) -ne 0 ] ; then echo "packages: $GITHUB_WORKSPACE/source/./singletons-base-code-generator" >> cabal.project ; fi
cat cabal.project
- name: sdist
run: |
Expand All @@ -210,23 +209,18 @@ jobs:
echo "PKGDIR_singletons_th=${PKGDIR_singletons_th}" >> "$GITHUB_ENV"
PKGDIR_singletons_base="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/singletons-base-[0-9.]*')"
echo "PKGDIR_singletons_base=${PKGDIR_singletons_base}" >> "$GITHUB_ENV"
PKGDIR_singletons_base_code_generator="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/singletons-base-code-generator-[0-9.]*')"
echo "PKGDIR_singletons_base_code_generator=${PKGDIR_singletons_base_code_generator}" >> "$GITHUB_ENV"
rm -f cabal.project cabal.project.local
touch cabal.project
touch cabal.project.local
echo "packages: ${PKGDIR_singletons}" >> cabal.project
if [ $((HCNUMVER >= 91200)) -ne 0 ] ; then echo "packages: ${PKGDIR_singletons_th}" >> cabal.project ; fi
if [ $((HCNUMVER >= 91200)) -ne 0 ] ; then echo "packages: ${PKGDIR_singletons_base}" >> cabal.project ; fi
if [ $((HCNUMVER >= 91200)) -ne 0 ] ; then echo "packages: ${PKGDIR_singletons_base_code_generator}" >> cabal.project ; fi
if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package singletons" >> cabal.project ; fi
if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi
if [ $((HCNUMVER >= 91200)) -ne 0 ] ; then echo "package singletons-th" >> cabal.project ; fi
if [ $((HCNUMVER >= 91200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi
if [ $((HCNUMVER >= 91200)) -ne 0 ] ; then echo "package singletons-base" >> cabal.project ; fi
if [ $((HCNUMVER >= 91200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi
if [ $((HCNUMVER >= 91200)) -ne 0 ] ; then echo "package singletons-base-code-generator" >> cabal.project ; fi
if [ $((HCNUMVER >= 91200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi
cat >> cabal.project <<EOF
allow-newer: indexed-traversable:base

Expand All @@ -235,7 +229,7 @@ jobs:
location: https://github.com/goldfirere/th-desugar
tag: 44158f7bb7faa2022795446505217b5e52862da5
EOF
$HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(Cabal|Cabal-syntax|singletons|singletons-base|singletons-base-code-generator|singletons-th)$/; }' >> cabal.project.local
$HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(Cabal|Cabal-syntax|singletons|singletons-base|singletons-th)$/; }' >> cabal.project.local
cat cabal.project
cat cabal.project.local
- name: dump install plan
Expand Down Expand Up @@ -266,8 +260,6 @@ jobs:
if [ $((HCNUMVER >= 91200)) -ne 0 ] ; then ${CABAL} -vnormal check ; fi
if [ $((HCNUMVER >= 91200)) -ne 0 ] ; then cd ${PKGDIR_singletons_base} || false ; fi
if [ $((HCNUMVER >= 91200)) -ne 0 ] ; then ${CABAL} -vnormal check ; fi
if [ $((HCNUMVER >= 91200)) -ne 0 ] ; then cd ${PKGDIR_singletons_base_code_generator} || false ; fi
if [ $((HCNUMVER >= 91200)) -ne 0 ] ; then ${CABAL} -vnormal check ; fi
- name: haddock
run: |
$CABAL v2-haddock --disable-documentation $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all
Expand Down
1 change: 0 additions & 1 deletion cabal.project
Original file line number Diff line number Diff line change
@@ -1,7 +1,6 @@
packages: ./singletons
./singletons-th
./singletons-base
./singletons-base-code-generator

source-repository-package
type: git
Expand Down
6 changes: 0 additions & 6 deletions singletons-base-code-generator/CHANGES.md

This file was deleted.

27 changes: 0 additions & 27 deletions singletons-base-code-generator/LICENSE

This file was deleted.

10 changes: 0 additions & 10 deletions singletons-base-code-generator/README.md

This file was deleted.

This file was deleted.

62 changes: 0 additions & 62 deletions singletons-base-code-generator/src/SingletonsBaseCodeGenerator.hs

This file was deleted.

5 changes: 0 additions & 5 deletions singletons-base/CHANGES.md
Original file line number Diff line number Diff line change
Expand Up @@ -4,11 +4,6 @@ Changelog for the `singletons-base` project
3.5 [2024.12.11]
----------------
* Require building with GHC 9.12.
* Remove the use of a custom `Setup.hs` script. This script has now been
replaced with a [`cabal` code
generator](https://cabal.readthedocs.io/en/stable/cabal-package-description-file.html#pkg-field-test-suite-code-generators)
As such, `singletons-base` now requires the use of `Cabal-3.8` or later in
order to build.
* The types of `sError`, `sErrorWithoutStackTrace`, and `sUndefined` are now
less polymorphic than they were before:

Expand Down
135 changes: 133 additions & 2 deletions singletons-base/Setup.hs
Original file line number Diff line number Diff line change
@@ -1,7 +1,138 @@
{-# OPTIONS_GHC -Wall #-}
module Main where
module Main (main) where

import Control.Monad

import qualified Data.List as List
import Data.String

import Distribution.PackageDescription
import Distribution.Simple
import Distribution.Simple.BuildPaths
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.PackageIndex
import Distribution.Simple.Program
import Distribution.Simple.Setup
import Distribution.Simple.Utils
import Distribution.Text

import System.Directory
import System.FilePath

main :: IO ()
main = defaultMain
main = defaultMainWithHooks simpleUserHooks
{ buildHook = \pkg lbi hooks flags -> do
generateBuildModule flags pkg lbi
buildHook simpleUserHooks pkg lbi hooks flags
, confHook = \(gpd, hbi) flags ->
confHook simpleUserHooks (amendGPD gpd, hbi) flags
, haddockHook = \pkg lbi hooks flags -> do
generateBuildModule (haddockToBuildFlags flags) pkg lbi
haddockHook simpleUserHooks pkg lbi hooks flags
}

-- | Convert only flags used by 'generateBuildModule'.
haddockToBuildFlags :: HaddockFlags -> BuildFlags
haddockToBuildFlags f = emptyBuildFlags
{ buildVerbosity = haddockVerbosity f
, buildDistPref = haddockDistPref f
}

generateBuildModule :: BuildFlags -> PackageDescription -> LocalBuildInfo -> IO ()
generateBuildModule flags pkg lbi = do
rootDir <- getCurrentDirectory
let verbosity = fromFlag (buildVerbosity flags)
distPref = fromFlag (buildDistPref flags)
distPref' | isRelative distPref = rootDir </> distPref
| otherwise = distPref
-- Package DBs
dbStack = withPackageDB lbi ++ [ SpecificPackageDB $ distPref' </> "package.conf.inplace" ]
dbFlags = "-hide-all-packages" : "-package-env=-" : packageDbArgsDb dbStack

ghc = case lookupProgram ghcProgram (withPrograms lbi) of
Just fp -> locationPath $ programLocation fp
Nothing -> error "Can't find GHC path"
withTestLBI pkg lbi $ \suite suitecfg -> when (testName suite == fromString testSuiteName) $ do
let testAutogenDir = autogenComponentModulesDir lbi suitecfg
createDirectoryIfMissingVerbose verbosity True testAutogenDir
let buildSingletonsBaseFile = testAutogenDir </> buildSingletonsBaseModule <.> "hs"
withLibLBI pkg lbi $ \_ libCLBI -> do
let libDeps = map fst $ componentPackageDeps libCLBI
pidx = case dependencyClosure (installedPkgs lbi) libDeps of
Left p -> p
Right _ -> error "Broken dependency closure"
libTransDeps = map installedUnitId $ allPackages pidx
singletonsBaseUnitId = componentUnitId libCLBI
deps = formatDeps (singletonsBaseUnitId:libTransDeps)
allFlags = dbFlags ++ deps
writeFile buildSingletonsBaseFile $ unlines
[ "module Build_singletons_base where"
, ""
, "ghcPath :: FilePath"
, "ghcPath = " ++ show ghc
, ""
, "ghcFlags :: [String]"
, "ghcFlags = " ++ show allFlags
, ""
, "rootDir :: FilePath"
, "rootDir = " ++ show rootDir
]
where
formatDeps = map formatOne
formatOne installedPkgId = "-package-id=" ++ display installedPkgId

-- GHC >= 7.6 uses the '-package-db' flag. See
-- https://ghc.haskell.org/trac/ghc/ticket/5977.
packageDbArgsDb :: [PackageDB] -> [String]
-- special cases to make arguments prettier in common scenarios
packageDbArgsDb dbstack = case dbstack of
(GlobalPackageDB:UserPackageDB:dbs)
| all isSpecific dbs -> concatMap single dbs
(GlobalPackageDB:dbs)
| all isSpecific dbs -> "-no-user-package-db"
: concatMap single dbs
dbs -> "-clear-package-db"
: concatMap single dbs
where
single (SpecificPackageDB db) = [ "-package-db=" ++ db ]
single GlobalPackageDB = [ "-global-package-db" ]
single UserPackageDB = [ "-user-package-db" ]
isSpecific (SpecificPackageDB _) = True
isSpecific _ = False

buildSingletonsBaseModule :: FilePath
buildSingletonsBaseModule = "Build_singletons_base"

testSuiteName :: String
testSuiteName = "singletons-base-test-suite"

amendGPD :: GenericPackageDescription -> GenericPackageDescription
amendGPD gpd = gpd
{ condTestSuites = map f (condTestSuites gpd)
}
where
f (name, condTree)
| name == fromString testSuiteName = (name, condTree')
| otherwise = (name, condTree)
where
-- I miss 'lens'
testSuite = condTreeData condTree
bi = testBuildInfo testSuite
om = otherModules bi
am = autogenModules bi

-- Cons the module to both other-modules and autogen-modules.
-- At the moment, cabal-spec-2.0 and cabal-spec-2.2 don't have
-- "all autogen-modules are other-modules if they aren't exposed-modules"
-- rule. Hopefully cabal-spec-3.0 will have.
--
-- Note: we `nub`, because it's unclear if that's ok to have duplicate
-- modules in the lists.
om' = List.nub $ mn : om
am' = List.nub $ mn : am

mn = fromString buildSingletonsBaseModule

bi' = bi { otherModules = om', autogenModules = am' }
testSuite' = testSuite { testBuildInfo = bi' }
condTree' = condTree { condTreeData = testSuite' }
Loading
Loading