Skip to content
Snippets Groups Projects
Unverified Commit 6b34e66b authored by Rodrigo Mesquita's avatar Rodrigo Mesquita :seedling:
Browse files

Migrate cabal-doctest v2

parent 6401689d
No related branches found
No related tags found
1 merge request!23Wip/romes/migration v2 + v3
Hide whitespace changes
Inline Side-by-side
patches/cabal-doctest-1.0.9.patch
+ 82
− 42
View file @ 6b34e66b
diff --git a/cabal-doctest.cabal b/cabal-doctest.cabal
index 30aeb12..a5b1895 100644
index 30aeb12..5d01844 100644
--- a/cabal-doctest.cabal
+++ b/cabal-doctest.cabal
@@ -44,8 +44,8 @@ library
@@ -44,8 +44,9 @@ library
other-modules:
other-extensions:
build-depends:
......@@ -10,24 +10,27 @@ index 30aeb12..a5b1895 100644
- , Cabal >=1.10 && <3.8
+ base >=4.3 && <4.21
+ , Cabal >=1.10 && <3.13
+ , Cabal-hooks
, directory
, filepath
diff --git a/src/Distribution/Extra/Doctest.hs b/src/Distribution/Extra/Doctest.hs
index ac5d07d..ffb6209 100644
index ac5d07d..8620cf0 100644
--- a/src/Distribution/Extra/Doctest.hs
+++ b/src/Distribution/Extra/Doctest.hs
@@ -1,5 +1,9 @@
@@ -1,5 +1,11 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE StaticPointers #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE DisambiguateRecordFields #-}
+
-- | The provided 'generateBuildModule' generates 'Build_doctests' module.
-- That module exports enough configuration, so your doctests could be simply
--
@@ -34,6 +38,7 @@
@@ -34,6 +40,7 @@
module Distribution.Extra.Doctest (
defaultMainWithDoctests,
defaultMainAutoconfWithDoctests,
......@@ -35,7 +38,17 @@ index ac5d07d..ffb6209 100644
addDoctestsUserHook,
doctestsUserHooks,
generateBuildModule,
@@ -57,20 +62,15 @@ import Data.String
@@ -44,6 +51,9 @@ module Distribution.Extra.Doctest (
#define InstalledPackageId UnitId
#endif
+import qualified Data.List.NonEmpty as NE
+import Distribution.Utils.ShortText (toShortText)
+import GHC.StaticPtr
import Control.Monad
(when)
import Data.IORef
@@ -57,20 +67,15 @@ import Data.String
import Distribution.Package
(InstalledPackageId, Package (..))
import Distribution.PackageDescription
......@@ -60,7 +73,14 @@ index ac5d07d..ffb6209 100644
import Distribution.Simple.Utils
(createDirectoryIfMissingVerbose, info)
import Distribution.Text
@@ -133,6 +133,7 @@ import Distribution.Utils.Path
@@ -127,12 +132,13 @@ import Distribution.Types.LibraryName
#if MIN_VERSION_Cabal(3,6,0)
import Distribution.Utils.Path
- (getSymbolicPath)
+ (getSymbolicPath, makeSymbolicPath)
#endif
#if MIN_VERSION_directory(1,2,2)
import System.Directory
(makeAbsolute)
......@@ -68,7 +88,7 @@ index ac5d07d..ffb6209 100644
#else
import System.Directory
(getCurrentDirectory)
@@ -160,6 +161,70 @@ mkVersion ds = Version ds []
@@ -160,6 +166,60 @@ mkVersion ds = Version ds []
-- Mains
-------------------------------------------------------------------------------
......@@ -108,38 +128,28 @@ index ac5d07d..ffb6209 100644
+ }
+ , buildHooks =
+ noBuildHooks
+ { preBuildComponentRules = fromRulesM $ RulesM $
+ \PreBuildComponentInputs{buildingWhat=flags, localBuildInfo=lbi, targetInfo=tgt} ->
+ -- Generate the contents of the "Build_doctests" module inside the
+ -- test-suite whose name matches the provided test-suite name.
+ case componentName $ targetComponent tgt of
+ CTestName test_nm | test_nm == fromString testSuiteName
+ -> do
+ let pkg = localPkgDescr lbi
+ actId <- registerAction $
+ Action $ \_resolvedDeps resolve -> do
+ -- We re-use the generateBuildModule function, but
+ -- it could probably be simplified with the new
+ -- SetupHooks API.
+ generateBuildModule testSuiteName flags pkg lbi
+ (Just $ resolveLocation resolve SrcFile)
+ return $ do
+ _ <- registerRule $
+ Rule
+ { unresolvedDependencies=[]
+ , monitoredValue=Nothing
+ , monitoredDirs=[]
+ , results=[(SrcFile, "Build_doctests.hs")]
+ , actionId=actId }
+ return ()
+ _ -> return . return $ ()
+ { preBuildComponentRules = Just $ rules (static ()) (buildRules testSuiteName)
+ }
+ }
+
+buildRules :: String -> PreBuildComponentInputs -> RulesM ()
+buildRules testSuiteName PreBuildComponentInputs{buildingWhat, localBuildInfo=lbi, targetInfo=tgt} = do
+ -- Generate the contents of the "Build_doctests" module inside the
+ -- test-suite whose name matches the provided test-suite name.
+ let autogendir = getSymbolicPath $ autogenComponentModulesDir lbi (targetCLBI tgt)
+ let action = mkCommand (static Dict) $ static (\(name, flags, lbi, autogendir) -> do
+ -- We re-use the generateBuildModule function, but
+ -- it could probably be simplified with the new
+ -- SetupHooks API.
+ generateBuildModule name flags (localPkgDescr lbi) lbi
+ (Just autogendir))
+ registerRule_ ("doctest-" <> toShortText testSuiteName) $
+ staticRule (action (testSuiteName, buildingWhat, lbi, autogendir)) [] (NE.singleton (autogendir, "Build_doctests.hs"))
+
-- | A default main with doctests:
--
-- @
@@ -196,7 +261,7 @@ doctestsUserHooks testsuiteName =
@@ -196,7 +256,7 @@ doctestsUserHooks testsuiteName =
addDoctestsUserHook :: String -> UserHooks -> UserHooks
addDoctestsUserHook testsuiteName uh = uh
{ buildHook = \pkg lbi hooks flags -> do
......@@ -148,7 +158,7 @@ index ac5d07d..ffb6209 100644
buildHook uh pkg lbi hooks flags
-- We use confHook to add "Build_Doctests" to otherModules and autogenModules.
--
@@ -204,17 +269,10 @@ addDoctestsUserHook testsuiteName uh = uh
@@ -204,17 +264,10 @@ addDoctestsUserHook testsuiteName uh = uh
, confHook = \(gpd, hbi) flags ->
confHook uh (amendGPD testsuiteName gpd, hbi) flags
, haddockHook = \pkg lbi hooks flags -> do
......@@ -167,7 +177,7 @@ index ac5d07d..ffb6209 100644
data Name = NameLib (Maybe String) | NameExe String deriving (Eq, Show)
nameToString :: Name -> String
@@ -245,16 +303,23 @@ data Component = Component Name [String] [String] [String]
@@ -245,16 +298,23 @@ data Component = Component Name [String] [String] [String]
-- main :: IO ()
-- main = defaultMainWithHooks simpleUserHooks
-- { buildHook = \pkg lbi hooks flags -> do
......@@ -192,32 +202,62 @@ index ac5d07d..ffb6209 100644
+ -> IO ()
+generateBuildModule testSuiteName flags pkg lbi givenTestAutogenDir = do
+ let verbosity = buildingWhatVerbosity flags
+ let distPref = buildingWhatDistPref flags
+ let distPref = getSymbolicPath $ buildingWhatDistPref flags
-- Package DBs & environments
let dbStack = withPackageDB lbi ++ [ SpecificPackageDB $ distPref </> "package.conf.inplace" ]
@@ -265,9 +330,9 @@ generateBuildModule testSuiteName flags pkg lbi = do
@@ -265,9 +325,9 @@ generateBuildModule testSuiteName flags pkg lbi = do
withTestLBI pkg lbi $ \suite suitecfg -> when (testName suite == fromString testSuiteName) $ do
#if MIN_VERSION_Cabal(1,25,0)
- let testAutogenDir = autogenComponentModulesDir lbi suitecfg
+ let testAutogenDir = fromMaybe (autogenComponentModulesDir lbi suitecfg) givenTestAutogenDir
+ let testAutogenDir = fromMaybe (getSymbolicPath $ autogenComponentModulesDir lbi suitecfg) givenTestAutogenDir
#else
- let testAutogenDir = autogenModulesDir lbi
+ let testAutogenDir = fromMaybe (autogenModulesDir lbi) givenTestAutogenDir
#endif
createDirectoryIfMissingVerbose verbosity True testAutogenDir
@@ -360,7 +425,7 @@ generateBuildModule testSuiteName flags pkg lbi = do
@@ -321,7 +381,7 @@ generateBuildModule testSuiteName flags pkg lbi = do
-- We need the directory with the component's cabal_macros.h!
#if MIN_VERSION_Cabal(1,25,0)
- let compAutogenDir = autogenComponentModulesDir lbi compCfg
+ let compAutogenDir = getSymbolicPath $ autogenComponentModulesDir lbi compCfg
#else
let compAutogenDir = autogenModulesDir lbi
#endif
@@ -336,10 +396,10 @@ generateBuildModule testSuiteName flags pkg lbi = do
#else
: hsSourceDirs compBI
#endif
- includeArgs <- mapM (fmap ("-I"++) . makeAbsolute) $ includeDirs compBI
+ includeArgs <- mapM (fmap ("-I"++) . makeAbsolute . getSymbolicPath) $ includeDirs compBI
-- We clear all includes, so the CWD isn't used.
let iArgs' = map ("-i"++) iArgsNoPrefix
- iArgs = "-i" : iArgs'
+ iArgs = "-i" : iArgs' :: [String]
-- default-extensions
let extensionArgs = map (("-X"++) . display) $ defaultExtensions compBI
@@ -354,13 +414,13 @@ generateBuildModule testSuiteName flags pkg lbi = do
-- even though the main-is module is named Main, its filepath might
-- actually be Something.hs. To account for this possibility, we simply
-- pass the full path to the main-is module instead.
- mainIsPath <- T.traverse (findFileEx verbosity iArgsNoPrefix) (compMainIs comp)
+ mainIsPath <- T.traverse (findFileEx verbosity (makeSymbolicPath <$> iArgsNoPrefix)) (compMainIs comp)
let all_sources = map display module_sources
++ additionalModules
++ maybeToList mainIsPath
- ++ maybeToList mainIsPath
+ ++ maybeToList (getSymbolicPath <$> mainIsPath)
- let component = Component
+ let component' = Component
(mbCompName comp)
(formatDeps $ testDeps compCfg suitecfg)
(concat
@@ -376,7 +441,7 @@ generateBuildModule testSuiteName flags pkg lbi = do
@@ -376,7 +436,7 @@ generateBuildModule testSuiteName flags pkg lbi = do
all_sources
-- modify IORef, append component
......
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment