diff --git a/Cabal-hooks/Cabal-hooks.cabal b/Cabal-hooks/Cabal-hooks.cabal index 419f15764b9..367ef185610 100644 --- a/Cabal-hooks/Cabal-hooks.cabal +++ b/Cabal-hooks/Cabal-hooks.cabal @@ -31,7 +31,6 @@ library Cabal >= 3.13 && < 3.15, base >= 4.11 && < 5, containers >= 0.5.0.0 && < 0.8, - filepath >= 1.3.0.1 && < 1.5, transformers >= 0.5.6.0 && < 0.7 ghc-options: -Wall -fno-ignore-asserts -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates diff --git a/Cabal-hooks/src/Distribution/Simple/SetupHooks.hs b/Cabal-hooks/src/Distribution/Simple/SetupHooks.hs index 488387b8e2f..2b49ffc5e5f 100644 --- a/Cabal-hooks/src/Distribution/Simple/SetupHooks.hs +++ b/Cabal-hooks/src/Distribution/Simple/SetupHooks.hs @@ -78,8 +78,8 @@ module Distribution.Simple.SetupHooks -- *** Rule inputs/outputs -- $rulesDemand - , Location - , findFileInDirs + , Location(..) + , location , autogenComponentModulesDir , componentBuildDir @@ -202,7 +202,7 @@ import Distribution.Simple.SetupHooks.Errors import Distribution.Simple.SetupHooks.Internal import Distribution.Simple.SetupHooks.Rule as Rule import Distribution.Simple.Utils - ( dieWithException, findFirstFile) + ( dieWithException ) import Distribution.System ( Platform(..) ) import Distribution.Types.Component @@ -235,12 +235,8 @@ import qualified Control.Monad.Trans.Writer.Strict as Writer #endif import Data.Foldable ( for_ ) -import Data.List - ( nub ) import Data.Map.Strict as Map ( insertLookupWithKey ) -import System.FilePath - ( () ) -------------------------------------------------------------------------------- -- Haddocks for the SetupHooks API @@ -466,14 +462,5 @@ addRuleMonitors :: Monad m => [MonitorFilePath] -> RulesT m () addRuleMonitors = RulesT . lift . lift . Writer.tell {-# INLINEABLE addRuleMonitors #-} --- | Find a file in the given search directories. -findFileInDirs :: FilePath -> [FilePath] -> IO (Maybe Location) -findFileInDirs file dirs = - findFirstFile - (uncurry ()) - [ (path, file) - | path <- nub dirs - ] - - -- TODO: add API functions that search and declare the appropriate monitoring - -- at the same time. +-- TODO: add API functions that search and declare the appropriate monitoring +-- at the same time. diff --git a/Cabal/src/Distribution/Simple/SetupHooks/Errors.hs b/Cabal/src/Distribution/Simple/SetupHooks/Errors.hs index 11577f3506b..22b070e5d41 100644 --- a/Cabal/src/Distribution/Simple/SetupHooks/Errors.hs +++ b/Cabal/src/Distribution/Simple/SetupHooks/Errors.hs @@ -20,7 +20,6 @@ module Distribution.Simple.SetupHooks.Errors , RulesException (..) , setupHooksExceptionCode , setupHooksExceptionMessage - , showLocs ) where import Distribution.PackageDescription @@ -35,8 +34,6 @@ import Data.List import qualified Data.List.NonEmpty as NE import qualified Data.Tree as Tree -import System.FilePath (normalise, ()) - -------------------------------------------------------------------------------- -- | An error involving the @SetupHooks@ module of a package with @@ -137,7 +134,7 @@ rulesExceptionMessage = \case CantFindSourceForRuleDependencies _r deps -> unlines $ ("Pre-build rules: can't find source for rule " ++ what ++ ":") - : map (\d -> " - " <> locPath d) depsL + : map (\d -> " - " <> show d) depsL where depsL = NE.toList deps what @@ -148,7 +145,7 @@ rulesExceptionMessage = \case MissingRuleOutputs _r reslts -> unlines $ ("Pre-build rule did not generate expected result" <> plural <> ":") - : map (\res -> " - " <> locPath res) resultsL + : map (\res -> " - " <> show res) resultsL where resultsL = NE.toList reslts plural @@ -181,13 +178,7 @@ rulesExceptionMessage = \case where showRule :: RuleBinary -> String showRule (Rule{staticDependencies = deps, results = reslts}) = - "Rule: " ++ showDeps deps ++ " --> " ++ showLocs (NE.toList reslts) - -locPath :: Location -> String -locPath (base, fp) = normalise $ base fp - -showLocs :: [Location] -> String -showLocs locs = "[" ++ intercalate ", " (map locPath locs) ++ "]" + "Rule: " ++ showDeps deps ++ " --> " ++ show (NE.toList reslts) showDeps :: [Rule.Dependency] -> String showDeps deps = "[" ++ intercalate ", " (map showDep deps) ++ "]" @@ -196,7 +187,7 @@ showDep :: Rule.Dependency -> String showDep = \case RuleDependency (RuleOutput{outputOfRule = rId, outputIndex = i}) -> "(" ++ show rId ++ ")[" ++ show i ++ "]" - FileDependency loc -> locPath loc + FileDependency loc -> show loc cannotApplyComponentDiffCode :: CannotApplyComponentDiffReason -> Int cannotApplyComponentDiffCode = \case diff --git a/Cabal/src/Distribution/Simple/SetupHooks/Internal.hs b/Cabal/src/Distribution/Simple/SetupHooks/Internal.hs index 25e2f39b1ad..29621ed7567 100644 --- a/Cabal/src/Distribution/Simple/SetupHooks/Internal.hs +++ b/Cabal/src/Distribution/Simple/SetupHooks/Internal.hs @@ -89,7 +89,6 @@ import Distribution.Compat.Prelude import Prelude () import Distribution.Compat.Lens ((.~)) -import Distribution.ModuleName import Distribution.PackageDescription import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler (Compiler (..)) @@ -110,7 +109,7 @@ import Distribution.Simple.SetupHooks.Rule import qualified Distribution.Simple.SetupHooks.Rule as Rule import Distribution.Simple.Utils import Distribution.System (Platform (..)) -import Distribution.Utils.Path (getSymbolicPath) +import Distribution.Utils.Path import qualified Distribution.Types.BuildInfo.Lens as BI (buildInfo) import Distribution.Types.LocalBuildConfig as LBC @@ -125,7 +124,6 @@ import qualified Data.Map as Map import qualified Data.Set as Set import System.Directory (doesFileExist) -import System.FilePath (normalise, (<.>), ()) -------------------------------------------------------------------------------- -- SetupHooks @@ -898,12 +896,12 @@ executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo a -- SetupHooks TODO: maybe requiring all generated modules to appear -- in autogen-modules is excessive; we can look through all modules instead. autogenModPaths = - map (\m -> toFilePath m <.> "hs") $ + map (\m -> moduleNameSymbolicPath m <.> "hs") $ autogenModules $ componentBuildInfo $ targetComponent tgtInfo leafRule_maybe (rId, r) = - if any ((r `ruleOutputsLocation`) . (compAutogenDir,)) autogenModPaths + if any ((r `ruleOutputsLocation`) . (Location compAutogenDir)) autogenModPaths then vertexFromRuleId rId else Nothing leafRules = mapMaybe leafRule_maybe $ Map.toList allRules @@ -927,7 +925,10 @@ executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo a warn verbosity $ unlines $ "The following rules are not demanded and will not be run:" - : [ " - " ++ show rId ++ ", generating " ++ showLocs (NE.toList $ results r) + : concat + [ [ " - " ++ show rId ++ "," + , " generating " ++ show (NE.toList $ results r) + ] | v <- Set.toList nonDemandedRuleVerts , let (r, rId, _) = ruleFromVertex v ] @@ -935,7 +936,8 @@ executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo a , " - Some autogenerated modules were not declared" , " (in the package description or in the pre-configure hooks)" , " - The output location for an autogenerated module is incorrect," - , " (e.g. it is not in the appropriate 'autogenComponentModules' directory)" + , " (e.g. the file extension is incorrect, or" + , " it is not in the appropriate 'autogenComponentModules' directory)" ] -- Run all the demanded rules, in dependency order. @@ -955,7 +957,7 @@ executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo a allDeps = staticDeps ++ fromMaybe [] (fst <$> mbDyn) -- Check that the dependencies the rule expects are indeed present. resolvedDeps <- traverse (resolveDependency verbosity rId allRules) allDeps - missingRuleDeps <- filterM missingDep resolvedDeps + missingRuleDeps <- filterM (missingDep mbWorkDir) resolvedDeps case NE.nonEmpty missingRuleDeps of Just missingDeps -> errorOut $ CantFindSourceForRuleDependencies (toRuleBinary r) missingDeps @@ -965,7 +967,7 @@ executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo a runCmdData rId execCmd -- Throw an error if running the action did not result in -- the generation of outputs that we expected it to. - missingRuleResults <- filterM missingDep $ NE.toList reslts + missingRuleResults <- filterM (missingDep mbWorkDir) $ NE.toList reslts for_ (NE.nonEmpty missingRuleResults) $ \missingResults -> errorOut $ MissingRuleOutputs (toRuleBinary r) missingResults return () @@ -975,7 +977,8 @@ executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo a SUser -> ruleBinary SSystem -> id clbi = targetCLBI tgtInfo - compAutogenDir = getSymbolicPath $ autogenComponentModulesDir lbi clbi + mbWorkDir = mbWorkDirLBI lbi + compAutogenDir = autogenComponentModulesDir lbi clbi errorOut e = dieWithException verbosity $ SetupHooksException $ @@ -1016,11 +1019,14 @@ ruleOutputsLocation (Rule{results = rs}) fp = any (\out -> normaliseLocation out == normaliseLocation fp) rs normaliseLocation :: Location -> Location -normaliseLocation (base, rel) = (normalise base, normalise rel) +normaliseLocation (Location base rel) = + Location (normaliseSymbolicPath base) (normaliseSymbolicPath rel) -- | Is the file we depend on missing? -missingDep :: Location -> IO Bool -missingDep (base, fp) = not <$> doesFileExist (base fp) +missingDep :: Maybe (SymbolicPath CWD (Dir Pkg)) -> Location -> IO Bool +missingDep mbWorkDir loc = not <$> doesFileExist fp + where + fp = interpretSymbolicPath mbWorkDir (location loc) -------------------------------------------------------------------------------- -- Compatibility with HookedBuildInfo. diff --git a/Cabal/src/Distribution/Simple/SetupHooks/Rule.hs b/Cabal/src/Distribution/Simple/SetupHooks/Rule.hs index afbabb859f6..e75d2c29f89 100644 --- a/Cabal/src/Distribution/Simple/SetupHooks/Rule.hs +++ b/Cabal/src/Distribution/Simple/SetupHooks/Rule.hs @@ -14,6 +14,7 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -65,7 +66,8 @@ module Distribution.Simple.SetupHooks.Rule , noRules -- ** Rule inputs/outputs - , Location + , Location (..) + , location -- ** File/directory monitoring , MonitorFilePath (..) @@ -95,9 +97,22 @@ import Distribution.ModuleName ) import Distribution.Simple.FileMonitor.Types import Distribution.Types.UnitId +import Distribution.Utils.Path + ( FileOrDir (..) + , Pkg + , RelativePath + , SymbolicPath + , getSymbolicPath + , () + ) import Distribution.Utils.ShortText ( ShortText ) +import Distribution.Utils.Structured + ( Structure (..) + , Structured (..) + , nominalStructure + ) import Distribution.Verbosity ( Verbosity ) @@ -130,8 +145,13 @@ import Data.Type.Equality ( (:~~:) (HRefl) , type (==) ) -import GHC.Show (showCommaSpace) +import GHC.Show + ( showCommaSpace + ) import GHC.StaticPtr +import GHC.TypeLits + ( Symbol + ) import System.IO.Unsafe ( unsafePerformIO ) @@ -145,6 +165,10 @@ import qualified Type.Reflection as Typeable , pattern App ) +import System.FilePath + ( normalise + ) + -------------------------------------------------------------------------------- {- Note [Fine-grained hooks] @@ -254,7 +278,7 @@ deriving anyclass instance Binary (RuleData System) -- | Trimmed down 'Show' instance, mostly for error messages. instance Show RuleBinary where show (Rule{staticDependencies = deps, results = reslts, ruleCommands = cmds}) = - what ++ ": " ++ showDeps deps ++ " --> " ++ showLocs (NE.toList reslts) + what ++ ": " ++ showDeps deps ++ " --> " ++ show (NE.toList reslts) where what = case cmds of StaticRuleCommand{} -> "Rule" @@ -266,8 +290,6 @@ instance Show RuleBinary where RuleDependency (RuleOutput{outputOfRule = rId, outputIndex = i}) -> "(" ++ show rId ++ ")[" ++ show i ++ "]" FileDependency loc -> show loc - showLocs :: [Location] -> String - showLocs locs = "[" ++ intercalate ", " (map show locs) ++ "]" -- | A rule with static dependencies. -- @@ -322,13 +344,60 @@ dynamicRule dict depsCmd action dep res = -- consisting of a base directory and of a file path relative to that base -- directory path. -- --- In practice, this will be something like @( dir, toFilePath modName )@, +-- In practice, this will be something like @'Location' dir ('moduleNameSymbolicPath' mod <.> "hs")@, -- where: -- -- - for a file dependency, @dir@ is one of the Cabal search directories, -- - for an output, @dir@ is a directory such as @autogenComponentModulesDir@ -- or @componentBuildDir@. -type Location = (FilePath, FilePath) +data Location where + Location + :: { locationBaseDir :: !(SymbolicPath Pkg (Dir baseDir)) + -- ^ Base directory. + , locationRelPath :: !(RelativePath baseDir File) + -- ^ File path relative to base directory (including file extension). + } + -> Location + +instance Eq Location where + Location b1 l1 == Location b2 l2 = + (getSymbolicPath b1 == getSymbolicPath b2) + && (getSymbolicPath l1 == getSymbolicPath l2) +instance Ord Location where + compare (Location b1 l1) (Location b2 l2) = + compare + (getSymbolicPath b1, getSymbolicPath l1) + (getSymbolicPath b2, getSymbolicPath l2) +instance Binary Location where + put (Location base loc) = put (base, loc) + get = Location <$> get <*> get +instance Structured Location where + structure _ = + Structure + tr + 0 + (show tr) + [ + ( "Location" + , + [ nominalStructure $ Proxy @(SymbolicPath Pkg (Dir (Tok "baseDir"))) + , nominalStructure $ Proxy @(RelativePath (Tok "baseDir") File) + ] + ) + ] + where + tr = Typeable.SomeTypeRep $ Typeable.typeRep @Location + +-- | Get a (relative or absolute) un-interpreted path to a 'Location'. +location :: Location -> SymbolicPath Pkg File +location (Location base rel) = base rel + +instance Show Location where + showsPrec p (Location base rel) = + showParen (p > 5) $ + showString (normalise $ getSymbolicPath base) + . showString " " + . showString (normalise $ getSymbolicPath rel) -- The reason for splitting it up this way is that some pre-processors don't -- simply generate one output @.hs@ file from one input file, but have @@ -1015,6 +1084,10 @@ instance } _ -> error "internal error when decoding dynamic rule commands" +-- | A token constructor used to define 'Structured' instances on types +-- that involve existential quantification. +data family Tok (arg :: Symbol) :: k + instance ( forall res. Binary (ruleCmd System LBS.ByteString res) , Binary (deps System LBS.ByteString LBS.ByteString) diff --git a/cabal-testsuite/PackageTests/BuildToolPaths/pbts/SetupHooks.hs b/cabal-testsuite/PackageTests/BuildToolPaths/pbts/SetupHooks.hs index 1386a6ad3c2..478d7af2f5d 100644 --- a/cabal-testsuite/PackageTests/BuildToolPaths/pbts/SetupHooks.hs +++ b/cabal-testsuite/PackageTests/BuildToolPaths/pbts/SetupHooks.hs @@ -38,15 +38,12 @@ import Distribution.Types.Component import Distribution.Types.LocalBuildInfo ( withPrograms ) import Distribution.Utils.Path - ( SymbolicPath, FileOrDir(Dir), CWD, Pkg - , getSymbolicPath, moduleNameSymbolicPath - ) import Distribution.Utils.ShortText ( toShortText ) -- filepath import System.FilePath - ( (), replaceExtension, takeDirectory, takeExtension ) + ( takeExtension ) -------------------------------------------------------------------------------- @@ -120,7 +117,7 @@ preBuildRules Just ( base, rel ) -> return $ Just - ( md, ( getSymbolicPath base, getSymbolicPath rel ) ) + ( md, Location base rel ) Nothing -> return Nothing let ppMods = catMaybes ppMbMods @@ -131,23 +128,27 @@ preBuildRules -- above search (it would be nice to be able to use findFileWithExtensionMonitored). -- 5. Declare a rule for each custom-pp module that runs the pre-processor. - for_ ppMods $ \ ( md, inputLoc@( _inputBaseDir, inputRelPath ) ) -> do - let ext = takeExtension inputRelPath + for_ ppMods $ \ ( md, inputLoc@(Location _inputBaseDir inputRelPath ) ) -> do + let ext = takeExtension $ getSymbolicPath inputRelPath customPp = case ext of ".hs-pp1" -> customPp1 ".hs-pp2" -> customPp2 _ -> error $ "internal error: unhandled extension " ++ ext - outputBaseLoc = getSymbolicPath $ autogenComponentModulesDir lbi clbi - outputLoc = ( outputBaseLoc, replaceExtension inputRelPath "hs" ) + outputBaseLoc = autogenComponentModulesDir lbi clbi + outputLoc = + Location + outputBaseLoc + ( unsafeCoerceSymbolicPath $ replaceExtensionSymbolicPath inputRelPath "hs" ) registerRule_ ( toShortText $ show md ) $ staticRule ( ppCmd customPp inputLoc outputLoc ) [] ( outputLoc NE.:| [] ) ppModule :: ( Verbosity, Maybe (SymbolicPath CWD (Dir Pkg)), ConfiguredProgram, Location, Location ) -> IO () -ppModule ( verbosity, mbWorkDir, customPp, ( inputBaseDir, inputRelPath ), ( outputBaseDir, outputRelPath ) ) = do - let inputPath = inputBaseDir inputRelPath - outputPath = outputBaseDir outputRelPath - createDirectoryIfMissingVerbose verbosity True $ takeDirectory outputPath - runProgramCwd verbosity mbWorkDir customPp [ inputPath, outputPath ] +ppModule ( verbosity, mbWorkDir, customPp, inputLoc, outputLoc ) = do + let inputPath = location inputLoc + outputPath = location outputLoc + createDirectoryIfMissingVerbose verbosity True $ + interpretSymbolicPath mbWorkDir (takeDirectorySymbolicPath outputPath) + runProgramCwd verbosity mbWorkDir customPp [ getSymbolicPath inputPath, getSymbolicPath outputPath ] componentModules :: Component -> [ ModuleName ] componentModules comp = libMods ++ otherModules ( componentBuildInfo comp ) diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/SetupHooks.hs index 67ac7b8ee1d..2e3bcf4a818 100644 --- a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/SetupHooks.hs +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/SetupHooks.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} @@ -15,6 +16,7 @@ import Distribution.ModuleName import Distribution.Simple.LocalBuildInfo (interpretSymbolicPathLBI) import Distribution.Simple.SetupHooks import Distribution.Simple.Utils +import Distribution.Utils.Path import Data.Foldable ( for_ ) import Data.List ( isPrefixOf ) @@ -24,7 +26,6 @@ import Data.Traversable ( for ) import GHC.Generics import qualified Data.Map as Map -import System.FilePath setupHooks :: SetupHooks setupHooks = @@ -39,12 +40,11 @@ preBuildRules :: PreBuildComponentInputs -> RulesM () preBuildRules (PreBuildComponentInputs { buildingWhat = what, localBuildInfo = lbi, targetInfo = tgt }) = mdo let verbosity = buildingWhatVerbosity what clbi = targetCLBI tgt - i = interpretSymbolicPathLBI lbi - autogenDir = i (autogenComponentModulesDir lbi clbi) - buildDir = i (componentBuildDir lbi clbi) + autogenDir = autogenComponentModulesDir lbi clbi + buildDir = componentBuildDir lbi clbi computeC2HsDepsAction (C2HsDepsInput {..}) = do - importLine : _srcLines <- lines <$> readFile (inDir toFilePath modNm <.> "myChs") + importLine : _srcLines <- lines <$> readFile (getSymbolicPath $ inDir moduleNameSymbolicPath modNm <.> "myChs") let imports :: [ModuleName] imports | "imports:" `isPrefixOf` importLine @@ -60,24 +60,24 @@ preBuildRules (PreBuildComponentInputs { buildingWhat = what, localBuildInfo = l , imports ) runC2HsAction (C2HsInput {..}) importModNms = do - let modPath = toFilePath modNm + let modPath = moduleNameSymbolicPath modNm warn verbosity $ "Running C2Hs on " ++ modName modNm ++ ".myChs.\n C2Hs dependencies: " ++ modNames importModNms - _importLine : srcLines <- lines <$> readFile (inDir modPath <.> "myChs") + _importLine : srcLines <- lines <$> readFile (getSymbolicPath $ inDir modPath <.> "myChs") - rewriteFileEx verbosity (hsDir modPath <.> "hs") $ + rewriteFileEx verbosity (getSymbolicPath $ hsDir modPath <.> "hs") $ unlines $ ("module " ++ modName modNm ++ " where\n") : (map ( ( "import " ++ ) . modName ) importModNms ++ srcLines) - rewriteFileEx verbosity (chiDir modPath <.> "myChi") "" + rewriteFileEx verbosity (getSymbolicPath $ chiDir unsafeCoerceSymbolicPath modPath <.> "myChi") "" mkRule modNm = dynamicRule (static Dict) (mkCommand (static Dict) (static computeC2HsDepsAction) $ C2HsDepsInput { ruleIds = modToRuleId, ..}) (mkCommand (static Dict) (static runC2HsAction) $ C2HsInput {hsDir = autogenDir, chiDir = buildDir, ..}) - [ FileDependency (inDir, modPath <.> "myChs") ] - ( ( autogenDir, modPath <.> "hs" ) NE.:| [ ( buildDir, modPath <.> "myChi" ) ] ) + [ FileDependency $ Location inDir (modPath <.> "myChs") ] + ( Location autogenDir (modPath <.> "hs" ) NE.:| [ Location buildDir (unsafeCoerceSymbolicPath modPath <.> "myChi") ] ) where - modPath = toFilePath modNm - inDir = "." + modPath = moduleNameSymbolicPath modNm + inDir = sameDirectory -- NB: in practice, we would get the module names by looking at the .cabal -- file and performing a search for `.chs` files on disk, but for this test @@ -94,7 +94,7 @@ preBuildRules (PreBuildComponentInputs { buildingWhat = what, localBuildInfo = l data C2HsDepsInput = C2HsDepsInput { verbosity :: Verbosity - , inDir :: FilePath + , inDir :: SymbolicPath Pkg (Dir Source) , modNm :: ModuleName , ruleIds :: Map.Map ModuleName RuleId } @@ -106,9 +106,9 @@ data C2HsInput = C2HsInput { verbosity :: Verbosity , modNm :: ModuleName - , inDir :: FilePath - , hsDir :: FilePath - , chiDir :: FilePath + , inDir :: SymbolicPath Pkg (Dir Source) + , hsDir :: SymbolicPath Pkg (Dir Source) + , chiDir :: SymbolicPath Pkg (Dir Build) } deriving stock ( Show, Generic ) deriving anyclass Binary diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/SetupHooks.hs index 65067ebff97..64920431b45 100644 --- a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/SetupHooks.hs +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/SetupHooks.hs @@ -7,6 +7,7 @@ module SetupHooks where import Distribution.Simple.LocalBuildInfo (interpretSymbolicPathLBI) import Distribution.Simple.SetupHooks +import Distribution.Utils.Path (makeRelativePathEx) import qualified Data.List.NonEmpty as NE ( NonEmpty(..) ) @@ -22,19 +23,18 @@ setupHooks = cyclicPreBuildRules :: PreBuildComponentInputs -> RulesM () cyclicPreBuildRules (PreBuildComponentInputs { localBuildInfo = lbi, targetInfo = tgt }) = mdo let clbi = targetCLBI tgt - i = interpretSymbolicPathLBI lbi - autogenDir = i (autogenComponentModulesDir lbi clbi) + autogenDir = autogenComponentModulesDir lbi clbi action = mkCommand (static Dict) (static (\ () -> error "This should not run")) () r1 <- registerRule "r1" $ staticRule action [ RuleDependency $ RuleOutput r2 0 ] - ( ( autogenDir, "G1.hs" ) NE.:| [] ) + ( Location autogenDir (makeRelativePathEx "G1.hs") NE.:| [] ) r2 <- registerRule "r2" $ staticRule action [ RuleDependency $ RuleOutput r1 0 ] - ( ( autogenDir, "G2.hs" ) NE.:| [] ) + ( Location autogenDir (makeRelativePathEx "G2.hs") NE.:| [] ) r3 <- registerRule "r3" $ staticRule action [ RuleDependency $ RuleOutput r3 0 ] - ( ( autogenDir, "G3.hs" ) NE.:| [] ) + ( Location autogenDir (makeRelativePathEx "G3.hs") NE.:| [] ) return () diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/setup.out b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/setup.out index 5076d3b207b..0222d0aa947 100644 --- a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/setup.out +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksCyclicRules/setup.out @@ -3,9 +3,9 @@ Configuring setup-hooks-cyclic-rules-test-0.1.0.0... # Setup build Error: [Cabal-9077] Hooks: cycles in dependency structure of rules: - Rule: [(RuleId {ruleNameSpace = RulesNameSpace {rulesUnitId = UnitId "main", rulesModuleName = ModuleName "SetupHooks", rulesSrcLoc = (18,59)}, ruleName = "r3"})[0]] --> [setup.dist/work/dist/build/autogen/G3.hs] + Rule: [(RuleId {ruleNameSpace = RulesNameSpace {rulesUnitId = UnitId "main", rulesModuleName = ModuleName "SetupHooks", rulesSrcLoc = (19,59)}, ruleName = "r3"})[0]] --> [setup.dist/work/dist/build/autogen G3.hs] - Rule: [(RuleId {ruleNameSpace = RulesNameSpace {rulesUnitId = UnitId "main", rulesModuleName = ModuleName "SetupHooks", rulesSrcLoc = (18,59)}, ruleName = "r2"})[0]] --> [setup.dist/work/dist/build/autogen/G1.hs] + Rule: [(RuleId {ruleNameSpace = RulesNameSpace {rulesUnitId = UnitId "main", rulesModuleName = ModuleName "SetupHooks", rulesSrcLoc = (19,59)}, ruleName = "r2"})[0]] --> [setup.dist/work/dist/build/autogen G1.hs] | - `- Rule: [(RuleId {ruleNameSpace = RulesNameSpace {rulesUnitId = UnitId "main", rulesModuleName = ModuleName "SetupHooks", rulesSrcLoc = (18,59)}, ruleName = "r1"})[0]] --> [setup.dist/work/dist/build/autogen/G2.hs] + `- Rule: [(RuleId {ruleNameSpace = RulesNameSpace {rulesUnitId = UnitId "main", rulesModuleName = ModuleName "SetupHooks", rulesSrcLoc = (19,59)}, ruleName = "r1"})[0]] --> [setup.dist/work/dist/build/autogen G2.hs] diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/SetupHooks.hs index b7ac707e627..2387cfaba92 100644 --- a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/SetupHooks.hs +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/SetupHooks.hs @@ -6,6 +6,7 @@ module SetupHooks where import Distribution.Simple.SetupHooks +import Distribution.Utils.Path (sameDirectory, makeRelativePathEx) import qualified Data.List.NonEmpty as NE ( NonEmpty(..) ) @@ -21,5 +22,5 @@ setupHooks = dupRuleIdRules :: PreBuildComponentInputs -> RulesM () dupRuleIdRules _ = do let cmd = mkCommand (static Dict) (static (\ _ -> error "This should not run")) () - registerRule_ "myRule" $ staticRule cmd [] ( ( "src", "A.hs" ) NE.:| [] ) - registerRule_ "myRule" $ staticRule cmd [] ( ( "src", "B.hs" ) NE.:| [] ) + registerRule_ "myRule" $ staticRule cmd [] ( Location sameDirectory (makeRelativePathEx "A.hs") NE.:| [] ) + registerRule_ "myRule" $ staticRule cmd [] ( Location sameDirectory (makeRelativePathEx "B.hs") NE.:| [] ) diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/setup.out b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/setup.out index 2a5f2e99d6f..f46cdd89acc 100644 --- a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/setup.out +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksDuplicateRuleId/setup.out @@ -2,6 +2,6 @@ Configuring setup-hooks-duplicate-rule-id-test-0.1.0.0... # Setup build Error: [Cabal-7717] -Duplicate pre-build rule (RuleId {ruleNameSpace = RulesNameSpace {rulesUnitId = UnitId "main", rulesModuleName = ModuleName "SetupHooks", rulesSrcLoc = (17,59)}, ruleName = "myRule"}) - - Rule: [] --> [src/A.hs] - - Rule: [] --> [src/B.hs] +Duplicate pre-build rule (RuleId {ruleNameSpace = RulesNameSpace {rulesUnitId = UnitId "main", rulesModuleName = ModuleName "SetupHooks", rulesSrcLoc = (18,59)}, ruleName = "myRule"}) + - Rule: [] --> [. A.hs] + - Rule: [] --> [. B.hs] diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/SetupHooks.hs index 0949aff5b89..56db5f98f13 100644 --- a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/SetupHooks.hs +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/SetupHooks.hs @@ -7,10 +7,10 @@ module SetupHooks where import Distribution.Simple.LocalBuildInfo (interpretSymbolicPathLBI) import Distribution.Simple.SetupHooks -import Distribution.Simple.Utils ( rewriteFileEx ) +import Distribution.Simple.Utils (rewriteFileEx) +import Distribution.Utils.Path import qualified Data.List.NonEmpty as NE ( NonEmpty(..) ) -import System.FilePath setupHooks :: SetupHooks setupHooks = @@ -24,11 +24,10 @@ setupHooks = invalidRuleOutputIndexRules :: PreBuildComponentInputs -> RulesM () invalidRuleOutputIndexRules (PreBuildComponentInputs { buildingWhat = what, localBuildInfo = lbi, targetInfo = tgt }) = do let clbi = targetCLBI tgt - i = interpretSymbolicPathLBI lbi - autogenDir = i (autogenComponentModulesDir lbi clbi) + autogenDir = autogenComponentModulesDir lbi clbi verbosity = buildingWhatVerbosity what action = mkCommand (static Dict) $ static (\ ((dir, modNm), verb) -> do - let loc = dir modNm <.> "hs" + let loc = getSymbolicPath dir modNm <.> "hs" rewriteFileEx verb loc $ "module " ++ modNm ++ " where {}" ) @@ -36,8 +35,8 @@ invalidRuleOutputIndexRules (PreBuildComponentInputs { buildingWhat = what, loca r1 <- registerRule "r1" $ staticRule (action ((autogenDir, "A"), verbosity)) - [] ( ( autogenDir, "A.hs" ) NE.:| [] ) + [] ( Location autogenDir (makeRelativePathEx "A.hs") NE.:| [] ) registerRule_ "r2" $ staticRule (action ((autogenDir, "B"), verbosity)) [ RuleDependency $ RuleOutput r1 7 ] - ( ( autogenDir, "B.hs" ) NE.:| [] ) + ( Location autogenDir (makeRelativePathEx "B.hs") NE.:| [] ) diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/SetupHooks.hs index 47ff3296163..1f1adcf7ab1 100644 --- a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/SetupHooks.hs +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/SetupHooks.hs @@ -6,6 +6,7 @@ module SetupHooks where import Distribution.Simple.LocalBuildInfo (interpretSymbolicPathLBI) import Distribution.Simple.SetupHooks +import Distribution.Utils.Path (sameDirectory, makeRelativePathEx) import qualified Data.List.NonEmpty as NE ( NonEmpty(..) ) @@ -21,10 +22,9 @@ setupHooks = missingDepRules :: PreBuildComponentInputs -> RulesM () missingDepRules (PreBuildComponentInputs { localBuildInfo = lbi, targetInfo = tgt }) = do let clbi = targetCLBI tgt - i = interpretSymbolicPathLBI lbi - autogenDir = i (autogenComponentModulesDir lbi clbi) + autogenDir = autogenComponentModulesDir lbi clbi action = mkCommand (static Dict) (static (\ _ -> error "This should not run")) () registerRule_ "r" $ staticRule action - [ FileDependency ( ".", "Missing.hs" ) ] - ( ( autogenDir, "G.hs" ) NE.:| [] ) + [ FileDependency $ Location sameDirectory (makeRelativePathEx "Missing.hs") ] + ( Location autogenDir (makeRelativePathEx "G.hs") NE.:| [] ) diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/setup.out b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/setup.out index bfbd911994d..c95e66def0c 100644 --- a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/setup.out +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleDep/setup.out @@ -3,4 +3,4 @@ Configuring setup-hooks-missing-rule-dep-test-0.1.0.0... # Setup build Error: [Cabal-1071] Pre-build rules: can't find source for rule dependency: - - Missing.hs + - . Missing.hs diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/SetupHooks.hs index 6b5ce60dd81..4223ee4385f 100644 --- a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/SetupHooks.hs +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/SetupHooks.hs @@ -6,6 +6,7 @@ module SetupHooks where import Distribution.Simple.LocalBuildInfo (interpretSymbolicPathLBI) import Distribution.Simple.SetupHooks +import Distribution.Utils.Path (makeRelativePathEx) import qualified Data.List.NonEmpty as NE ( NonEmpty(..) ) @@ -21,10 +22,9 @@ setupHooks = missingResRules :: PreBuildComponentInputs -> RulesM () missingResRules (PreBuildComponentInputs { localBuildInfo = lbi, targetInfo = tgt }) = do let clbi = targetCLBI tgt - i = interpretSymbolicPathLBI lbi - autogenDir = i (autogenComponentModulesDir lbi clbi) + autogenDir = autogenComponentModulesDir lbi clbi action = mkCommand (static Dict) (static (\ _ -> return ())) () registerRule_ "r" $ staticRule action [ ] - ( ( autogenDir, "G.hs" ) NE.:| [] ) + ( Location autogenDir (makeRelativePathEx "G.hs") NE.:| [] ) diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/setup.out b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/setup.out index 5659bca63e1..1e0fd56bb6f 100644 --- a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/setup.out +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksMissingRuleRes/setup.out @@ -3,4 +3,4 @@ Configuring setup-hooks-missing-rule-res-test-0.1.0.0... # Setup build Error: [Cabal-3498] Pre-build rule did not generate expected result: - - setup.dist/work/dist/build/autogen/G.hs + - setup.dist/work/dist/build/autogen G.hs diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/SetupHooks.hs index a301e71cff0..e15c3ae2ead 100644 --- a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/SetupHooks.hs +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/SetupHooks.hs @@ -9,14 +9,12 @@ module SetupHooks where import Distribution.Simple.LocalBuildInfo (interpretSymbolicPathLBI) import Distribution.Simple.SetupHooks import Distribution.Simple.Utils ( rewriteFileEx, warn ) +import Distribution.Utils.Path import Data.Foldable ( for_ ) import qualified Data.List.NonEmpty as NE ( NonEmpty(..) ) import Data.Traversable ( for ) -import System.FilePath - ( (<.>), () ) - setupHooks :: SetupHooks setupHooks = noSetupHooks @@ -37,25 +35,28 @@ preBuildRules :: PreBuildComponentInputs -> RulesM () preBuildRules (PreBuildComponentInputs { buildingWhat = what, localBuildInfo = lbi, targetInfo = tgt }) = mdo let verbosity = buildingWhatVerbosity what clbi = targetCLBI tgt - i = interpretSymbolicPathLBI lbi - autogenDir = i (autogenComponentModulesDir lbi clbi) + autogenDir = autogenComponentModulesDir lbi clbi mkAction = mkCommand (static Dict) $ static (\ (dir, verb, (inMod, outMod)) -> do warn verb $ "Running rule: " ++ inMod ++ " --> " ++ outMod - let loc = dir outMod <.> "hs" + let loc = getSymbolicPath dir outMod <.> "hs" rewriteFileEx verb loc $ "module " ++ outMod ++ " where { import " ++ inMod ++ " }" ) - actionArg inMod outMod = (autogenDir, verbosity, (inMod, outMod)) + actionArg inMod outMod = + (autogenDir, verbosity, (inMod, outMod)) mkRule action input outMod = staticRule action [ input ] - ( ( autogenDir, outMod <.> "hs" ) NE.:| [] ) - - r1 <- registerRule "r1" $ mkRule (mkAction (actionArg "B" "C")) (RuleDependency $ RuleOutput r2 0) "C" -- B --> C - r2 <- registerRule "r2" $ mkRule (mkAction (actionArg "A" "B")) (FileDependency (".", "A.hs")) "B" -- A --> B - r3 <- registerRule "r3" $ mkRule (mkAction (actionArg "C" "D")) (RuleDependency $ RuleOutput r1 0) "D" -- C --> D + ( Location autogenDir (makeRelativePathEx outMod <.> "hs") NE.:| [] ) + + -- B --> C + -- A --> B + -- C --> D + r1 <- registerRule "r1" $ mkRule (mkAction (actionArg "B" "C")) (RuleDependency $ RuleOutput r2 0) "C" + r2 <- registerRule "r2" $ mkRule (mkAction (actionArg "A" "B")) (FileDependency $ Location sameDirectory (makeRelativePathEx "A.hs")) "B" + r3 <- registerRule "r3" $ mkRule (mkAction (actionArg "C" "D")) (RuleDependency $ RuleOutput r1 0) "D" return () diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/SetupHooks.hs index e1d2141aa61..bae5ace431d 100644 --- a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/SetupHooks.hs +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/SetupHooks.hs @@ -7,6 +7,7 @@ module SetupHooks where import Distribution.Simple.LocalBuildInfo (interpretSymbolicPathLBI) import Distribution.Simple.SetupHooks +import Distribution.Utils.Path (makeRelativePathEx) import qualified Data.List.NonEmpty as NE ( NonEmpty(..) ) @@ -22,12 +23,11 @@ setupHooks = unusedPreBuildRules :: PreBuildComponentInputs -> RulesM () unusedPreBuildRules (PreBuildComponentInputs { localBuildInfo = lbi, targetInfo = tgt }) = do let clbi = targetCLBI tgt - i = interpretSymbolicPathLBI lbi - autogenDir = i (autogenComponentModulesDir lbi clbi) + autogenDir = autogenComponentModulesDir lbi clbi action = mkCommand (static Dict) (static (\ _ -> error "This should not run")) () registerRule_ "r1" $ staticRule action [] - ( ( autogenDir, "X.hs" ) NE.:| [ ( autogenDir, "Y.hs" ) ] ) + ( Location autogenDir (makeRelativePathEx "X.hs") NE.:| [ Location autogenDir (makeRelativePathEx "Y.hs") ] ) registerRule_ "r2" $ staticRule action [] - ( ( autogenDir, "Z.what" ) NE.:| [] ) + ( Location autogenDir (makeRelativePathEx "Z.hs") NE.:| [] ) diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/setup.out b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/setup.out index b5b0f048ce6..47872b4f83d 100644 --- a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/setup.out +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksUnusedRules/setup.out @@ -2,12 +2,15 @@ Configuring setup-hooks-unused-rules-test-0.1.0.0... # Setup build Warning: The following rules are not demanded and will not be run: - - RuleId {ruleNameSpace = RulesNameSpace {rulesUnitId = UnitId "main", rulesModuleName = ModuleName "SetupHooks", rulesSrcLoc = (18,59)}, ruleName = "r1"}, generating [setup.dist/work/dist/build/autogen/X.hs, setup.dist/work/dist/build/autogen/Y.hs] - - RuleId {ruleNameSpace = RulesNameSpace {rulesUnitId = UnitId "main", rulesModuleName = ModuleName "SetupHooks", rulesSrcLoc = (18,59)}, ruleName = "r2"}, generating [setup.dist/work/dist/build/autogen/Z.what] + - RuleId {ruleNameSpace = RulesNameSpace {rulesUnitId = UnitId "main", rulesModuleName = ModuleName "SetupHooks", rulesSrcLoc = (19,59)}, ruleName = "r1"}, + generating [setup.dist/work/dist/build/autogen X.hs,setup.dist/work/dist/build/autogen Y.hs] + - RuleId {ruleNameSpace = RulesNameSpace {rulesUnitId = UnitId "main", rulesModuleName = ModuleName "SetupHooks", rulesSrcLoc = (19,59)}, ruleName = "r2"}, + generating [setup.dist/work/dist/build/autogen Z.hs] Possible reasons for this error: - Some autogenerated modules were not declared (in the package description or in the pre-configure hooks) - The output location for an autogenerated module is incorrect, - (e.g. it is not in the appropriate 'autogenComponentModules' directory) + (e.g. the file extension is incorrect, or + it is not in the appropriate 'autogenComponentModules' directory) Preprocessing library for setup-hooks-unused-rules-test-0.1.0.0... Building library for setup-hooks-unused-rules-test-0.1.0.0...