Skip to content

Commit f9e242f

Browse files
mergify[bot]mergify[bot]
authored
Merge pull request #9992 from mpickering/wip/hooks-location
SetupHooks: make Location a separate data type
2 parents b7cc326 + 6dd579f commit f9e242f

File tree

19 files changed

+192
-131
lines changed

19 files changed

+192
-131
lines changed

‎Cabal-hooks/Cabal-hooks.cabal

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -31,7 +31,6 @@ library
3131
Cabal >= 3.13 && < 3.15,
3232
base >= 4.11 && < 5,
3333
containers >= 0.5.0.0 && < 0.8,
34-
filepath >= 1.3.0.1 && < 1.5,
3534
transformers >= 0.5.6.0 && < 0.7
3635

3736
ghc-options: -Wall -fno-ignore-asserts -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates

‎Cabal-hooks/src/Distribution/Simple/SetupHooks.hs

Lines changed: 5 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -78,8 +78,8 @@ module Distribution.Simple.SetupHooks
7878
-- *** Rule inputs/outputs
7979

8080
-- $rulesDemand
81-
, Location
82-
, findFileInDirs
81+
, Location(..)
82+
, location
8383
, autogenComponentModulesDir
8484
, componentBuildDir
8585

@@ -202,7 +202,7 @@ import Distribution.Simple.SetupHooks.Errors
202202
import Distribution.Simple.SetupHooks.Internal
203203
import Distribution.Simple.SetupHooks.Rule as Rule
204204
import Distribution.Simple.Utils
205-
( dieWithException, findFirstFile)
205+
( dieWithException )
206206
import Distribution.System
207207
( Platform(..) )
208208
import Distribution.Types.Component
@@ -235,12 +235,8 @@ import qualified Control.Monad.Trans.Writer.Strict as Writer
235235
#endif
236236
import Data.Foldable
237237
( for_ )
238-
import Data.List
239-
( nub )
240238
import Data.Map.Strict as Map
241239
( insertLookupWithKey )
242-
import System.FilePath
243-
( (</>) )
244240

245241
--------------------------------------------------------------------------------
246242
-- Haddocks for the SetupHooks API
@@ -466,14 +462,5 @@ addRuleMonitors :: Monad m => [MonitorFilePath] -> RulesT m ()
466462
addRuleMonitors = RulesT . lift . lift . Writer.tell
467463
{-# INLINEABLE addRuleMonitors #-}
468464

469-
-- | Find a file in the given search directories.
470-
findFileInDirs :: FilePath -> [FilePath] -> IO (Maybe Location)
471-
findFileInDirs file dirs =
472-
findFirstFile
473-
(uncurry (</>))
474-
[ (path, file)
475-
| path <- nub dirs
476-
]
477-
478-
-- TODO: add API functions that search and declare the appropriate monitoring
479-
-- at the same time.
465+
-- TODO: add API functions that search and declare the appropriate monitoring
466+
-- at the same time.

‎Cabal/src/Distribution/Simple/SetupHooks/Errors.hs

Lines changed: 4 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -20,7 +20,6 @@ module Distribution.Simple.SetupHooks.Errors
2020
, RulesException (..)
2121
, setupHooksExceptionCode
2222
, setupHooksExceptionMessage
23-
, showLocs
2423
) where
2524

2625
import Distribution.PackageDescription
@@ -35,8 +34,6 @@ import Data.List
3534
import qualified Data.List.NonEmpty as NE
3635
import qualified Data.Tree as Tree
3736

38-
import System.FilePath (normalise, (</>))
39-
4037
--------------------------------------------------------------------------------
4138

4239
-- | An error involving the @SetupHooks@ module of a package with
@@ -137,7 +134,7 @@ rulesExceptionMessage = \case
137134
CantFindSourceForRuleDependencies _r deps ->
138135
unlines $
139136
("Pre-build rules: can't find source for rule " ++ what ++ ":")
140-
: map (\d -> " - " <> locPath d) depsL
137+
: map (\d -> " - " <> show d) depsL
141138
where
142139
depsL = NE.toList deps
143140
what
@@ -148,7 +145,7 @@ rulesExceptionMessage = \case
148145
MissingRuleOutputs _r reslts ->
149146
unlines $
150147
("Pre-build rule did not generate expected result" <> plural <> ":")
151-
: map (\res -> " - " <> locPath res) resultsL
148+
: map (\res -> " - " <> show res) resultsL
152149
where
153150
resultsL = NE.toList reslts
154151
plural
@@ -181,13 +178,7 @@ rulesExceptionMessage = \case
181178
where
182179
showRule :: RuleBinary -> String
183180
showRule (Rule{staticDependencies = deps, results = reslts}) =
184-
"Rule: " ++ showDeps deps ++ " --> " ++ showLocs (NE.toList reslts)
185-
186-
locPath :: Location -> String
187-
locPath (base, fp) = normalise $ base </> fp
188-
189-
showLocs :: [Location] -> String
190-
showLocs locs = "[" ++ intercalate ", " (map locPath locs) ++ "]"
181+
"Rule: " ++ showDeps deps ++ " --> " ++ show (NE.toList reslts)
191182

