From b2a62b97d9a047da968fe72bef67c66bc3f546c5 Mon Sep 17 00:00:00 2001 From: sheaf Date: Tue, 5 Mar 2024 11:51:31 +0100 Subject: [PATCH] Split off file monitoring types into Cabal library This commit splits off the file monitoring types from cabal-install into the Cabal library, so that they can be referred to in pre-build rules for SetupHooks. This will allow package authors with Hooks build-type to monitor files and directories specified by globbing. --- Cabal-hooks/src/Distribution/Simple/SetupHooks.hs | 460 +++++++++++++ Cabal/Cabal.cabal | 1 + Cabal/src/Distribution/Simple/FileMonitor/Types.hs | 217 +++++++ .../Simple/{Glob/Internal.hs => Glob.hs} | 245 +++---- Cabal/src/Distribution/Simple/Glob/Internal.hs | 630 ++++-------------- Cabal/src/Distribution/Simple/SetupHooks/Rule.hs | 718 +++++++++++++++++++++ .../src/Distribution/Client/FileMonitor.hs | 137 +--- cabal-install/src/Distribution/Client/Glob.hs | 63 +- 8 files changed, 1663 insertions(+), 808 deletions(-) create mode 100644 Cabal-hooks/src/Distribution/Simple/SetupHooks.hs create mode 100644 Cabal/src/Distribution/Simple/FileMonitor/Types.hs copy Cabal/src/Distribution/Simple/{Glob/Internal.hs => Glob.hs} (79%) rewrite Cabal/src/Distribution/Simple/Glob/Internal.hs (78%) create mode 100644 Cabal/src/Distribution/Simple/SetupHooks/Rule.hs diff --git a/Cabal-hooks/src/Distribution/Simple/SetupHooks.hs b/Cabal-hooks/src/Distribution/Simple/SetupHooks.hs new file mode 100644 index 000000000..3434ab275 --- /dev/null +++ b/Cabal-hooks/src/Distribution/Simple/SetupHooks.hs @@ -0,0 +1,460 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE StaticPointers #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module: Distribution.Simple.SetupHooks +Description: Interface for the @Hooks@ @build-type@. + +This module defines the interface for the @Hooks@ @build-type@. + +To write a package that implements @build-type: Hooks@, you should define +a module @SetupHooks.hs@ which exports a value @setupHooks :: 'SetupHooks'@. +This is a record that declares actions to hook into the cabal build process. + +See 'SetupHooks' for more details. +-} +module Distribution.Simple.SetupHooks + ( -- * Hooks + + -- $setupHooks + SetupHooks(..) + , noSetupHooks + + -- * Configure hooks + + -- $configureHooks + , ConfigureHooks(..) + , noConfigureHooks + -- ** Per-package configure hooks + , PreConfPackageInputs(..) + , PreConfPackageOutputs(..) -- See Note [Not hiding SetupHooks constructors] + , noPreConfPackageOutputs + , PreConfPackageHook + , PostConfPackageInputs(..) + , PostConfPackageHook + -- ** Per-component configure hooks + , PreConfComponentInputs(..) + , PreConfComponentOutputs(..) -- See Note [Not hiding SetupHooks constructors] + , noPreConfComponentOutputs + , PreConfComponentHook + , ComponentDiff(..), emptyComponentDiff, buildInfoComponentDiff + , LibraryDiff, ForeignLibDiff, ExecutableDiff + , TestSuiteDiff, BenchmarkDiff + , BuildInfoDiff + + -- * Build hooks + + , BuildHooks(..), noBuildHooks + , BuildingWhat(..), buildingWhatVerbosity, buildingWhatDistPref + + -- ** Pre-build rules + + -- $preBuildRules + , PreBuildComponentInputs(..) + , PreBuildComponentRules + + -- ** Post-build hooks + , PostBuildComponentInputs(..) + , PostBuildComponentHook + + -- ** Rules + , Rules + , rules + , noRules + , Rule(..) -- See Note [Not hiding SetupHooks constructors] + , Dependency (..) + , RuleOutput (..) + , RuleId + , staticRule, dynamicRule + -- *** Rule inputs/outputs + + -- $rulesDemand + , Location + , findFileInDirs + , autogenComponentModulesDir + , componentBuildDir + + -- *** Actions + , RuleCommands(..) + , Command(..) -- See Note [Not hiding SetupHooks constructors] + , mkCommand + , Dict(..) + + -- *** Rules API + + -- $rulesAPI + , RulesM + , registerRule + , registerRule_ + + -- **** File/directory monitoring + , addRuleMonitors + , MonitorFilePath(..) + , MonitorKindFile(..) + , MonitorKindDir(..) + + -- * Install hooks + , InstallHooks(..), noInstallHooks + , InstallComponentInputs(..), InstallComponentHook + + -- * Re-exports + + -- ** Hooks + -- *** Configure hooks + , ConfigFlags(..) + -- *** Build hooks + , BuildFlags(..), ReplFlags(..), HaddockFlags(..), HscolourFlags(..) + -- *** Install hooks + , CopyFlags(..) + + -- ** @Hooks@ API + -- + -- | These are functions provided as part of the @Hooks@ API. + -- It is recommended to import them from this module as opposed to + -- manually importing them from inside the Cabal module hierarchy. + , installFileGlob, addKnownPrograms + + -- ** General @Cabal@ datatypes + , Verbosity, Compiler(..), Platform(..), Suffix(..) + + -- *** Package information + , LocalBuildConfig, LocalBuildInfo, PackageBuildDescr + -- SetupHooks TODO: we can't simply re-export all the fields of + -- LocalBuildConfig etc, due to the presence of duplicate record fields. + -- Ideally we'd like to e.g. re-export LocalBuildConfig + -- qualified, but qualified re-exports aren't a thing currently. + + , PackageDescription(..) + + -- *** Component information + , Component(..), ComponentName(..), componentName + , BuildInfo(..), emptyBuildInfo + , TargetInfo(..), ComponentLocalBuildInfo(..) + + -- **** Components + , Library(..), ForeignLib(..), Executable(..) + , TestSuite(..), Benchmark(..) + , LibraryName(..) + , emptyLibrary, emptyForeignLib, emptyExecutable + , emptyTestSuite, emptyBenchmark + + -- ** Programs + , Program, ConfiguredProgram, ProgramDb, ProgArg + + ) +where +import Distribution.PackageDescription + ( PackageDescription(..) + , Library(..), ForeignLib(..) + , Executable(..), TestSuite(..), Benchmark(..) + , emptyLibrary, emptyForeignLib + , emptyExecutable, emptyBenchmark, emptyTestSuite + , BuildInfo(..), emptyBuildInfo + , ComponentName(..), LibraryName(..) + ) +import Distribution.Simple.BuildPaths + ( autogenComponentModulesDir ) +import Distribution.Simple.Compiler + ( Compiler(..) ) +import Distribution.Simple.Errors + ( CabalException(SetupHooksException) ) +import Distribution.Simple.Install + ( installFileGlob ) +import Distribution.Simple.LocalBuildInfo + ( componentBuildDir ) +import Distribution.Simple.PreProcess.Types + ( Suffix(..) ) +import Distribution.Simple.Program.Db + ( ProgramDb, addKnownPrograms ) +import Distribution.Simple.Program.Types + ( Program, ConfiguredProgram, ProgArg ) +import Distribution.Simple.Setup + ( BuildFlags(..) + , ConfigFlags(..) + , CopyFlags(..) + , HaddockFlags(..) + , HscolourFlags(..) + , ReplFlags(..) + ) +import Distribution.Simple.SetupHooks.Errors +import Distribution.Simple.SetupHooks.Internal +import Distribution.Simple.SetupHooks.Rule as Rule +import Distribution.Simple.Utils + ( dieWithException, findFirstFile) +import Distribution.System + ( Platform(..) ) +import Distribution.Types.Component + ( Component(..), componentName ) +import Distribution.Types.ComponentLocalBuildInfo + ( ComponentLocalBuildInfo(..) ) +import Distribution.Types.LocalBuildInfo + ( LocalBuildInfo(..) ) +import Distribution.Types.LocalBuildConfig + ( LocalBuildConfig, PackageBuildDescr ) +import Distribution.Types.TargetInfo + ( TargetInfo(..) ) +import Distribution.Utils.ShortText + ( ShortText ) +import Distribution.Verbosity + ( Verbosity ) + +import Control.Monad + ( void ) +import Control.Monad.IO.Class + ( MonadIO(liftIO) ) +import Control.Monad.Trans.Class + ( lift ) +import qualified Control.Monad.Trans.Reader as Reader +import qualified Control.Monad.Trans.State as State +#if MIN_VERSION_transformers(0,5,6) +import qualified Control.Monad.Trans.Writer.CPS as Writer +#else +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 + +{- $setupHooks +A Cabal package with @Hooks@ @build-type@ must define the Haskell module +@SetupHooks@ which defines a value @setupHooks :: 'SetupHooks'@. + +These *setup hooks* allow package authors to customise the configuration and +building of a package by providing certain hooks that get folded into the +general package configuration and building logic within @Cabal@. + +This mechanism replaces the @Custom@ @build-type@, providing better +integration with the rest of the Haskell ecosystem. + +Usage example: + +> -- In your .cabal file +> build-type: Hooks +> +> custom-setup +> setup-depends: +> base >= 4.18 && < 5, +> Cabal-hooks >= 0.1 && < 0.3 + +> -- In SetupHooks.hs, next to your .cabal file +> module SetupHooks where +> import Distribution.Simple.SetupHooks ( SetupHooks, noSetupHooks ) +> +> setupHooks :: SetupHooks +> setupHooks = +> noSetupHooks +> { configureHooks = myConfigureHooks +> , buildHooks = myBuildHooks } + +Note that 'SetupHooks' can be monoidally combined, e.g.: + +> module SetupHooks where +> import Distribution.Simple.SetupHooks +> import qualified SomeOtherLibrary ( setupHooks ) +> +> setupHooks :: SetupHooks +> setupHooks = SomeOtherLibrary.setupHooks <> mySetupHooks +> +> mySetupHooks :: SetupHooks +> mySetupHooks = ... +-} + +{- $configureHooks +Configure hooks can be used to augment the Cabal configure logic with +package-specific logic. The main principle is that the configure hooks can +feed into updating the 'PackageDescription' of a @cabal@ package. From then on, +this package configuration is set in stone, and later hooks (e.g. hooks into +the build phase) can no longer modify this configuration; instead they will +receive this configuration in their inputs, and must honour it. + +Configuration happens at two levels: + + * global configuration covers the entire package, + * local configuration covers a single component. + +Once the global package configuration is done, all hooks work on a +per-component level. The configuration hooks thus follow a simple philosophy: + + * All modifications to global package options must use `preConfPackageHook`. + * All modifications to component configuration options must use `preConfComponentHook`. + +For example, to generate modules inside a given component, you should: + + * In the per-component configure hook, declare the modules you are going to + generate by adding them to the `autogenModules` field for that component + (unless you know them ahead of time, in which case they can be listed + textually in the @.cabal@ file of the project). + * In the build hooks, describe the actions that will generate these modules. +-} + +{- $preBuildRules +Pre-build hooks are specified in the form of a collection of pre-build 'Rules'. + +Pre-build rules are specified as a collection of rules. Each t'Rule' declares +its dependencies, its outputs, and refers to a command to run in order to +execute the rule in the form of a t'RuleCommands'. + +Note that: + + - file dependencies are not specified directly by 'FilePath' but rather use + the 'Location' type, + - rules can directly depend on other rules, which requires the ability to + refer to a rule by 'RuleId', + - rules refer to the actions that execute them using static pointers, in order + to enable serialisation/deserialisation of rules, + - rules can additionally monitor files or directories, which determines + when to re-compute the entire set of rules. + +To construct a t'Rule', you should use one of the 'staticRule' or 'dynamicRule' +smart constructors, to avoid relying on internal implementation details of +the t'Rule' datatype. +-} + +{- $rulesDemand +Rules can declare various kinds of dependencies: + + - 'staticDependencies': files or other rules that a rule statically depends on, + - extra dynamic dependencies, using the 'DynamicRuleCommands' constructor, + - 'MonitoredFileOrDir': additional files or directories to monitor. + +Rules are considered __out-of-date__ precisely when any of the following +conditions apply: + + [O1] there has been a (relevant) change in the files and directories + monitored by the rules, + [O2] the environment passed to the computation of rules has changed. + +If the rules are out-of-date, the build system is expected to re-run the +computation that computes all rules. + +After this re-computation of the set of all rules, we match up new rules +with old rules, by 'RuleId'. A rule is then considered __stale__ if any of +following conditions apply: + + [N] the rule is new, or + [S] the rule matches with an old rule, and either: + + [S1] a file dependency of the rule has been modified/created/deleted, or + a (transitive) rule dependency of the rule is itself stale, or + [S2] the rule is different from the old rule, e.g. the argument stored in + the rule command has changed, or the pointer to the action to run the + rule has changed. (This is determined using the @Eq Rule@ instance.) + +A stale rule becomes no longer stale once we run its associated action. The +build system is responsible for re-running the actions associated with +each stale rule, in dependency order. This means the build system is expected +to behave as follows: + + 1. Any time the rules are out-of-date, query the rules to obtain + up-to-date rules. + 2. Re-run stale rules. +-} + +{- $rulesAPI +Defining pre-build rules can be done in the following style: + +> {-# LANGUAGE BlockArguments, StaticPointers #-} +> myPreBuildRules :: PreBuildComponentRules +> myPreBuildRules = rules $ static myRulesFromEnv +> where +> myRulesFromEnv preBuildEnvironment = do +> let cmd1 = mkCommand (static Dict) $ static \ arg -> do { .. } +> cmd2 = mkCommand (static Dict) $ static \ arg -> do { .. } +> myData <- liftIO someIOAction +> addRuleMonitors [ MonitorDir "someSearchDir" DirContents ] +> registerRule_ $ staticRule (cmd1 arg1) deps1 outs1 +> registerRule_ $ staticRule (cmd1 arg2) deps2 outs2 +> registerRule_ $ staticRule (cmd1 arg3) deps3 outs3 +> registerRule_ $ staticRule (cmd2 arg4) deps4 outs4 + +Here we use the 'rules', 'staticRule' and 'mkCommand' smart constructors, +rather than directly using the v'Rules', v'Rule' and v'Command' constructors, +which insulates us from internal changes to the t'Rules', t'Rule' and t'Command' +datatypes, respectively. + +We use 'addRuleMonitors' to declare a monitored directory that the collection +of rules as a whole depends on. In this case, we declare that they depend on the +contents of the "searchDir" directory. This means that the rules will be +computed anew whenever the contents of this directory change. +-} + +{- Note [Not hiding SetupHooks constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We would like to hide as many datatype constructors from the API as possible +and provide smart constructors instead, so that hook authors don't end up +depending on internal implementation details that are subject to change. + +However, doing so significantly degrades the Haddock documentation. So we +instead opt for exposing the constructor, but suggesting users use the +corresponding smart constructor instead. +-} + +-------------------------------------------------------------------------------- +-- API functions + +-- | Register a rule. Returns an identifier for that rule. +registerRule + :: ShortText -- ^ user-given rule name; + -- these should be unique on a per-package level + -> Rule -- ^ the rule to register + -> RulesT IO RuleId +registerRule nm !newRule = RulesT $ do + RulesEnv { rulesEnvUnitId = unitId + , rulesEnvVerbosity = verbosity } <- Reader.ask + oldRules <- lift $ State.get + let rId = RuleId { ruleUnitId = unitId, ruleName = nm } + (mbDup, newRules) = Map.insertLookupWithKey (\ _ new _old -> new) rId newRule oldRules + for_ mbDup $ \ oldRule -> + liftIO $ dieWithException verbosity + $ SetupHooksException + $ RulesException + $ DuplicateRuleId rId oldRule newRule + lift $ State.put newRules + return rId + +-- | Register a rule, discarding the produced 'RuleId'. +-- +-- Using this function means that you don't expect any other rules to ever +-- depend on any outputs of this rule. Use 'registerRule' to retain the +-- 'RuleId' instead. +registerRule_ + :: ShortText -- ^ user-given rule name; + -- these should be unique on a per-package level + -> Rule -- ^ the rule to register + -> RulesT IO () +registerRule_ i r = void $ registerRule i r + +-- | Declare additional monitored objects for the collection of all rules. +-- +-- When these monitored objects change, the rules are re-computed. +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 + ] + + -- SetupHooks TODO: add API functions that do searching and declare + -- the appropriate monitoring at the same time. diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index c264a39ad..2e9a6b765 100644 --- a/Cabal/Cabal.cabal +++ b/Cabal/Cabal.cabal @@ -106,6 +106,7 @@ library Distribution.Simple.Compiler Distribution.Simple.Configure Distribution.Simple.Errors + Distribution.Simple.FileMonitor.Types Distribution.Simple.Flag Distribution.Simple.GHC Distribution.Simple.GHCJS diff --git a/Cabal/src/Distribution/Simple/FileMonitor/Types.hs b/Cabal/src/Distribution/Simple/FileMonitor/Types.hs new file mode 100644 index 000000000..17ca31988 --- /dev/null +++ b/Cabal/src/Distribution/Simple/FileMonitor/Types.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE DeriveGeneric #-} + +-- | +-- Module: Distribution.Simple.FileMonitor.Types +-- +-- Types for monitoring files and directories. +module Distribution.Simple.FileMonitor.Types + ( -- * Globs with respect to a root + RootedGlob (..) + , FilePathRoot (..) + , Glob + + -- * File monitoring + , MonitorFilePath (..) + , MonitorKindFile (..) + , MonitorKindDir (..) + + -- ** Utility constructors of t'MonitorFilePath' + , monitorFile + , monitorFileHashed + , monitorNonExistentFile + , monitorFileExistence + , monitorDirectory + , monitorNonExistentDirectory + , monitorDirectoryExistence + , monitorFileOrDirectory + , monitorFileGlob + , monitorFileGlobExistence + , monitorFileSearchPath + , monitorFileHashedSearchPath + ) +where + +import Distribution.Compat.Prelude +import Distribution.Simple.Glob.Internal + ( Glob (..) + ) + +import qualified Distribution.Compat.CharParsing as P +import Distribution.Parsec +import Distribution.Pretty +import qualified Text.PrettyPrint as Disp + +-------------------------------------------------------------------------------- +-- Rooted globs. +-- + +-- | A file path specified by globbing, relative +-- to some root directory. +data RootedGlob + = RootedGlob + FilePathRoot + -- ^ what the glob is relative to + Glob + -- ^ the glob + deriving (Eq, Show, Generic) + +instance Binary RootedGlob +instance Structured RootedGlob + +data FilePathRoot + = FilePathRelative + | -- | e.g. @"/"@, @"c:\"@ or result of 'takeDrive' + FilePathRoot FilePath + | FilePathHomeDir + deriving (Eq, Show, Generic) + +instance Binary FilePathRoot +instance Structured FilePathRoot + +------------------------------------------------------------------------------ +-- Types for specifying files to monitor +-- + +-- | A description of a file (or set of files) to monitor for changes. +-- +-- Where file paths are relative they are relative to a common directory +-- (e.g. project root), not necessarily the process current directory. +data MonitorFilePath + = MonitorFile + { monitorKindFile :: !MonitorKindFile + , monitorKindDir :: !MonitorKindDir + , monitorPath :: !FilePath + } + | MonitorFileGlob + { monitorKindFile :: !MonitorKindFile + , monitorKindDir :: !MonitorKindDir + , monitorPathGlob :: !RootedGlob + } + deriving (Eq, Show, Generic) + +data MonitorKindFile + = FileExists + | FileModTime + | FileHashed + | FileNotExists + deriving (Eq, Show, Generic) + +data MonitorKindDir + = DirExists + | DirModTime + | DirNotExists + deriving (Eq, Show, Generic) + +instance Binary MonitorFilePath +instance Binary MonitorKindFile +instance Binary MonitorKindDir + +instance Structured MonitorFilePath +instance Structured MonitorKindFile +instance Structured MonitorKindDir + +-- | Monitor a single file for changes, based on its modification time. +-- The monitored file is considered to have changed if it no longer +-- exists or if its modification time has changed. +monitorFile :: FilePath -> MonitorFilePath +monitorFile = MonitorFile FileModTime DirNotExists + +-- | Monitor a single file for changes, based on its modification time +-- and content hash. The monitored file is considered to have changed if +-- it no longer exists or if its modification time and content hash have +-- changed. +monitorFileHashed :: FilePath -> MonitorFilePath +monitorFileHashed = MonitorFile FileHashed DirNotExists + +-- | Monitor a single non-existent file for changes. The monitored file +-- is considered to have changed if it exists. +monitorNonExistentFile :: FilePath -> MonitorFilePath +monitorNonExistentFile = MonitorFile FileNotExists DirNotExists + +-- | Monitor a single file for existence only. The monitored file is +-- considered to have changed if it no longer exists. +monitorFileExistence :: FilePath -> MonitorFilePath +monitorFileExistence = MonitorFile FileExists DirNotExists + +-- | Monitor a single directory for changes, based on its modification +-- time. The monitored directory is considered to have changed if it no +-- longer exists or if its modification time has changed. +monitorDirectory :: FilePath -> MonitorFilePath +monitorDirectory = MonitorFile FileNotExists DirModTime + +-- | Monitor a single non-existent directory for changes. The monitored +-- directory is considered to have changed if it exists. +monitorNonExistentDirectory :: FilePath -> MonitorFilePath +-- Just an alias for monitorNonExistentFile, since you can't +-- tell the difference between a non-existent directory and +-- a non-existent file :) +monitorNonExistentDirectory = monitorNonExistentFile + +-- | Monitor a single directory for existence. The monitored directory is +-- considered to have changed only if it no longer exists. +monitorDirectoryExistence :: FilePath -> MonitorFilePath +monitorDirectoryExistence = MonitorFile FileNotExists DirExists + +-- | Monitor a single file or directory for changes, based on its modification +-- time. The monitored file is considered to have changed if it no longer +-- exists or if its modification time has changed. +monitorFileOrDirectory :: FilePath -> MonitorFilePath +monitorFileOrDirectory = MonitorFile FileModTime DirModTime + +-- | Monitor a set of files (or directories) identified by a file glob. +-- The monitored glob is considered to have changed if the set of files +-- matching the glob changes (i.e. creations or deletions), or for files if the +-- modification time and content hash of any matching file has changed. +monitorFileGlob :: RootedGlob -> MonitorFilePath +monitorFileGlob = MonitorFileGlob FileHashed DirExists + +-- | Monitor a set of files (or directories) identified by a file glob for +-- existence only. The monitored glob is considered to have changed if the set +-- of files matching the glob changes (i.e. creations or deletions). +monitorFileGlobExistence :: RootedGlob -> MonitorFilePath +monitorFileGlobExistence = MonitorFileGlob FileExists DirExists + +-- | Creates a list of files to monitor when you search for a file which +-- unsuccessfully looked in @notFoundAtPaths@ before finding it at +-- @foundAtPath@. +monitorFileSearchPath :: [FilePath] -> FilePath -> [MonitorFilePath] +monitorFileSearchPath notFoundAtPaths foundAtPath = + monitorFile foundAtPath + : map monitorNonExistentFile notFoundAtPaths + +-- | Similar to 'monitorFileSearchPath', but also instructs us to +-- monitor the hash of the found file. +monitorFileHashedSearchPath :: [FilePath] -> FilePath -> [MonitorFilePath] +monitorFileHashedSearchPath notFoundAtPaths foundAtPath = + monitorFileHashed foundAtPath + : map monitorNonExistentFile notFoundAtPaths + +------------------------------------------------------------------------------ +-- Parsing & pretty-printing +-- + +instance Pretty RootedGlob where + pretty (RootedGlob root pathglob) = pretty root Disp.<> pretty pathglob + +instance Parsec RootedGlob where + parsec = do + root <- parsec + case root of + FilePathRelative -> RootedGlob root <$> parsec + _ -> RootedGlob root <$> parsec <|> pure (RootedGlob root GlobDirTrailing) + +instance Pretty FilePathRoot where + pretty FilePathRelative = Disp.empty + pretty (FilePathRoot root) = Disp.text root + pretty FilePathHomeDir = Disp.char '~' Disp.<> Disp.char '/' + +instance Parsec FilePathRoot where + parsec = root <|> P.try home <|> P.try drive <|> pure FilePathRelative + where + root = FilePathRoot "/" <$ P.char '/' + home = FilePathHomeDir <$ P.string "~/" + drive = do + dr <- P.satisfy $ \c -> (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') + _ <- P.char ':' + _ <- P.char '/' <|> P.char '\\' + return (FilePathRoot (toUpper dr : ":\\")) diff --git a/Cabal/src/Distribution/Simple/Glob/Internal.hs b/Cabal/src/Distribution/Simple/Glob.hs similarity index 79% copy from Cabal/src/Distribution/Simple/Glob/Internal.hs copy to Cabal/src/Distribution/Simple/Glob.hs index 4f0b91eca..50a88d674 100644 --- a/Cabal/src/Distribution/Simple/Glob/Internal.hs +++ b/Cabal/src/Distribution/Simple/Glob.hs @@ -1,11 +1,13 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- -- | --- Module : Distribution.Simple.Glob.Internal +-- Module : Distribution.Simple.Glob -- Copyright : Isaac Jones, Simon Marlow 2003-2004 -- License : BSD3 -- portions Copyright (c) 2007, Galois Inc. @@ -13,63 +15,59 @@ -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- --- Internal module for simple file globbing. --- Please import "Distribution.Simple.Glob" instead. -module Distribution.Simple.Glob.Internal where +-- Simple file globbing. +module Distribution.Simple.Glob + ( -- * Globs + Glob + + -- * Matching on globs + , GlobResult (..) + , globMatches + , fileGlobMatches + , matchGlob + , matchGlobPieces + , matchDirFileGlob + , matchDirFileGlobWithDie + , runDirFileGlob + + -- * Parsing globs + , parseFileGlob + , GlobSyntaxError (..) + , explainGlobSyntaxError + + -- * Utility + , isRecursiveInRoot + ) +where import Distribution.Compat.Prelude import Prelude () -import Control.Monad (mapM) - -import Distribution.Parsec -import Distribution.Pretty - import Distribution.CabalSpecVersion + ( CabalSpecVersion (..) + ) +import Distribution.Pretty +import Distribution.Simple.Errors + ( CabalException (MatchDirFileGlob, MatchDirFileGlobErrors) + ) +import Distribution.Simple.Glob.Internal import Distribution.Simple.Utils -import Distribution.Verbosity hiding (normal) + ( debug + , dieWithException + , getDirectoryContentsRecursive + , warn + ) +import Distribution.Utils.Path +import Distribution.Verbosity + ( Verbosity + , silent + ) +import Control.Monad (mapM) import Data.List (stripPrefix) import System.Directory import System.FilePath -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --------------------------------------------------------------------------------- - --- | A filepath specified by globbing. -data Glob - = -- | @/@ - GlobDir !GlobPieces !Glob - | -- | @**/@, where @**@ denotes recursively traversing - -- all directories and matching filenames on . - GlobDirRecursive !GlobPieces - | -- | A file glob. - GlobFile !GlobPieces - | -- | Trailing dir; a glob ending in @/@. - GlobDirTrailing - deriving (Eq, Show, Generic) - -instance Binary Glob -instance Structured Glob - --- | A single directory or file component of a globbed path -type GlobPieces = [GlobPiece] - --- | A piece of a globbing pattern -data GlobPiece - = -- | A wildcard @*@ - WildCard - | -- | A literal string @dirABC@ - Literal String - | -- | A union of patterns, e.g. @dir/{a,*.txt,c}/...@ - Union [GlobPieces] - deriving (Eq, Show, Generic) - -instance Binary GlobPiece -instance Structured GlobPiece - ------------------------------------------------------------------------------- -- * Matching @@ -121,6 +119,87 @@ matchGlobPieces = goStart go [] (_ : _) = False go (_ : _) "" = False +-- | Extract the matches from a list of 'GlobResult's. +-- +-- Note: throws away the 'GlobMissingDirectory' results; chances are +-- that you want to check for these and error out if any are present. +-- +-- @since 3.12.0.0 +globMatches :: [GlobResult a] -> [a] +globMatches input = [a | GlobMatch a <- input] + +-- | This will 'die'' when the glob matches no files, or if the glob +-- refers to a missing directory, or if the glob fails to parse. +-- +-- The 'Version' argument must be the spec version of the package +-- description being processed, as globs behave slightly differently +-- in different spec versions. +-- +-- The first 'FilePath' argument is the directory that the glob is +-- relative to. It must be a valid directory (and hence it can't be +-- the empty string). The returned values will not include this +-- prefix. +-- +-- The second 'FilePath' is the glob itself. +matchDirFileGlob + :: Verbosity + -> CabalSpecVersion + -> Maybe (SymbolicPath CWD (Dir dir)) + -> SymbolicPathX allowAbs dir file + -> IO [SymbolicPathX allowAbs dir file] +matchDirFileGlob v = matchDirFileGlobWithDie v dieWithException + +-- | Like 'matchDirFileGlob' but with customizable 'die' +-- +-- @since 3.6.0.0 +matchDirFileGlobWithDie + :: Verbosity + -> (forall res. Verbosity -> CabalException -> IO [res]) + -> CabalSpecVersion + -> Maybe (SymbolicPath CWD (Dir dir)) + -> SymbolicPathX allowAbs dir file + -> IO [SymbolicPathX allowAbs dir file] +matchDirFileGlobWithDie verbosity rip version mbWorkDir symPath = + let rawFilePath = getSymbolicPath symPath + dir = maybe "." getSymbolicPath mbWorkDir + in case parseFileGlob version rawFilePath of + Left err -> rip verbosity $ MatchDirFileGlob (explainGlobSyntaxError rawFilePath err) + Right glob -> do + results <- runDirFileGlob verbosity (Just version) dir glob + let missingDirectories = + [missingDir | GlobMissingDirectory missingDir <- results] + matches = globMatches results + directoryMatches = [a | GlobMatchesDirectory a <- results] + + let errors :: [String] + errors = + [ "filepath wildcard '" + ++ rawFilePath + ++ "' refers to the directory" + ++ " '" + ++ missingDir + ++ "', which does not exist or is not a directory." + | missingDir <- missingDirectories + ] + ++ [ "filepath wildcard '" ++ rawFilePath ++ "' does not match any files." + | null matches && null directoryMatches + -- we don't error out on directory matches, simply warn about them and ignore. + ] + + warns :: [String] + warns = + [ "Ignoring directory '" ++ path ++ "'" ++ " listed in a Cabal package field which should only include files (not directories)." + | path <- directoryMatches + ] + + if null errors + then do + unless (null warns) $ + warn verbosity $ + unlines warns + return $ map unsafeMakeSymbolicPath matches + else rip verbosity $ MatchDirFileGlobErrors errors + ------------------------------------------------------------------------------- -- * Parsing & printing @@ -179,82 +258,10 @@ enableMultidot version | version >= CabalSpecV2_4 = True | otherwise = False --- ** Parsing globs otherwise - -instance Pretty Glob where - pretty (GlobDir glob pathglob) = - dispGlobPieces glob - Disp.<> Disp.char '/' - Disp.<> pretty pathglob - pretty (GlobDirRecursive glob) = - Disp.text "**/" - Disp.<> dispGlobPieces glob - pretty (GlobFile glob) = dispGlobPieces glob - pretty GlobDirTrailing = Disp.empty - -instance Parsec Glob where - parsec = parsecPath - where - parsecPath :: CabalParsing m => m Glob - parsecPath = do - glob <- parsecGlob - dirSep *> (GlobDir glob <$> parsecPath <|> pure (GlobDir glob GlobDirTrailing)) <|> pure (GlobFile glob) - -- We could support parsing recursive directory search syntax - -- @**@ here too, rather than just in 'parseFileGlob' - - dirSep :: CabalParsing m => m () - dirSep = - () <$ P.char '/' - <|> P.try - ( do - _ <- P.char '\\' - -- check this isn't an escape code - P.notFollowedBy (P.satisfy isGlobEscapedChar) - ) - - parsecGlob :: CabalParsing m => m GlobPieces - parsecGlob = some parsecPiece - where - parsecPiece = P.choice [literal, wildcard, union] - - wildcard = WildCard <$ P.char '*' - union = Union . toList <$> P.between (P.char '{') (P.char '}') (P.sepByNonEmpty parsecGlob (P.char ',')) - literal = Literal <$> some litchar - - litchar = normal <|> escape - - normal = P.satisfy (\c -> not (isGlobEscapedChar c) && c /= '/' && c /= '\\') - escape = P.try $ P.char '\\' >> P.satisfy isGlobEscapedChar - -------------------------------------------------------------------------------- -- Parse and printing utils -------------------------------------------------------------------------------- -dispGlobPieces :: GlobPieces -> Disp.Doc -dispGlobPieces = Disp.hcat . map dispPiece - where - dispPiece WildCard = Disp.char '*' - dispPiece (Literal str) = Disp.text (escape str) - dispPiece (Union globs) = - Disp.braces - ( Disp.hcat - ( Disp.punctuate - (Disp.char ',') - (map dispGlobPieces globs) - ) - ) - escape [] = [] - escape (c : cs) - | isGlobEscapedChar c = '\\' : c : escape cs - | otherwise = c : escape cs - -isGlobEscapedChar :: Char -> Bool -isGlobEscapedChar '*' = True -isGlobEscapedChar '{' = True -isGlobEscapedChar '}' = True -isGlobEscapedChar ',' = True -isGlobEscapedChar _ = False - -- ** Cabal package globbing errors data GlobSyntaxError diff --git a/Cabal/src/Distribution/Simple/Glob/Internal.hs b/Cabal/src/Distribution/Simple/Glob/Internal.hs dissimilarity index 78% index 4f0b91eca..13661cf97 100644 --- a/Cabal/src/Distribution/Simple/Glob/Internal.hs +++ b/Cabal/src/Distribution/Simple/Glob/Internal.hs @@ -1,497 +1,133 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} - ------------------------------------------------------------------------------ - --- | --- Module : Distribution.Simple.Glob.Internal --- Copyright : Isaac Jones, Simon Marlow 2003-2004 --- License : BSD3 --- portions Copyright (c) 2007, Galois Inc. --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Internal module for simple file globbing. --- Please import "Distribution.Simple.Glob" instead. -module Distribution.Simple.Glob.Internal where - -import Distribution.Compat.Prelude -import Prelude () - -import Control.Monad (mapM) - -import Distribution.Parsec -import Distribution.Pretty - -import Distribution.CabalSpecVersion -import Distribution.Simple.Utils -import Distribution.Verbosity hiding (normal) - -import Data.List (stripPrefix) -import System.Directory -import System.FilePath - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --------------------------------------------------------------------------------- - --- | A filepath specified by globbing. -data Glob - = -- | @/@ - GlobDir !GlobPieces !Glob - | -- | @**/@, where @**@ denotes recursively traversing - -- all directories and matching filenames on . - GlobDirRecursive !GlobPieces - | -- | A file glob. - GlobFile !GlobPieces - | -- | Trailing dir; a glob ending in @/@. - GlobDirTrailing - deriving (Eq, Show, Generic) - -instance Binary Glob -instance Structured Glob - --- | A single directory or file component of a globbed path -type GlobPieces = [GlobPiece] - --- | A piece of a globbing pattern -data GlobPiece - = -- | A wildcard @*@ - WildCard - | -- | A literal string @dirABC@ - Literal String - | -- | A union of patterns, e.g. @dir/{a,*.txt,c}/...@ - Union [GlobPieces] - deriving (Eq, Show, Generic) - -instance Binary GlobPiece -instance Structured GlobPiece - -------------------------------------------------------------------------------- - --- * Matching - --------------------------------------------------------------------------------- - --- | Match a 'Glob' against the file system, starting from a --- given root directory. The results are all relative to the given root. --- --- @since 3.12.0.0 -matchGlob :: FilePath -> Glob -> IO [FilePath] -matchGlob root glob = - -- For this function, which is the general globbing one (doesn't care about - -- cabal spec, used e.g. for monitoring), we consider all matches. - mapMaybe - ( \case - GlobMatch a -> Just a - GlobWarnMultiDot a -> Just a - GlobMatchesDirectory a -> Just a - GlobMissingDirectory{} -> Nothing - ) - <$> runDirFileGlob silent Nothing root glob - --- | Match a globbing pattern against a file path component -matchGlobPieces :: GlobPieces -> String -> Bool -matchGlobPieces = goStart - where - -- From the man page, glob(7): - -- "If a filename starts with a '.', this character must be - -- matched explicitly." - - go, goStart :: [GlobPiece] -> String -> Bool - - goStart (WildCard : _) ('.' : _) = False - goStart (Union globs : rest) cs = - any - (\glob -> goStart (glob ++ rest) cs) - globs - goStart rest cs = go rest cs - - go [] "" = True - go (Literal lit : rest) cs - | Just cs' <- stripPrefix lit cs = - go rest cs' - | otherwise = False - go [WildCard] "" = True - go (WildCard : rest) (c : cs) = go rest (c : cs) || go (WildCard : rest) cs - go (Union globs : rest) cs = any (\glob -> go (glob ++ rest) cs) globs - go [] (_ : _) = False - go (_ : _) "" = False - -------------------------------------------------------------------------------- - --- * Parsing & printing - --------------------------------------------------------------------------------- --- Filepaths with globs may be parsed in the special context is globbing in --- cabal package fields, such as `data-files`. In that case, we restrict the --- globbing syntax to that supported by the cabal spec version in use. --- Otherwise, we parse the globs to the extent of our globbing features --- (wildcards `*`, unions `{a,b,c}`, and directory-recursive wildcards `**`). - --- ** Parsing globs in a cabal package - -parseFileGlob :: CabalSpecVersion -> FilePath -> Either GlobSyntaxError Glob -parseFileGlob version filepath = case reverse (splitDirectories filepath) of - [] -> - Left EmptyGlob - (filename : "**" : segments) - | allowGlobStar -> do - finalSegment <- case splitExtensions filename of - ("*", ext) - | '*' `elem` ext -> Left StarInExtension - | null ext -> Left NoExtensionOnStar - | otherwise -> Right (GlobDirRecursive [WildCard, Literal ext]) - _ - | allowLiteralFilenameGlobStar -> - Right (GlobDirRecursive [Literal filename]) - | otherwise -> - Left LiteralFileNameGlobStar - - foldM addStem finalSegment segments - | otherwise -> Left VersionDoesNotSupportGlobStar - (filename : segments) -> do - pat <- case splitExtensions filename of - ("*", ext) - | not allowGlob -> Left VersionDoesNotSupportGlob - | '*' `elem` ext -> Left StarInExtension - | null ext -> Left NoExtensionOnStar - | otherwise -> Right (GlobFile [WildCard, Literal ext]) - (_, ext) - | '*' `elem` ext -> Left StarInExtension - | '*' `elem` filename -> Left StarInFileName - | otherwise -> Right (GlobFile [Literal filename]) - - foldM addStem pat segments - where - addStem pat seg - | '*' `elem` seg = Left StarInDirectory - | otherwise = Right (GlobDir [Literal seg] pat) - allowGlob = version >= CabalSpecV1_6 - allowGlobStar = version >= CabalSpecV2_4 - allowLiteralFilenameGlobStar = version >= CabalSpecV3_8 - -enableMultidot :: CabalSpecVersion -> Bool -enableMultidot version - | version >= CabalSpecV2_4 = True - | otherwise = False - --- ** Parsing globs otherwise - -instance Pretty Glob where - pretty (GlobDir glob pathglob) = - dispGlobPieces glob - Disp.<> Disp.char '/' - Disp.<> pretty pathglob - pretty (GlobDirRecursive glob) = - Disp.text "**/" - Disp.<> dispGlobPieces glob - pretty (GlobFile glob) = dispGlobPieces glob - pretty GlobDirTrailing = Disp.empty - -instance Parsec Glob where - parsec = parsecPath - where - parsecPath :: CabalParsing m => m Glob - parsecPath = do - glob <- parsecGlob - dirSep *> (GlobDir glob <$> parsecPath <|> pure (GlobDir glob GlobDirTrailing)) <|> pure (GlobFile glob) - -- We could support parsing recursive directory search syntax - -- @**@ here too, rather than just in 'parseFileGlob' - - dirSep :: CabalParsing m => m () - dirSep = - () <$ P.char '/' - <|> P.try - ( do - _ <- P.char '\\' - -- check this isn't an escape code - P.notFollowedBy (P.satisfy isGlobEscapedChar) - ) - - parsecGlob :: CabalParsing m => m GlobPieces - parsecGlob = some parsecPiece - where - parsecPiece = P.choice [literal, wildcard, union] - - wildcard = WildCard <$ P.char '*' - union = Union . toList <$> P.between (P.char '{') (P.char '}') (P.sepByNonEmpty parsecGlob (P.char ',')) - literal = Literal <$> some litchar - - litchar = normal <|> escape - - normal = P.satisfy (\c -> not (isGlobEscapedChar c) && c /= '/' && c /= '\\') - escape = P.try $ P.char '\\' >> P.satisfy isGlobEscapedChar - --------------------------------------------------------------------------------- --- Parse and printing utils --------------------------------------------------------------------------------- - -dispGlobPieces :: GlobPieces -> Disp.Doc -dispGlobPieces = Disp.hcat . map dispPiece - where - dispPiece WildCard = Disp.char '*' - dispPiece (Literal str) = Disp.text (escape str) - dispPiece (Union globs) = - Disp.braces - ( Disp.hcat - ( Disp.punctuate - (Disp.char ',') - (map dispGlobPieces globs) - ) - ) - escape [] = [] - escape (c : cs) - | isGlobEscapedChar c = '\\' : c : escape cs - | otherwise = c : escape cs - -isGlobEscapedChar :: Char -> Bool -isGlobEscapedChar '*' = True -isGlobEscapedChar '{' = True -isGlobEscapedChar '}' = True -isGlobEscapedChar ',' = True -isGlobEscapedChar _ = False - --- ** Cabal package globbing errors - -data GlobSyntaxError - = StarInDirectory - | StarInFileName - | StarInExtension - | NoExtensionOnStar - | EmptyGlob - | LiteralFileNameGlobStar - | VersionDoesNotSupportGlobStar - | VersionDoesNotSupportGlob - deriving (Eq, Show) - -explainGlobSyntaxError :: FilePath -> GlobSyntaxError -> String -explainGlobSyntaxError filepath StarInDirectory = - "invalid file glob '" - ++ filepath - ++ "'. A wildcard '**' is only allowed as the final parent" - ++ " directory. Stars must not otherwise appear in the parent" - ++ " directories." -explainGlobSyntaxError filepath StarInExtension = - "invalid file glob '" - ++ filepath - ++ "'. Wildcards '*' are only allowed as the" - ++ " file's base name, not in the file extension." -explainGlobSyntaxError filepath StarInFileName = - "invalid file glob '" - ++ filepath - ++ "'. Wildcards '*' may only totally replace the" - ++ " file's base name, not only parts of it." -explainGlobSyntaxError filepath NoExtensionOnStar = - "invalid file glob '" - ++ filepath - ++ "'. If a wildcard '*' is used it must be with an file extension." -explainGlobSyntaxError filepath LiteralFileNameGlobStar = - "invalid file glob '" - ++ filepath - ++ "'. Prior to 'cabal-version: 3.8'" - ++ " if a wildcard '**' is used as a parent directory, the" - ++ " file's base name must be a wildcard '*'." -explainGlobSyntaxError _ EmptyGlob = - "invalid file glob. A glob cannot be the empty string." -explainGlobSyntaxError filepath VersionDoesNotSupportGlobStar = - "invalid file glob '" - ++ filepath - ++ "'. Using the double-star syntax requires 'cabal-version: 2.4'" - ++ " or greater. Alternatively, for compatibility with earlier Cabal" - ++ " versions, list the included directories explicitly." -explainGlobSyntaxError filepath VersionDoesNotSupportGlob = - "invalid file glob '" - ++ filepath - ++ "'. Using star wildcards requires 'cabal-version: >= 1.6'. " - ++ "Alternatively if you require compatibility with earlier Cabal " - ++ "versions then list all the files explicitly." - --- Note throughout that we use splitDirectories, not splitPath. On --- Posix, this makes no difference, but, because Windows accepts both --- slash and backslash as its path separators, if we left in the --- separators from the glob we might not end up properly normalised. - -data GlobResult a - = -- | The glob matched the value supplied. - GlobMatch a - | -- | The glob did not match the value supplied because the - -- cabal-version is too low and the extensions on the file did - -- not precisely match the glob's extensions, but rather the - -- glob was a proper suffix of the file's extensions; i.e., if - -- not for the low cabal-version, it would have matched. - GlobWarnMultiDot a - | -- | The glob couldn't match because the directory named doesn't - -- exist. The directory will be as it appears in the glob (i.e., - -- relative to the directory passed to 'matchDirFileGlob', and, - -- for 'data-files', relative to 'data-dir'). - GlobMissingDirectory a - | -- | The glob matched a directory when we were looking for files only. - -- It didn't match a file! - -- - -- @since 3.12.0.0 - GlobMatchesDirectory a - deriving (Show, Eq, Ord, Functor) - --- | Match files against a pre-parsed glob, starting in a directory. --- --- The 'Version' argument must be the spec version of the package --- description being processed, as globs behave slightly differently --- in different spec versions. --- --- The 'FilePath' argument is the directory that the glob is relative --- to. It must be a valid directory (and hence it can't be the empty --- string). The returned values will not include this prefix. -runDirFileGlob - :: Verbosity - -> Maybe CabalSpecVersion - -- ^ If the glob we are running should care about the cabal spec, and warnings such as 'GlobWarnMultiDot', then this should be the version. - -- If you want to run a glob but don't care about any of the cabal-spec restrictions on globs, use 'Nothing'! - -> FilePath - -> Glob - -> IO [GlobResult FilePath] -runDirFileGlob verbosity mspec rawRoot pat = do - -- The default data-dir is null. Our callers -should- be - -- converting that to '.' themselves, but it's a certainty that - -- some future call-site will forget and trigger a really - -- hard-to-debug failure if we don't check for that here. - when (null rawRoot) $ - warn verbosity $ - "Null dir passed to runDirFileGlob; interpreting it " - ++ "as '.'. This is probably an internal error." - let root = if null rawRoot then "." else rawRoot - debug verbosity $ "Expanding glob '" ++ show (pretty pat) ++ "' in directory '" ++ root ++ "'." - -- This function might be called from the project root with dir as - -- ".". Walking the tree starting there involves going into .git/ - -- and dist-newstyle/, which is a lot of work for no reward, so - -- extract the constant prefix from the pattern and start walking - -- there, and only walk as much as we need to: recursively if **, - -- the whole directory if *, and just the specific file if it's a - -- literal. - let - (prefixSegments, variablePattern) = splitConstantPrefix pat - joinedPrefix = joinPath prefixSegments - - -- The glob matching function depends on whether we care about the cabal version or not - doesGlobMatch :: GlobPieces -> String -> Maybe (GlobResult ()) - doesGlobMatch glob str = case mspec of - Just spec -> checkNameMatches spec glob str - Nothing -> if matchGlobPieces glob str then Just (GlobMatch ()) else Nothing - - go (GlobFile glob) dir = do - entries <- getDirectoryContents (root dir) - catMaybes - <$> mapM - ( \s -> do - -- When running a glob from a Cabal package description (i.e. - -- when a cabal spec version is passed as an argument), we - -- disallow matching a @GlobFile@ against a directory, preferring - -- @GlobDir dir GlobDirTrailing@ to specify a directory match. - isFile <- maybe (return True) (const $ doesFileExist (root dir s)) mspec - let match = (dir s <$) <$> doesGlobMatch glob s - return $ - if isFile - then match - else case match of - Just (GlobMatch x) -> Just $ GlobMatchesDirectory x - Just (GlobWarnMultiDot x) -> Just $ GlobMatchesDirectory x - Just (GlobMatchesDirectory x) -> Just $ GlobMatchesDirectory x - Just (GlobMissingDirectory x) -> Just $ GlobMissingDirectory x -- this should never match, unless you are in a file-delete-heavy concurrent setting i guess - Nothing -> Nothing - ) - entries - go (GlobDirRecursive glob) dir = do - entries <- getDirectoryContentsRecursive (root dir) - return $ - mapMaybe - ( \s -> do - globMatch <- doesGlobMatch glob (takeFileName s) - pure ((dir s) <$ globMatch) - ) - entries - go (GlobDir glob globPath) dir = do - entries <- getDirectoryContents (root dir) - subdirs <- - filterM - ( \subdir -> - doesDirectoryExist - (root dir subdir) - ) - $ filter (matchGlobPieces glob) entries - concat <$> traverse (\subdir -> go globPath (dir subdir)) subdirs - go GlobDirTrailing dir = return [GlobMatch dir] - - directoryExists <- doesDirectoryExist (root joinedPrefix) - if directoryExists - then go variablePattern joinedPrefix - else return [GlobMissingDirectory joinedPrefix] - where - -- \| Extract the (possibly null) constant prefix from the pattern. - -- This has the property that, if @(pref, final) = splitConstantPrefix pat@, - -- then @pat === foldr GlobDir final pref@. - splitConstantPrefix :: Glob -> ([FilePath], Glob) - splitConstantPrefix = unfoldr' step - where - step (GlobDir [Literal seg] pat') = Right (seg, pat') - step pat' = Left pat' - - unfoldr' :: (a -> Either r (b, a)) -> a -> ([b], r) - unfoldr' f a = case f a of - Left r -> ([], r) - Right (b, a') -> case unfoldr' f a' of - (bs, r) -> (b : bs, r) - --- | Is the root of this relative glob path a directory-recursive wildcard, e.g. @**/*.txt@ ? -isRecursiveInRoot :: Glob -> Bool -isRecursiveInRoot (GlobDirRecursive _) = True -isRecursiveInRoot _ = False - --- | Check how the string matches the glob under this cabal version -checkNameMatches :: CabalSpecVersion -> GlobPieces -> String -> Maybe (GlobResult ()) -checkNameMatches spec glob candidate - -- Check if glob matches in its general form - | matchGlobPieces glob candidate = - -- if multidot is supported, then this is a clean match - if enableMultidot spec - then pure (GlobMatch ()) - else -- if not, issue a warning saying multidot is needed for the match - - let (_, candidateExts) = splitExtensions $ takeFileName candidate - extractExts :: GlobPieces -> Maybe String - extractExts [] = Nothing - extractExts [Literal lit] - -- Any literal terminating a glob, and which does have an extension, - -- returns that extension. Otherwise, recurse until Nothing is returned. - | let ext = takeExtensions lit - , ext /= "" = - Just ext - extractExts (_ : x) = extractExts x - in case extractExts glob of - Just exts - | exts == candidateExts -> - return (GlobMatch ()) - | exts `isSuffixOf` candidateExts -> - return (GlobWarnMultiDot ()) - _ -> return (GlobMatch ()) - | otherwise = empty - --- | How/does the glob match the given filepath, according to the cabal version? --- Since this is pure, we don't make a distinction between matching on --- directories or files (i.e. this function won't return 'GlobMatchesDirectory') -fileGlobMatches :: CabalSpecVersion -> Glob -> FilePath -> Maybe (GlobResult ()) -fileGlobMatches version g path = go g (splitDirectories path) - where - go GlobDirTrailing [] = Just (GlobMatch ()) - go (GlobFile glob) [file] = checkNameMatches version glob file - go (GlobDirRecursive glob) dirs - | [] <- reverse dirs = - Nothing -- @dir/**/x.txt@ should not match @dir/hello@ - | file : _ <- reverse dirs = - checkNameMatches version glob file - go (GlobDir glob globPath) (dir : dirs) = do - _ <- checkNameMatches version glob dir -- we only care if dir segment matches - go globPath dirs - go _ _ = Nothing +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Glob.Internal +-- Copyright : Isaac Jones, Simon Marlow 2003-2004 +-- License : BSD3 +-- portions Copyright (c) 2007, Galois Inc. +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Internal module for simple file globbing. +-- Please import "Distribution.Simple.Glob" instead. +module Distribution.Simple.Glob.Internal where + +import Distribution.Compat.Prelude +import Prelude () + +import qualified Distribution.Compat.CharParsing as P +import Distribution.Parsec +import Distribution.Pretty +import qualified Text.PrettyPrint as Disp + +-------------------------------------------------------------------------------- + +-- | A filepath specified by globbing. +data Glob + = -- | @/@ + GlobDir !GlobPieces !Glob + | -- | @**/@, where @**@ denotes recursively traversing + -- all directories and matching filenames on . + GlobDirRecursive !GlobPieces + | -- | A file glob. + GlobFile !GlobPieces + | -- | Trailing dir; a glob ending in @/@. + GlobDirTrailing + deriving (Eq, Show, Generic) + +instance Binary Glob +instance Structured Glob + +-- | A single directory or file component of a globbed path +type GlobPieces = [GlobPiece] + +-- | A piece of a globbing pattern +data GlobPiece + = -- | A wildcard @*@ + WildCard + | -- | A literal string @dirABC@ + Literal String + | -- | A union of patterns, e.g. @dir/{a,*.txt,c}/...@ + Union [GlobPieces] + deriving (Eq, Show, Generic) + +instance Binary GlobPiece +instance Structured GlobPiece + +-------------------------------------------------------------------------------- +-- Parsing & pretty-printing + +instance Pretty Glob where + pretty (GlobDir glob pathglob) = + dispGlobPieces glob + Disp.<> Disp.char '/' + Disp.<> pretty pathglob + pretty (GlobDirRecursive glob) = + Disp.text "**/" + Disp.<> dispGlobPieces glob + pretty (GlobFile glob) = dispGlobPieces glob + pretty GlobDirTrailing = Disp.empty + +instance Parsec Glob where + parsec = parsecPath + where + parsecPath :: CabalParsing m => m Glob + parsecPath = do + glob <- parsecGlob + dirSep *> (GlobDir glob <$> parsecPath <|> pure (GlobDir glob GlobDirTrailing)) <|> pure (GlobFile glob) + -- We could support parsing recursive directory search syntax + -- @**@ here too, rather than just in 'parseFileGlob' + + dirSep :: CabalParsing m => m () + dirSep = + () <$ P.char '/' + <|> P.try + ( do + _ <- P.char '\\' + -- check this isn't an escape code + P.notFollowedBy (P.satisfy isGlobEscapedChar) + ) + + parsecGlob :: CabalParsing m => m GlobPieces + parsecGlob = some parsecPiece + where + parsecPiece = P.choice [literal, wildcard, union] + + wildcard = WildCard <$ P.char '*' + union = Union . toList <$> P.between (P.char '{') (P.char '}') (P.sepByNonEmpty parsecGlob (P.char ',')) + literal = Literal <$> some litchar + + litchar = normal <|> escape + + normal = P.satisfy (\c -> not (isGlobEscapedChar c) && c /= '/' && c /= '\\') + escape = P.try $ P.char '\\' >> P.satisfy isGlobEscapedChar + +dispGlobPieces :: GlobPieces -> Disp.Doc +dispGlobPieces = Disp.hcat . map dispPiece + where + dispPiece WildCard = Disp.char '*' + dispPiece (Literal str) = Disp.text (escape str) + dispPiece (Union globs) = + Disp.braces + ( Disp.hcat + ( Disp.punctuate + (Disp.char ',') + (map dispGlobPieces globs) + ) + ) + escape [] = [] + escape (c : cs) + | isGlobEscapedChar c = '\\' : c : escape cs + | otherwise = c : escape cs + +isGlobEscapedChar :: Char -> Bool +isGlobEscapedChar '*' = True +isGlobEscapedChar '{' = True +isGlobEscapedChar '}' = True +isGlobEscapedChar ',' = True +isGlobEscapedChar _ = False diff --git a/Cabal/src/Distribution/Simple/SetupHooks/Rule.hs b/Cabal/src/Distribution/Simple/SetupHooks/Rule.hs new file mode 100644 index 000000000..7e7502450 --- /dev/null +++ b/Cabal/src/Distribution/Simple/SetupHooks/Rule.hs @@ -0,0 +1,718 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module: Distribution.Simple.SetupHooks.Rule +-- +-- Internal module that defines fine-grained rules for setup hooks. +-- Users should import 'Distribution.Simple.SetupHooks' instead. +module Distribution.Simple.SetupHooks.Rule + ( -- * Rules + + -- ** Rule + Rule (..) + , RuleId (..) + , staticRule + , dynamicRule + + -- ** Commands + , RuleCommands (..) + , Command (..) + , runCommand + , mkCommand + , Dict (..) + + -- *** Helpers for executing commands + , RuleCmds + , RuleDynDepsCmd + , RuleExecCmd + , DynDepsCmd (..) + , DepsRes (..) + , ruleDepsCmd + , runRuleDynDepsCmd + , ruleExecCmd + , runRuleExecCmd + + -- ** Collections of rules + , Rules (..) + , Dependency (..) + , RuleOutput (..) + , rules + , noRules + + -- ** Rule inputs/outputs + , Location + + -- ** File/directory monitoring + , MonitorFilePath (..) + , MonitorKindFile (..) + , MonitorKindDir (..) + + -- *** Monadic API for generation of 'ActionId' + , RulesM + , RulesT (..) + , RulesEnv (..) + , computeRules + ) +where + +import qualified Distribution.Compat.Binary as Binary +import Distribution.Compat.Prelude + +import Distribution.Simple.FileMonitor.Types +import Distribution.Types.UnitId +import Distribution.Utils.ShortText + ( ShortText + ) +import Distribution.Verbosity + ( Verbosity + ) + +import Control.Monad.Fix + ( MonadFix + ) +import Control.Monad.Trans + ( MonadIO + , MonadTrans (..) + ) +import qualified Control.Monad.Trans.Reader as Reader +import qualified Control.Monad.Trans.State as State +#if MIN_VERSION_transformers(0,5,6) +import qualified Control.Monad.Trans.Writer.CPS as Writer +#else +import qualified Control.Monad.Trans.Writer.Strict as Writer +#endif +import qualified Data.ByteString.Lazy as LBS +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map + ( empty + ) + +import qualified Data.Kind as Hs +import Data.Type.Equality + ( (:~:) (Refl) + , (:~~:) (HRefl) + ) +import Data.Typeable + ( eqT + ) +import GHC.Show (showCommaSpace) +import GHC.StaticPtr +import System.IO.Unsafe + ( unsafePerformIO + ) +import qualified Type.Reflection as Typeable + ( SomeTypeRep (..) + , TypeRep + , eqTypeRep + , typeRep + , typeRepKind + , withTypeable + ) + +-------------------------------------------------------------------------------- + +{- Note [Fine-grained hooks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To best understand how the framework of fine-grained build rules +fits into Cabal and the greater Haskell ecosystem, it is helpful to think +that we want build tools (such as cabal-install or HLS) to be able to call +individual build rules on-demand, so that e.g. when a user modifies a .xyz file +the associated preprocessor is re-run. + +To do this, we need to perform two different kinds of invocations: + + Query: query the package for the rules that it provides, with their + dependency information. This allows one to determine when each + rule should be rerun. + + (For example, if one rule preprocesses *.xyz into *.hs, we need to + re-run the rule whenever *.xyz is modified.) + + Run: run the relevant action, once one has determined that the rule + has gone stale. + +To do this, any Cabal package with Hooks build-type provides a SetupHooks +module which supports these queries; for example it can be compiled into +a separate executable which can be invoked in the manner described above. +-} + +--------- +-- Rules + +-- | A unique identifier for a t'Rule'. +data RuleId = RuleId + { ruleUnitId :: !UnitId + , ruleName :: !ShortText + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (Binary, Structured) + +-- | A rule consists of: +-- +-- - an action to run to execute the rule, +-- - a description of the rule inputs and outputs. +-- +-- Use 'staticRule' or 'dynamicRule' to construct a rule, overriding specific +-- fields, rather than directly using the 'Rule' constructor. +data Rule + = -- | Please use the 'staticRule' or 'dynamicRule' smart constructors + -- instead of this constructor, in order to avoid relying on internal + -- implementation details. + Rule + { ruleCommands :: !RuleCmds + -- ^ To run this rule, which t'Command's should we execute? + , staticDependencies :: ![Dependency] + -- ^ Static dependencies of this rule. + , results :: !(NE.NonEmpty Location) + -- ^ Results of this rule. + } + deriving stock (Show, Eq, Generic) + deriving anyclass (Binary) + +-- | A rule with static dependencies. +-- +-- Prefer using this smart constructor instead of v'Rule' whenever possible. +staticRule + :: Typeable arg + => Command arg (IO ()) + -> [Dependency] + -> NE.NonEmpty Location + -> Rule +staticRule cmd dep res = + Rule + { ruleCommands = StaticRuleCommand{staticRuleCommand = cmd} + , staticDependencies = dep + , results = res + } + +-- | A rule with dynamic dependencies. +-- +-- Prefer using this smart constructor instead of v'Rule' whenever possible. +dynamicRule + :: (Typeable depsArg, Typeable depsRes, Typeable arg) + => StaticPtr (Dict (Binary depsRes, Show depsRes, Eq depsRes)) + -> Command depsArg (IO ([Dependency], depsRes)) + -> Command arg (depsRes -> IO ()) + -> [Dependency] + -> NE.NonEmpty Location + -> Rule +dynamicRule dict depsCmd action dep res = + Rule + { ruleCommands = + DynamicRuleCommands + { dynamicRuleInstances = dict + , dynamicDeps = DynDepsCmd{dynDepsCmd = depsCmd} + , dynamicRuleCommand = action + } + , staticDependencies = dep + , results = res + } + +----------------------- +-- Rule inputs/outputs + +-- | A (fully resolved) location of a dependency or result of a rule, +-- 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 )@, +-- 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) + +-- 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 +-- dependencies on other generated files (notably @c2hs@, where building one +-- @.hs@ file may require reading other @.chi@ files, and then compiling the +-- @.hs@ file may require reading a generated @.h@ file). +-- In these cases, the generated files need to embed relative path names to each +-- other (eg the generated @.hs@ file mentions the @.h@ file in the FFI imports). +-- This path must be relative to the base directory where the generated files +-- are located; it cannot be relative to the top level of the build tree because +-- the compilers do not look for @.h@ files relative to there, ie we do not use +-- @-I .@, instead we use @-I dist/build@ (or whatever dist dir has been set +-- by the user). + +-- | A dependency of a rule. +data Dependency + = -- | A dependency on an output of another rule. + RuleDependency !RuleOutput + | -- | A direct dependency on a file at a particular location on disk. + -- + -- This should not be used for files that are generated by other rules; + -- use 'RuleDependency' instead. + FileDependency !Location + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (Binary, Structured) + +-- | A reference to an output of another rule. +data RuleOutput = RuleOutput + { outputOfRule :: !RuleId + -- ^ which rule's outputs are we referring to? + , outputIndex :: !Word + -- ^ which particular output of that rule? + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (Binary, Structured) + +--------- +-- Rules + +-- | Monad for constructing rules. +type RulesM a = RulesT IO a + +-- | The environment within the monadic API. +data RulesEnv = RulesEnv + { rulesEnvVerbosity :: !Verbosity + , rulesEnvUnitId :: !UnitId + } + +-- | Monad transformer for defining rules. Usually wraps the 'IO' monad, +-- allowing @IO@ actions to be performed using @liftIO@. +newtype RulesT m a = RulesT + { runRulesT + :: Reader.ReaderT + RulesEnv + ( State.StateT + (Map RuleId Rule) + (Writer.WriterT [MonitorFilePath] m) + ) + a + } + deriving newtype (Functor, Applicative, Monad, MonadIO, MonadFix) + +instance MonadTrans RulesT where + lift = RulesT . lift . lift . lift + +-- | A collection of t'Rule's. +-- +-- Use the 'rules' smart constructor instead of directly using the v'Rules' +-- constructor. +-- +-- - Rules are registered using 'registerRule', +-- - Monitored files or directories are declared using 'addRuleMonitors'; +-- a change in these will trigger the recomputation of all rules. +-- +-- The @env@ type parameter represents an extra argument, which usually +-- consists of information known to Cabal such as 'LocalBuildInfo' and +-- 'ComponentLocalBuildInfo'. +newtype Rules env = Rules {runRules :: env -> RulesM ()} + +-- | __Warning__: this 'Semigroup' instance is not commutative. +instance Semigroup (Rules env) where + (Rules rs1) <> (Rules rs2) = + Rules $ \inputs -> do + y1 <- rs1 inputs + y2 <- rs2 inputs + return $ y1 <> y2 + +instance Monoid (Rules env) where + mempty = Rules $ const noRules + +-- | An empty collection of rules. +noRules :: RulesM () +noRules = return () + +-- | Construct a collection of rules. +-- +-- Usage: +-- +-- > myRules :: Rules env +-- > myRules = rules $ static f +-- > where +-- > f :: env -> RulesM () +-- > f env = do { ... } -- use the monadic API here +rules + :: StaticPtr (env -> RulesM ()) + -- ^ a static computation of rules + -> Rules env +rules f = Rules $ \env -> RulesT $ do + Reader.withReaderT (\rulesEnv -> rulesEnv{rulesEnvUnitId = unitId}) $ + runRulesT $ + deRefStaticPtr f env + where + unitId = mkUnitId $ spInfoUnitId $ staticPtrInfo f + +-- | Internal function: run the monadic 'Rules' computations in order +-- to obtain all the 'Rule's with their 'RuleId's. +computeRules + :: Verbosity + -> env + -> Rules env + -> IO (Map RuleId Rule, [MonitorFilePath]) +computeRules verbosity inputs (Rules rs) = do + -- Bogus UnitId to start with. This will be the first thing + -- to be set when users use the 'rules' smart constructor. + let noUnitId = mkUnitId "" + env0 = + RulesEnv + { rulesEnvVerbosity = verbosity + , rulesEnvUnitId = noUnitId + } + Writer.runWriterT $ + (`State.execStateT` Map.empty) $ + (`Reader.runReaderT` env0) $ + runRulesT $ + rs inputs + +------------ +-- Commands + +-- | A command consists of a statically-known action together with a +-- (possibly dynamic) argument to that action. +-- +-- For example, the action can consist of running an executable +-- (such as @happy@ or @c2hs@), while the argument consists of the variable +-- component of the command, e.g. the specific file to run @happy@ on. +data Command arg res = Command + { actionPtr :: !(StaticPtr (arg -> res)) + -- ^ The (statically-known) action to execute. + , actionArg :: !arg + -- ^ The (possibly dynamic) argument to pass to the action. + , cmdInstances :: !(StaticPtr (Dict (Binary arg, Show arg))) + -- ^ Static evidence that the argument can be serialised and deserialised. + } + +-- | Construct a command. +-- +-- Prefer using this smart constructor instead of v'Command' whenever possible. +mkCommand + :: forall arg res + . StaticPtr (Dict (Binary arg, Show arg)) + -> StaticPtr (arg -> res) + -> arg + -> Command arg res +mkCommand dict actionPtr arg = + Command + { actionPtr = actionPtr + , actionArg = arg + , cmdInstances = dict + } + +-- | Run a 'Command'. +runCommand :: Command args res -> res +runCommand (Command{actionPtr = ptr, actionArg = arg}) = + deRefStaticPtr ptr arg + +-- | Commands to execute a rule: +-- +-- - for a rule with static dependencies, a single command, +-- - for a rule with dynamic dependencies, a command for computing dynamic +-- dependencies, and a command for executing the rule. +data + RuleCommands + (deps :: Hs.Type -> Hs.Type -> Hs.Type) + (ruleCmd :: Hs.Type -> Hs.Type -> Hs.Type) + where + -- | A rule with statically-known dependencies. + StaticRuleCommand + :: forall arg deps ruleCmd + . Typeable arg + => { staticRuleCommand :: !(ruleCmd arg (IO ())) + -- ^ The command to execute the rule. + } + -> RuleCommands deps ruleCmd + DynamicRuleCommands + :: forall depsArg depsRes arg deps ruleCmd + . (Typeable depsArg, Typeable depsRes, Typeable arg) + => { dynamicRuleInstances :: !(StaticPtr (Dict (Binary depsRes, Show depsRes, Eq depsRes))) + -- ^ A rule with dynamic dependencies, which consists of two parts: + -- + -- - a dynamic dependency computation, that returns additional edges to + -- be added to the build graph together with an additional piece of data, + -- - the command to execute the rule itself, which receives the additional + -- piece of data returned by the dependency computation. + , -- \^ Static evidence used for serialisation, in order to pass the result + -- of the dependency computation to the main rule action. + dynamicDeps :: !(deps depsArg depsRes) + -- ^ A dynamic dependency computation. The resulting dependencies + -- will be injected into the build graph, and the result of the computation + -- will be passed on to the command that executes the rule. + , dynamicRuleCommand :: !(ruleCmd arg (depsRes -> IO ())) + -- ^ The command to execute the rule. It will receive the result + -- of the dynamic dependency computation. + } + -> RuleCommands deps ruleCmd + +-- | A placeholder for a command that has been omitted, e.g. when we don't +-- care about serialising/deserialising one particular command in a datatype. +data NoCmd arg res = CmdOmitted + deriving stock (Generic, Eq, Ord, Show) + deriving anyclass (Binary) + +-- | A dynamic dependency command. +newtype DynDepsCmd depsArg depsRes = DynDepsCmd {dynDepsCmd :: Command depsArg (IO ([Dependency], depsRes))} + deriving newtype (Show, Eq, Binary) + +-- | The result of a dynamic dependency computation. +newtype DepsRes depsArg depsRes = DepsRes {depsRes :: depsRes} + deriving newtype (Show, Eq, Binary) + +-- | Both the rule command and the (optional) dynamic dependency command. +type RuleCmds = RuleCommands DynDepsCmd Command + +-- | Only the (optional) dynamic dependency command. +type RuleDynDepsCmd = RuleCommands DynDepsCmd NoCmd + +-- | The rule command together with the result of the (optional) dynamic +-- dependency computation. +type RuleExecCmd = RuleCommands DepsRes Command + +-- | Project out the (optional) dependency computation command, so that +-- it can be serialised without serialising anything else. +ruleDepsCmd :: RuleCmds -> RuleDynDepsCmd +ruleDepsCmd = \case + StaticRuleCommand{staticRuleCommand = _ :: Command args (IO ())} -> + StaticRuleCommand{staticRuleCommand = CmdOmitted :: NoCmd args (IO ())} + DynamicRuleCommands + { dynamicRuleCommand = _ :: Command args (depsRes -> IO ()) + , dynamicRuleInstances = instsPtr + , dynamicDeps = deps + } -> + DynamicRuleCommands + { dynamicRuleInstances = instsPtr + , dynamicDeps = deps + , dynamicRuleCommand = CmdOmitted :: NoCmd args (depsRes -> IO ()) + } + +-- | Obtain the (optional) 'IO' action that computes dynamic dependencies. +runRuleDynDepsCmd :: RuleDynDepsCmd -> Maybe (IO ([Dependency], LBS.ByteString)) +runRuleDynDepsCmd = \case + StaticRuleCommand{} -> Nothing + DynamicRuleCommands + { dynamicRuleInstances = instsPtr + , dynamicDeps = DynDepsCmd{dynDepsCmd = depsCmd} + } + | Dict <- deRefStaticPtr instsPtr -> + Just $ do + (deps, depsRes) <- runCommand depsCmd + return $ (deps, Binary.encode depsRes) + +-- | Project out the command for running the rule, passing in the result of +-- the dependency computation if there was one. +ruleExecCmd :: RuleCmds -> Maybe LBS.ByteString -> RuleExecCmd +ruleExecCmd (StaticRuleCommand{staticRuleCommand = cmd}) _ = + StaticRuleCommand{staticRuleCommand = cmd} +ruleExecCmd + ( DynamicRuleCommands + { dynamicRuleInstances = instsPtr + , dynamicRuleCommand = cmd :: Command arg (depsRes -> IO ()) + , dynamicDeps = _ :: DynDepsCmd depsArg depsRes + } + ) + mbDepsResBinary = + case mbDepsResBinary of + Nothing -> + error $ + unlines + [ "Missing ByteString argument in 'ruleExecCmd'." + , "Run 'runRuleDynDepsCmd' on the rule to obtain this data." + ] + Just depsResBinary + | Dict <- deRefStaticPtr instsPtr -> + DynamicRuleCommands + { dynamicRuleInstances = instsPtr + , dynamicRuleCommand = cmd + , dynamicDeps = DepsRes (Binary.decode depsResBinary) :: DepsRes depsArg depsRes + } + +-- | Obtain the 'IO' action that executes a rule. +runRuleExecCmd :: RuleExecCmd -> IO () +runRuleExecCmd = \case + StaticRuleCommand{staticRuleCommand = cmd} -> runCommand cmd + DynamicRuleCommands{dynamicDeps = DepsRes res, dynamicRuleCommand = cmd} -> + runCommand cmd res + +-------------------------------------------------------------------------------- +-- Instances + +-- | A wrapper used to pass evidence of a constraint as an explicit value. +data Dict c where + Dict :: c => Dict c + +instance Show (Command arg res) where + showsPrec prec (Command{actionPtr = cmdPtr, actionArg = arg, cmdInstances = insts}) + | Dict <- deRefStaticPtr insts = + showParen (prec >= 11) $ + showString "Command {" + . showString "actionPtrKey = " + . shows (staticKey cmdPtr) + . showCommaSpace + . showString "actionArg = " + . shows arg + . showString "}" + +instance Eq (Command arg res) where + Command{actionPtr = cmdPtr1, actionArg = arg1, cmdInstances = insts1} + == Command{actionPtr = cmdPtr2, actionArg = arg2, cmdInstances = insts2} + | staticKey cmdPtr1 == staticKey cmdPtr2 + , staticKey insts1 == staticKey insts2 + , Dict <- deRefStaticPtr insts1 = + Binary.encode arg1 == Binary.encode arg2 + | otherwise = + False + +instance Binary (Command arg res) where + put (Command{actionPtr = cmdPtr, actionArg = arg, cmdInstances = insts}) + | Dict <- deRefStaticPtr insts = + do + put (staticKey cmdPtr) + put (staticKey insts) + put arg + get = do + cmdKey <- get @StaticKey + instsKey <- get @StaticKey + case unsafePerformIO $ unsafeLookupStaticPtr cmdKey of + Just cmdPtr + | Just instsPtr <- unsafePerformIO $ unsafeLookupStaticPtr instsKey + , Dict <- deRefStaticPtr @(Dict (Binary arg, Show arg)) instsPtr -> + do + arg <- get + return $ Command{actionPtr = cmdPtr, actionArg = arg, cmdInstances = instsPtr} + _ -> error "failed to look up static pointer key for action" + +instance + ( forall arg res. Show (ruleCmd arg res) + , forall depsArg depsRes. Show depsRes => Show (deps depsArg depsRes) + ) + => Show (RuleCommands deps ruleCmd) + where + showsPrec prec (StaticRuleCommand{staticRuleCommand = cmd}) = + showParen (prec >= 11) $ + showString "StaticRuleCommand {" + . showString "staticRuleCommand = " + . shows cmd + . showString "}" + showsPrec + prec + ( DynamicRuleCommands + { dynamicDeps = deps + , dynamicRuleCommand = cmd + , dynamicRuleInstances = instsPtr + } + ) + | Dict <- deRefStaticPtr instsPtr = + showParen (prec >= 11) $ + showString "DynamicRuleCommands {" + . showString "dynamicDeps = " + . shows deps + . showCommaSpace + . showString "dynamicRuleCommand = " + . shows cmd + . showString "}" + +instance + ( forall arg res. Eq (ruleCmd arg res) + , forall depsArg depsRes. Eq depsRes => Eq (deps depsArg depsRes) + ) + => Eq (RuleCommands deps ruleCmd) + where + StaticRuleCommand{staticRuleCommand = ruleCmd1 :: ruleCmd arg1 (IO ())} + == StaticRuleCommand{staticRuleCommand = ruleCmd2 :: ruleCmd arg2 (IO ())} + | Just Refl <- eqT @arg1 @arg2 = + ruleCmd1 == ruleCmd2 + DynamicRuleCommands + { dynamicDeps = depsCmd1 :: deps depsArg1 depsRes1 + , dynamicRuleCommand = ruleCmd1 :: ruleCmd arg1 (depsRes1 -> IO ()) + , dynamicRuleInstances = instsPtr1 + } + == DynamicRuleCommands + { dynamicDeps = depsCmd2 :: deps depsArg2 depsRes2 + , dynamicRuleCommand = ruleCmd2 :: ruleCmd arg2 (depsRes2 -> IO ()) + , dynamicRuleInstances = instsPtr2 + } + | Just Refl <- eqT @depsArg1 @depsArg2 + , Just Refl <- eqT @depsRes1 @depsRes2 + , Just Refl <- eqT @arg1 @arg2 + , Dict <- deRefStaticPtr instsPtr1 = + depsCmd1 == depsCmd2 + && ruleCmd1 == ruleCmd2 + && staticKey instsPtr1 == staticKey instsPtr2 + _ == _ = False + +instance + ( forall arg res. Binary (ruleCmd arg res) + , forall depsArg depsRes. Binary depsRes => Binary (deps depsArg depsRes) + ) + => Binary (RuleCommands deps ruleCmd) + where + put = \case + StaticRuleCommand{staticRuleCommand = ruleCmd :: ruleCmd arg (IO ())} -> do + put @Word 0 + put $ Typeable.SomeTypeRep (Typeable.typeRep @arg) + put ruleCmd + DynamicRuleCommands + { dynamicDeps = deps :: deps depsArg depsRes + , dynamicRuleCommand = ruleCmd :: ruleCmd arg (depsRes -> IO ()) + , dynamicRuleInstances = instsPtr + } | Dict <- deRefStaticPtr instsPtr -> + do + put @Word 1 + put $ Typeable.SomeTypeRep (Typeable.typeRep @depsArg) + put $ Typeable.SomeTypeRep (Typeable.typeRep @depsRes) + put $ Typeable.SomeTypeRep (Typeable.typeRep @arg) + put $ staticKey instsPtr + put ruleCmd + put deps + get = do + tag <- get @Word + case tag of + 0 -> do + Typeable.SomeTypeRep (trArg :: Typeable.TypeRep arg) <- get + if + | Just HRefl <- Typeable.eqTypeRep (Typeable.typeRepKind trArg) (Typeable.typeRep @Hs.Type) -> + do + ruleCmd <- get @(ruleCmd arg (IO ())) + return $ + Typeable.withTypeable trArg $ + StaticRuleCommand + { staticRuleCommand = ruleCmd + } + | otherwise -> + error "internal error when decoding static rule command" + _ -> do + Typeable.SomeTypeRep (trDepsArg :: Typeable.TypeRep depsArg) <- get + Typeable.SomeTypeRep (trDepsRes :: Typeable.TypeRep depsRes) <- get + Typeable.SomeTypeRep (trArg :: Typeable.TypeRep arg) <- get + instsKey <- get @StaticKey + if + | Just HRefl <- Typeable.eqTypeRep (Typeable.typeRepKind trDepsArg) (Typeable.typeRep @Hs.Type) + , Just HRefl <- Typeable.eqTypeRep (Typeable.typeRepKind trDepsRes) (Typeable.typeRep @Hs.Type) + , Just HRefl <- Typeable.eqTypeRep (Typeable.typeRepKind trArg) (Typeable.typeRep @Hs.Type) + , Just instsPtr <- unsafePerformIO $ unsafeLookupStaticPtr instsKey + , Dict :: Dict (Binary depsRes, Show depsRes, Eq depsRes) <- + deRefStaticPtr instsPtr -> + do + ruleCmd <- get @(ruleCmd arg (depsRes -> IO ())) + deps <- get @(deps depsArg depsRes) + return $ + Typeable.withTypeable trDepsArg $ + Typeable.withTypeable trDepsRes $ + Typeable.withTypeable trArg $ + DynamicRuleCommands + { dynamicDeps = deps + , dynamicRuleCommand = ruleCmd + , dynamicRuleInstances = instsPtr + } + | otherwise -> + error "internal error when decoding dynamic rule commands" diff --git a/cabal-install/src/Distribution/Client/FileMonitor.hs b/cabal-install/src/Distribution/Client/FileMonitor.hs index 084545d5e..59742cc1b 100644 --- a/cabal-install/src/Distribution/Client/FileMonitor.hs +++ b/cabal-install/src/Distribution/Client/FileMonitor.hs @@ -11,22 +11,7 @@ -- input values they depend on have changed. module Distribution.Client.FileMonitor ( -- * Declaring files to monitor - MonitorFilePath (..) - , MonitorKindFile (..) - , MonitorKindDir (..) - , RootedGlob (..) - , monitorFile - , monitorFileHashed - , monitorNonExistentFile - , monitorFileExistence - , monitorDirectory - , monitorNonExistentDirectory - , monitorDirectoryExistence - , monitorFileOrDirectory - , monitorFileGlob - , monitorFileGlobExistence - , monitorFileSearchPath - , monitorFileHashedSearchPath + module Distribution.Simple.FileMonitor.Types -- * Creating and checking sets of monitored files , FileMonitor (..) @@ -68,131 +53,15 @@ import Control.Monad.Trans (MonadIO, liftIO) import Distribution.Client.Glob import Distribution.Client.Utils (MergeResult (..), mergeBy) import Distribution.Compat.Time +import Distribution.Simple.FileMonitor.Types import Distribution.Simple.Utils (handleDoesNotExist, writeFileAtomic) import Distribution.Utils.Structured (Tag (..), structuredEncode) + import System.Directory import System.FilePath import System.IO ------------------------------------------------------------------------------ --- Types for specifying files to monitor --- - --- | A description of a file (or set of files) to monitor for changes. --- --- Where file paths are relative they are relative to a common directory --- (e.g. project root), not necessarily the process current directory. -data MonitorFilePath - = MonitorFile - { monitorKindFile :: !MonitorKindFile - , monitorKindDir :: !MonitorKindDir - , monitorPath :: !FilePath - } - | MonitorFileGlob - { monitorKindFile :: !MonitorKindFile - , monitorKindDir :: !MonitorKindDir - , monitorPathGlob :: !RootedGlob - } - deriving (Eq, Show, Generic) - -data MonitorKindFile - = FileExists - | FileModTime - | FileHashed - | FileNotExists - deriving (Eq, Show, Generic) - -data MonitorKindDir - = DirExists - | DirModTime - | DirNotExists - deriving (Eq, Show, Generic) - -instance Binary MonitorFilePath -instance Binary MonitorKindFile -instance Binary MonitorKindDir - -instance Structured MonitorFilePath -instance Structured MonitorKindFile -instance Structured MonitorKindDir - --- | Monitor a single file for changes, based on its modification time. --- The monitored file is considered to have changed if it no longer --- exists or if its modification time has changed. -monitorFile :: FilePath -> MonitorFilePath -monitorFile = MonitorFile FileModTime DirNotExists - --- | Monitor a single file for changes, based on its modification time --- and content hash. The monitored file is considered to have changed if --- it no longer exists or if its modification time and content hash have --- changed. -monitorFileHashed :: FilePath -> MonitorFilePath -monitorFileHashed = MonitorFile FileHashed DirNotExists - --- | Monitor a single non-existent file for changes. The monitored file --- is considered to have changed if it exists. -monitorNonExistentFile :: FilePath -> MonitorFilePath -monitorNonExistentFile = MonitorFile FileNotExists DirNotExists - --- | Monitor a single file for existence only. The monitored file is --- considered to have changed if it no longer exists. -monitorFileExistence :: FilePath -> MonitorFilePath -monitorFileExistence = MonitorFile FileExists DirNotExists - --- | Monitor a single directory for changes, based on its modification --- time. The monitored directory is considered to have changed if it no --- longer exists or if its modification time has changed. -monitorDirectory :: FilePath -> MonitorFilePath -monitorDirectory = MonitorFile FileNotExists DirModTime - --- | Monitor a single non-existent directory for changes. The monitored --- directory is considered to have changed if it exists. -monitorNonExistentDirectory :: FilePath -> MonitorFilePath --- Just an alias for monitorNonExistentFile, since you can't --- tell the difference between a non-existent directory and --- a non-existent file :) -monitorNonExistentDirectory = monitorNonExistentFile - --- | Monitor a single directory for existence. The monitored directory is --- considered to have changed only if it no longer exists. -monitorDirectoryExistence :: FilePath -> MonitorFilePath -monitorDirectoryExistence = MonitorFile FileNotExists DirExists - --- | Monitor a single file or directory for changes, based on its modification --- time. The monitored file is considered to have changed if it no longer --- exists or if its modification time has changed. -monitorFileOrDirectory :: FilePath -> MonitorFilePath -monitorFileOrDirectory = MonitorFile FileModTime DirModTime - --- | Monitor a set of files (or directories) identified by a file glob. --- The monitored glob is considered to have changed if the set of files --- matching the glob changes (i.e. creations or deletions), or for files if the --- modification time and content hash of any matching file has changed. -monitorFileGlob :: RootedGlob -> MonitorFilePath -monitorFileGlob = MonitorFileGlob FileHashed DirExists - --- | Monitor a set of files (or directories) identified by a file glob for --- existence only. The monitored glob is considered to have changed if the set --- of files matching the glob changes (i.e. creations or deletions). -monitorFileGlobExistence :: RootedGlob -> MonitorFilePath -monitorFileGlobExistence = MonitorFileGlob FileExists DirExists - --- | Creates a list of files to monitor when you search for a file which --- unsuccessfully looked in @notFoundAtPaths@ before finding it at --- @foundAtPath@. -monitorFileSearchPath :: [FilePath] -> FilePath -> [MonitorFilePath] -monitorFileSearchPath notFoundAtPaths foundAtPath = - monitorFile foundAtPath - : map monitorNonExistentFile notFoundAtPaths - --- | Similar to 'monitorFileSearchPath', but also instructs us to --- monitor the hash of the found file. -monitorFileHashedSearchPath :: [FilePath] -> FilePath -> [MonitorFilePath] -monitorFileHashedSearchPath notFoundAtPaths foundAtPath = - monitorFileHashed foundAtPath - : map monitorNonExistentFile notFoundAtPaths - ------------------------------------------------------------------------------- -- Implementation types, files status -- diff --git a/cabal-install/src/Distribution/Client/Glob.hs b/cabal-install/src/Distribution/Client/Glob.hs index 90054a8f6..6aa2da0c2 100644 --- a/cabal-install/src/Distribution/Client/Glob.hs +++ b/cabal-install/src/Distribution/Client/Glob.hs @@ -12,48 +12,25 @@ module Distribution.Client.Glob , Glob (..) , GlobPiece (..) , GlobPieces - , matchGlob - , matchGlobPieces , matchFileGlob ) where import Distribution.Client.Compat.Prelude import Prelude () +import Distribution.Simple.FileMonitor.Types import Distribution.Simple.Glob import Distribution.Simple.Glob.Internal + ( Glob (..) + , GlobPiece (..) + , GlobPieces + ) import System.Directory import System.FilePath -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -------------------------------------------------------------------------------- --- | A file path specified by globbing, relative --- to some root directory. -data RootedGlob - = RootedGlob - FilePathRoot - -- ^ what the glob is relative to - Glob - -- ^ the glob - deriving (Eq, Show, Generic) - -instance Binary RootedGlob -instance Structured RootedGlob - -data FilePathRoot - = FilePathRelative - | -- | e.g. @"/"@, @"c:\"@ or result of 'takeDrive' - FilePathRoot FilePath - | FilePathHomeDir - deriving (Eq, Show, Generic) - -instance Binary FilePathRoot -instance Structured FilePathRoot - -- | Check if a 'RootedGlob' doesn't actually make use of any globbing and -- is in fact equivalent to a non-glob 'FilePath'. -- @@ -105,33 +82,3 @@ matchFileGlob relroot (RootedGlob globroot glob) = do case globroot of FilePathRelative -> return matches _ -> return (map (root ) matches) - ------------------------------------------------------------------------------- --- Parsing & pretty-printing --- - -instance Pretty RootedGlob where - pretty (RootedGlob root pathglob) = pretty root Disp.<> pretty pathglob - -instance Parsec RootedGlob where - parsec = do - root <- parsec - case root of - FilePathRelative -> RootedGlob root <$> parsec - _ -> RootedGlob root <$> parsec <|> pure (RootedGlob root GlobDirTrailing) - -instance Pretty FilePathRoot where - pretty FilePathRelative = Disp.empty - pretty (FilePathRoot root) = Disp.text root - pretty FilePathHomeDir = Disp.char '~' Disp.<> Disp.char '/' - -instance Parsec FilePathRoot where - parsec = root <|> P.try home <|> P.try drive <|> pure FilePathRelative - where - root = FilePathRoot "/" <$ P.char '/' - home = FilePathHomeDir <$ P.string "~/" - drive = do - dr <- P.satisfy $ \c -> (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') - _ <- P.char ':' - _ <- P.char '/' <|> P.char '\\' - return (FilePathRoot (toUpper dr : ":\\")) -- 2.11.4.GIT