Merge pull request haskell#9992 from mpickering/wip/hooks-location

SetupHooks: make Location a separate data type

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)