From 6dd579fc99162d2ca3f861bd360ed102ad69b6ac Mon Sep 17 00:00:00 2001 From: sheaf Date: Thu, 9 May 2024 10:59:49 +0200 Subject: [PATCH] Setup Hooks: make Location a separate data type This commit makes Location a separate data type: data Location where Location :: SymbolicPath Pkg (Dir baseDir) -> RelativePath baseDir File -> Location instead of being a type synonym for (FilePath, FilePath). We noted during testing of the Hooks API that it was all too easy to give an incorrect location for rule outputs, e.g. by omitting an extension or using an absolute path. This change allows us to improve the API documentation, as well as clarifying the types to avoid any ambiguities about what kind of file path is expected (FilePath vs SymbolicPath). --- Cabal-hooks/Cabal-hooks.cabal | 1 - .../src/Distribution/Simple/SetupHooks.hs | 23 ++--- .../Distribution/Simple/SetupHooks/Errors.hs | 17 +--- .../Simple/SetupHooks/Internal.hs | 32 ++++--- .../Distribution/Simple/SetupHooks/Rule.hs | 87 +++++++++++++++++-- .../BuildToolPaths/pbts/SetupHooks.hs | 29 ++++--- .../SetupHooksC2HsRules/SetupHooks.hs | 34 ++++---- .../SetupHooksCyclicRules/SetupHooks.hs | 10 +-- .../SetupHooksCyclicRules/setup.out | 6 +- .../SetupHooksDuplicateRuleId/SetupHooks.hs | 5 +- .../SetupHooksDuplicateRuleId/setup.out | 6 +- .../SetupHooks.hs | 13 ++- .../SetupHooksMissingRuleDep/SetupHooks.hs | 8 +- .../SetupHooksMissingRuleDep/setup.out | 2 +- .../SetupHooksMissingRuleRes/SetupHooks.hs | 6 +- .../SetupHooksMissingRuleRes/setup.out | 2 +- .../SetupHooksRuleOrdering/SetupHooks.hs | 25 +++--- .../SetupHooksUnusedRules/SetupHooks.hs | 8 +- .../SetupHooksUnusedRules/setup.out | 9 +- 19 files changed, 192 insertions(+), 131 deletions(-) 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...