Skip to content

Commit

Permalink
Setup Hooks: make Location a separate data type
Browse files Browse the repository at this point in the history
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).
  • Loading branch information
sheaf authored and Mikolaj committed May 18, 2024
1 parent b7cc326 commit 6dd579f
Show file tree
Hide file tree
Showing 19 changed files with 192 additions and 131 deletions.
1 change: 0 additions & 1 deletion Cabal-hooks/Cabal-hooks.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
23 changes: 5 additions & 18 deletions Cabal-hooks/src/Distribution/Simple/SetupHooks.hs
Original file line number Diff line number Diff line change
Expand Up @@ -78,8 +78,8 @@ module Distribution.Simple.SetupHooks
-- *** Rule inputs/outputs

-- $rulesDemand
, Location
, findFileInDirs
, Location(..)
, location
, autogenComponentModulesDir
, componentBuildDir

Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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.
17 changes: 4 additions & 13 deletions Cabal/src/Distribution/Simple/SetupHooks/Errors.hs
Original file line number Diff line number Diff line change
Expand Up @@ -20,7 +20,6 @@ module Distribution.Simple.SetupHooks.Errors
, RulesException (..)
, setupHooksExceptionCode
, setupHooksExceptionMessage
, showLocs
) where

import Distribution.PackageDescription
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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) ++ "]"
Expand All @@ -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
Expand Down
32 changes: 19 additions & 13 deletions Cabal/src/Distribution/Simple/SetupHooks/Internal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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 (..))
Expand All @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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.
Expand All @@ -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
Expand All @@ -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 ()
Expand All @@ -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 $
Expand Down Expand Up @@ -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.
Expand Down
87 changes: 80 additions & 7 deletions Cabal/src/Distribution/Simple/SetupHooks/Rule.hs
Original file line number Diff line number Diff line change
Expand Up @@ -14,6 +14,7 @@
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
Expand Down Expand Up @@ -65,7 +66,8 @@ module Distribution.Simple.SetupHooks.Rule
, noRules

-- ** Rule inputs/outputs
, Location
, Location (..)
, location

-- ** File/directory monitoring
, MonitorFilePath (..)
Expand Down Expand Up @@ -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
)
Expand Down Expand Up @@ -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
)
Expand All @@ -145,6 +165,10 @@ import qualified Type.Reflection as Typeable
, pattern App
)

import System.FilePath
( normalise
)

--------------------------------------------------------------------------------

{- Note [Fine-grained hooks]
Expand Down Expand Up @@ -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"
Expand All @@ -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.
--
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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)
Expand Down
Loading

0 comments on commit 6dd579f

Please sign in to comment.