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

@@ -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

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.

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

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,15 +925,19 @@ 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
                 ]
               ++ [ "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)"
                  ]
 
       -- 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.

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)