Skip to content

Commit 6dd579f

Browse files
sheafMikolaj
sheaf
authored and
Mikolaj
committed
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).
1 parent b7cc326 commit 6dd579f

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)