diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index ec94080d..f8ad2830 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -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: | @@ -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 <> 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 @@ -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 diff --git a/cabal.project b/cabal.project index 10df3480..7c168425 100644 --- a/cabal.project +++ b/cabal.project @@ -1,7 +1,6 @@ packages: ./singletons ./singletons-th ./singletons-base - ./singletons-base-code-generator source-repository-package type: git diff --git a/singletons-base-code-generator/CHANGES.md b/singletons-base-code-generator/CHANGES.md deleted file mode 100644 index 09fc0ac8..00000000 --- a/singletons-base-code-generator/CHANGES.md +++ /dev/null @@ -1,6 +0,0 @@ -Changelog for the `singletons-base-code-generator` project -========================================================== - -0.1 [2024.12.11] ----------------- -* Initial release. diff --git a/singletons-base-code-generator/LICENSE b/singletons-base-code-generator/LICENSE deleted file mode 100644 index e1d90009..00000000 --- a/singletons-base-code-generator/LICENSE +++ /dev/null @@ -1,27 +0,0 @@ -Copyright (c) 2022-2024, Ryan Scott -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -1. Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. - -2. Redistributions in binary form must reproduce the above copyright notice, -this list of conditions and the following disclaimer in the documentation -and/or other materials provided with the distribution. - -3. Neither the name of the author nor the names of its contributors may be -used to endorse or promote products derived from this software without -specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" -AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/singletons-base-code-generator/README.md b/singletons-base-code-generator/README.md deleted file mode 100644 index 7ab97d41..00000000 --- a/singletons-base-code-generator/README.md +++ /dev/null @@ -1,10 +0,0 @@ -`singletons-base-code-generator` -================================ - -[![Hackage](https://img.shields.io/hackage/v/singletons-base-code-generator.svg)](http://hackage.haskell.org/package/singletons-base-code-generator) - -A [`cabal` code -generator](https://cabal.readthedocs.io/en/stable/cabal-package-description-file.html#pkg-field-test-suite-code-generators) -used in the test suite for the -[`singletons-base`](https://hackage.haskell.org/package/singletons-base) -library. diff --git a/singletons-base-code-generator/singletons-base-code-generator.cabal b/singletons-base-code-generator/singletons-base-code-generator.cabal deleted file mode 100644 index 78836f18..00000000 --- a/singletons-base-code-generator/singletons-base-code-generator.cabal +++ /dev/null @@ -1,43 +0,0 @@ -cabal-version: 3.8 -name: singletons-base-code-generator -version: 0.1 -synopsis: Code generator for the singletons-base test suite -homepage: http://www.github.com/goldfirere/singletons -category: Dependent Types -author: Ryan Scott -maintainer: Ryan Scott -bug-reports: https://github.com/goldfirere/singletons/issues -stability: experimental -tested-with: GHC == 9.12.1 -extra-doc-files: CHANGES.md -extra-source-files: README.md -license: BSD-3-Clause -license-file: LICENSE -build-type: Simple -description: - A [@cabal@ code - generator](https://cabal.readthedocs.io/en/stable/cabal-package-description-file.html#pkg-field-test-suite-code-generators) - used in the test suite for the - [@singletons-base@](https://hackage.haskell.org/package/singletons-base) - library. - -source-repository this - type: git - location: https://github.com/goldfirere/singletons.git - subdir: singletons-base-code-generator - tag: v0.1 - -source-repository head - type: git - location: https://github.com/goldfirere/singletons.git - subdir: singletons-base-code-generator - branch: master - -executable singletons-base-code-generator - hs-source-dirs: src - ghc-options: -Wall -Wcompat -threaded - default-language: GHC2021 - main-is: SingletonsBaseCodeGenerator.hs - build-depends: base >= 4.21 && < 4.22, - directory >= 1.2 && < 1.4, - filepath >= 1.3 && < 1.6 diff --git a/singletons-base-code-generator/src/SingletonsBaseCodeGenerator.hs b/singletons-base-code-generator/src/SingletonsBaseCodeGenerator.hs deleted file mode 100644 index 9daa628f..00000000 --- a/singletons-base-code-generator/src/SingletonsBaseCodeGenerator.hs +++ /dev/null @@ -1,62 +0,0 @@ --- | A @cabal@ code generator used in the test suite for the @singletons-base@ --- library. This records all of the GHC flags used when building --- @singletons-base@ so that when the test suite invokes GHC, it can find the --- locally built version of @singletons-base@ and its dependencies. -module Main (main) where - -import Data.List (isPrefixOf) -import System.Directory (createDirectoryIfMissing, getCurrentDirectory) -import System.Environment (getArgs) -import System.FilePath ((), (<.>)) - - -main :: IO () -main = do - -- The directory in which singletons-base and its test suite are located. This - -- only works under the assumption that cabal will navigate to that directory - -- before invoking the code generator. This is always the case when I've - -- tested it, but if this assumption does not hold in general, we may need to - -- revisit this assumption. - singletonsBaseDir <- getCurrentDirectory - args <- getArgs - (tgt, rest) <- - case args of - (tgt:allFlags) -> pure (tgt, allFlags) - [] -> fail "Expected at least one argument for code generator" - ghcFlags <- takeGhcArgs rest - -- Filter out GHC language extensions and warnings, as the singletons-base - -- test suite wants to have finer-grained control over these. - let ghcFlags' = filter (\flag -> not (isLangExtension flag || isWarning flag)) ghcFlags - createDirectoryIfMissing True tgt - writeFile (tgt generatedFileName <.> "hs") $ unlines - [ "module " ++ generatedFileName ++ " where" - , "" - , "ghcFlags :: [String]" - , "ghcFlags = " ++ show ghcFlags' - , "" - , "rootDir :: FilePath" - , "rootDir = " ++ show singletonsBaseDir - ] - putStrLn generatedFileName - --- | @cabal@ code generators have a convention that GHC-specific arguments are --- separated from the rest of the @cabal@-specific arguments using @--@. --- Assuming this convention, this function looks up the GHC-specific arguments. -takeGhcArgs :: [String] -> IO [String] -takeGhcArgs ("--":xs) = pure xs -takeGhcArgs (_:xs) = takeGhcArgs xs -takeGhcArgs [] = fail "Expected -- to separate arguments" - --- | Returns 'True' if a GHC command-line argument corresponds to a language --- extension (e.g., @-XTypeFamilies@). -isLangExtension :: String -> Bool -isLangExtension = isPrefixOf "-X" - --- | Returns 'True' if a GHC command-line argument corresponds to a warning flag --- (e.g., @-Wtabs@). -isWarning :: String -> Bool -isWarning flag = any (`isPrefixOf` flag) ["-W", "-fwarn", "-fno-warn"] - --- | The name of the generated file containing the GHC flags. -generatedFileName :: String -generatedFileName = "SingletonsBaseGHCFlags" diff --git a/singletons-base/CHANGES.md b/singletons-base/CHANGES.md index 317f356d..d88d68fe 100644 --- a/singletons-base/CHANGES.md +++ b/singletons-base/CHANGES.md @@ -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: diff --git a/singletons-base/Setup.hs b/singletons-base/Setup.hs index 118731c3..a0692580 100644 --- a/singletons-base/Setup.hs +++ b/singletons-base/Setup.hs @@ -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' } diff --git a/singletons-base/singletons-base.cabal b/singletons-base/singletons-base.cabal index 7f5db355..ed9fc364 100644 --- a/singletons-base/singletons-base.cabal +++ b/singletons-base/singletons-base.cabal @@ -1,6 +1,6 @@ -cabal-version: 3.8 name: singletons-base version: 3.5 +cabal-version: 1.24 synopsis: A promoted and singled version of the base library homepage: http://www.github.com/goldfirere/singletons category: Dependent Types @@ -9,20 +9,18 @@ maintainer: Ryan Scott bug-reports: https://github.com/goldfirere/singletons/issues stability: experimental tested-with: GHC == 9.12.1 -extra-doc-files: CHANGES.md -extra-source-files: README.md - tests/README.md - tests/compile-and-dump/GradingClient/*.hs - tests/compile-and-dump/InsertionSort/*.hs - tests/compile-and-dump/Promote/*.hs +extra-source-files: README.md, CHANGES.md, tests/README.md, + tests/compile-and-dump/GradingClient/*.hs, + tests/compile-and-dump/InsertionSort/*.hs, + tests/compile-and-dump/Promote/*.hs, tests/compile-and-dump/Singletons/*.hs - tests/compile-and-dump/GradingClient/*.golden - tests/compile-and-dump/InsertionSort/*.golden - tests/compile-and-dump/Promote/*.golden + tests/compile-and-dump/GradingClient/*.golden, + tests/compile-and-dump/InsertionSort/*.golden, + tests/compile-and-dump/Promote/*.golden, tests/compile-and-dump/Singletons/*.golden -license: BSD-3-Clause +license: BSD3 license-file: LICENSE -build-type: Simple +build-type: Custom description: @singletons-base@ uses @singletons-th@ to define promoted and singled functions from the @base@ library, including the "Prelude". This library was @@ -65,6 +63,13 @@ source-repository head subdir: singletons-base branch: master +custom-setup + setup-depends: + base >= 4.19 && < 4.22, + Cabal >= 3.0 && < 3.15, + directory >= 1, + filepath >= 1.3 + library hs-source-dirs: src build-depends: base >= 4.21 && < 4.22, @@ -154,21 +159,9 @@ test-suite singletons-base-test-suite bytestring >= 0.10.9, deepseq >= 1.4.4, filepath >= 1.3, - ghc-paths >= 0.1, process >= 1.1, turtle >= 1.5, text >= 1.2, singletons-base, tasty >= 1.2, - tasty-golden >= 2.2, - - -- Dependencies only used when invoking GHC in the test - -- suite - ghc-prim, - ghc-internal, - mtl, - template-haskell, - th-desugar, - transformers - build-tool-depends: singletons-base-code-generator:singletons-base-code-generator - code-generators: singletons-base-code-generator + tasty-golden >= 2.2 diff --git a/singletons-base/tests/SingletonsBaseTestSuiteUtils.hs b/singletons-base/tests/SingletonsBaseTestSuiteUtils.hs index 44eb1c67..d71e3d3f 100644 --- a/singletons-base/tests/SingletonsBaseTestSuiteUtils.hs +++ b/singletons-base/tests/SingletonsBaseTestSuiteUtils.hs @@ -10,12 +10,13 @@ module SingletonsBaseTestSuiteUtils ( , cleanFiles ) where +import Build_singletons_base ( ghcPath, ghcFlags, rootDir ) import Control.Exception ( Exception ) import Data.Foldable ( asum ) import Data.Text ( Text ) import Data.String ( IsString(fromString) ) -import GHC.Paths ( ghc ) -import System.FilePath ( (), takeBaseName, pathSeparator ) +import System.FilePath ( takeBaseName, pathSeparator ) +import System.FilePath ( () ) import System.IO ( IOMode(..), openFile ) import System.Process ( CreateProcess(..), StdStream(..) , createProcess, proc, waitForProcess @@ -25,8 +26,6 @@ import Test.Tasty.Golden ( goldenVsFileDiff ) import qualified Data.Text as Text import qualified Turtle -import SingletonsBaseGHCFlags ( ghcFlags, rootDir ) - -- Some infractructure for handling external process errors newtype ProcessException = ProcessException String deriving newtype (Eq, Ord, Show) @@ -86,7 +85,7 @@ compileAndDumpTest testName opts = compileWithGHC :: IO () compileWithGHC = do hActualFile <- openFile actualFilePath WriteMode - (_, _, _, pid) <- createProcess (proc ghc (testPath : opts)) + (_, _, _, pid) <- createProcess (proc ghcPath (testPath : opts)) { std_out = UseHandle hActualFile , std_err = UseHandle hActualFile , cwd = Just goldenPath }