192183
showDeps :: [Rule.Dependency] -> String
193184
showDeps deps = "[" ++ intercalate ", " (map showDep deps) ++ "]"
@@ -196,7 +187,7 @@ showDep :: Rule.Dependency -> String
196187
showDep = \case
197188
RuleDependency (RuleOutput{outputOfRule = rId, outputIndex = i}) ->
198189
"(" ++ show rId ++ ")[" ++ show i ++ "]"
199-
FileDependency loc -> locPath loc
190+
FileDependency loc -> show loc
200191

201192
cannotApplyComponentDiffCode :: CannotApplyComponentDiffReason -> Int
202193
cannotApplyComponentDiffCode = \case

‎Cabal/src/Distribution/Simple/SetupHooks/Internal.hs

Lines changed: 19 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -89,7 +89,6 @@ import Distribution.Compat.Prelude
8989
import Prelude ()
9090

9191
import Distribution.Compat.Lens ((.~))
92-
import Distribution.ModuleName
9392
import Distribution.PackageDescription
9493
import Distribution.Simple.BuildPaths
9594
import Distribution.Simple.Compiler (Compiler (..))
@@ -110,7 +109,7 @@ import Distribution.Simple.SetupHooks.Rule
110109
import qualified Distribution.Simple.SetupHooks.Rule as Rule
111110
import Distribution.Simple.Utils
112111
import Distribution.System (Platform (..))
113-
import Distribution.Utils.Path (getSymbolicPath)
112+
import Distribution.Utils.Path
114113

115114
import qualified Distribution.Types.BuildInfo.Lens as BI (buildInfo)
116115
import Distribution.Types.LocalBuildConfig as LBC
@@ -125,7 +124,6 @@ import qualified Data.Map as Map
125124
import qualified Data.Set as Set
126125

127126
import System.Directory (doesFileExist)
128-
import System.FilePath (normalise, (<.>), (</>))
129127

130128
--------------------------------------------------------------------------------
131129
-- SetupHooks
@@ -898,12 +896,12 @@ executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo a
898896
-- SetupHooks TODO: maybe requiring all generated modules to appear
899897
-- in autogen-modules is excessive; we can look through all modules instead.
900898
autogenModPaths =
901-
map (\m -> toFilePath m <.> "hs") $
899+
map (\m -> moduleNameSymbolicPath m <.> "hs") $
902900
autogenModules $
903901
componentBuildInfo $
904902
targetComponent tgtInfo
905903
leafRule_maybe (rId, r) =
906-
if any ((r `ruleOutputsLocation`) . (compAutogenDir,)) autogenModPaths
904+
if any ((r `ruleOutputsLocation`) . (Location compAutogenDir)) autogenModPaths
907905
then vertexFromRuleId rId
908906
else Nothing
909907
leafRules = mapMaybe leafRule_maybe $ Map.toList allRules
@@ -927,15 +925,19 @@ executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo a
927925
warn verbosity $
928926
unlines $
929927
"The following rules are not demanded and will not be run:"
930-
: [ " - " ++ show rId ++ ", generating " ++ showLocs (NE.toList $ results r)
928+
: concat
929+
[ [ " - " ++ show rId ++ ","
930+
, " generating " ++ show (NE.toList $ results r)
931+
]
931932
| v <- Set.toList nonDemandedRuleVerts
932933
, let (r, rId, _) = ruleFromVertex v
933934
]
934935
++ [ "Possible reasons for this error:"
935936
, " - Some autogenerated modules were not declared"
936937
, " (in the package description or in the pre-configure hooks)"
937938
, " - The output location for an autogenerated module is incorrect,"
938-
, " (e.g. it is not in the appropriate 'autogenComponentModules' directory)"
939+
, " (e.g. the file extension is incorrect, or"
940+
, " it is not in the appropriate 'autogenComponentModules' directory)"
939941
]
940942

941943
-- Run all the demanded rules, in dependency order.
@@ -955,7 +957,7 @@ executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo a
955957
allDeps = staticDeps ++ fromMaybe [] (fst <$> mbDyn)
956958
-- Check that the dependencies the rule expects are indeed present.
957959
resolvedDeps <- traverse (resolveDependency verbosity rId allRules) allDeps
958-
missingRuleDeps <- filterM missingDep resolvedDeps
960+
missingRuleDeps <- filterM (missingDep mbWorkDir) resolvedDeps
959961
case NE.nonEmpty missingRuleDeps of
960962
Just missingDeps ->
961963
errorOut $ CantFindSourceForRuleDependencies (toRuleBinary r) missingDeps
@@ -965,7 +967,7 @@ executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo a
965967
runCmdData rId execCmd
966968
-- Throw an error if running the action did not result in
967969
-- the generation of outputs that we expected it to.
968-
missingRuleResults <- filterM missingDep $ NE.toList reslts
970+
missingRuleResults <- filterM (missingDep mbWorkDir) $ NE.toList reslts
969971
for_ (NE.nonEmpty missingRuleResults) $ \missingResults ->
970972
errorOut $ MissingRuleOutputs (toRuleBinary r) missingResults
971973
return ()
@@ -975,7 +977,8 @@ executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo a
975977
SUser -> ruleBinary
976978
SSystem -> id
977979
clbi = targetCLBI tgtInfo
978-
compAutogenDir = getSymbolicPath $ autogenComponentModulesDir lbi clbi
980+
mbWorkDir = mbWorkDirLBI lbi
981+
compAutogenDir = autogenComponentModulesDir lbi clbi
979982
errorOut e =
980983
dieWithException verbosity $
981984
SetupHooksException $
@@ -1016,11 +1019,14 @@ ruleOutputsLocation (Rule{results = rs}) fp =
10161019
any (\out -> normaliseLocation out == normaliseLocation fp) rs
10171020

10181021
normaliseLocation :: Location -> Location
1019-
normaliseLocation (base, rel) = (normalise base, normalise rel)
1022+
normaliseLocation (Location base rel) =
1023+
Location (normaliseSymbolicPath base) (normaliseSymbolicPath rel)
10201024

10211025
-- | Is the file we depend on missing?
1022-
missingDep :: Location -> IO Bool
1023-
missingDep (base, fp) = not <$> doesFileExist (base </> fp)
1026+
missingDep :: Maybe (SymbolicPath CWD (Dir Pkg)) -> Location -> IO Bool
1027+
missingDep mbWorkDir loc = not <$> doesFileExist fp
1028+
where
1029+
fp = interpretSymbolicPath mbWorkDir (location loc)
10241030

10251031
--------------------------------------------------------------------------------
10261032
-- Compatibility with HookedBuildInfo.

‎Cabal/src/Distribution/Simple/SetupHooks/Rule.hs

Lines changed: 80 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,7 @@
1414
{-# LANGUAGE MultiWayIf #-}
1515
{-# LANGUAGE NamedFieldPuns #-}
1616
{-# LANGUAGE PatternSynonyms #-}
17+
{-# LANGUAGE PolyKinds #-}
1718
{-# LANGUAGE QuantifiedConstraints #-}
1819
{-# LANGUAGE RankNTypes #-}
1920
{-# LANGUAGE ScopedTypeVariables #-}
@@ -65,7 +66,8 @@ module Distribution.Simple.SetupHooks.Rule
6566
, noRules
6667

6768
-- ** Rule inputs/outputs
68-
, Location
69+
, Location (..)
70+
, location
6971

7072
-- ** File/directory monitoring
7173
, MonitorFilePath (..)
@@ -95,9 +97,22 @@ import Distribution.ModuleName
9597
)
9698
import Distribution.Simple.FileMonitor.Types
9799
import Distribution.Types.UnitId
100+
import Distribution.Utils.Path
101+
( FileOrDir (..)
102+
, Pkg
103+
, RelativePath
104+
, SymbolicPath
105+
, getSymbolicPath
106+
, (</>)
107+
)
98108
import Distribution.Utils.ShortText
99109
( ShortText
100110
)
111+
import Distribution.Utils.Structured
112+
( Structure (..)
113+
, Structured (..)
114+
, nominalStructure
115+
)
101116
import Distribution.Verbosity
102117
( Verbosity
103118
)
@@ -130,8 +145,13 @@ import Data.Type.Equality
130145
( (:~~:) (HRefl)
131146
, type (==)
132147
)
133-
import GHC.Show (showCommaSpace)
148+
import GHC.Show
149+
( showCommaSpace
150+
)
134151
import GHC.StaticPtr
152+
import GHC.TypeLits
153+
( Symbol
154+
)
135155
import System.IO.Unsafe
136156
( unsafePerformIO
137157
)
@@ -145,6 +165,10 @@ import qualified Type.Reflection as Typeable
145165
, pattern App
146166
)
147167

168+
import System.FilePath
169+
( normalise
170+
)
171+
148172
--------------------------------------------------------------------------------
149173

150174
{- Note [Fine-grained hooks]
@@ -254,7 +278,7 @@ deriving anyclass instance Binary (RuleData System)
254278
-- | Trimmed down 'Show' instance, mostly for error messages.
255279
instance Show RuleBinary where
256280
show (Rule{staticDependencies = deps, results = reslts, ruleCommands = cmds}) =
257-
what ++ ": " ++ showDeps deps ++ " --> " ++ showLocs (NE.toList reslts)
281+
what ++ ": " ++ showDeps deps ++ " --> " ++ show (NE.toList reslts)
258282
where
259283
what = case cmds of
260284
StaticRuleCommand{} -> "Rule"
@@ -266,8 +290,6 @@ instance Show RuleBinary where
266290
RuleDependency (RuleOutput{outputOfRule = rId, outputIndex = i}) ->
267291
"(" ++ show rId ++ ")[" ++ show i ++ "]"
268292
FileDependency loc -> show loc
269-
showLocs :: [Location] -> String
270-
showLocs locs = "[" ++ intercalate ", " (map show locs) ++ "]"
271293

272294
-- | A rule with static dependencies.
273295
--
@@ -322,13 +344,60 @@ dynamicRule dict depsCmd action dep res =
322344
-- consisting of a base directory and of a file path relative to that base
323345
-- directory path.
324346
--
325-
-- In practice, this will be something like @( dir, toFilePath modName )@,
347+
-- In practice, this will be something like @'Location' dir ('moduleNameSymbolicPath' mod <.> "hs")@,
326348
-- where:
327349
--
328350
-- - for a file dependency, @dir@ is one of the Cabal search directories,
329351
-- - for an output, @dir@ is a directory such as @autogenComponentModulesDir@
330352
-- or @componentBuildDir@.
331-
type Location = (FilePath, FilePath)
353+
data Location where
354+
Location
355+
:: { locationBaseDir :: !(SymbolicPath Pkg (Dir baseDir))
356+
-- ^ Base directory.
357+
, locationRelPath :: !(RelativePath baseDir File)
358+
-- ^ File path relative to base directory (including file extension).
359+
}
360+
-> Location
361+
362+
instance Eq Location where
363+
Location b1 l1 == Location b2 l2 =
364+
(getSymbolicPath b1 == getSymbolicPath b2)
365+
&& (getSymbolicPath l1 == getSymbolicPath l2)
366+
instance Ord Location where
367+
compare (Location b1 l1) (Location b2 l2) =
368+
compare
369+
(getSymbolicPath b1, getSymbolicPath l1)
370+
(getSymbolicPath b2, getSymbolicPath l2)
371+
instance Binary Location where
372+
put (Location base loc) = put (base, loc)
373+
get = Location <$> get <*> get
374+
instance Structured Location where
375+
structure _ =
376+
Structure
377+
tr
378+
0
379+
(show tr)
380+
[
381+
( "Location"
382+
,
383+
[ nominalStructure $ Proxy @(SymbolicPath Pkg (Dir (Tok "baseDir")))
384+
, nominalStructure $ Proxy @(RelativePath (Tok "baseDir") File)
385+
]
386+
)
387+
]
388+
where
389+
tr = Typeable.SomeTypeRep $ Typeable.typeRep @Location
390+
391+
-- | Get a (relative or absolute) un-interpreted path to a 'Location'.
392+
location :: Location -> SymbolicPath Pkg File
393+
location (Location base rel) = base </> rel
394+
395+
instance Show Location where
396+
showsPrec p (Location base rel) =
397+
showParen (p > 5) $
398+
showString (normalise $ getSymbolicPath base)
399+
. showString " </> "
400+
. showString (normalise $ getSymbolicPath rel)
332401

333402
-- The reason for splitting it up this way is that some pre-processors don't
334403
-- simply generate one output @.hs@ file from one input file, but have
@@ -1015,6 +1084,10 @@ instance
10151084
}
10161085
_ -> error "internal error when decoding dynamic rule commands"
10171086

1087+
-- | A token constructor used to define 'Structured' instances on types
1088+
-- that involve existential quantification.
1089+
data family Tok (arg :: Symbol) :: k
1090+
10181091
instance
10191092
( forall res. Binary (ruleCmd System LBS.ByteString res)
10201093
, Binary (deps System LBS.ByteString LBS.ByteString)

0 commit comments

Comments
 (0)