{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
-- |
-- Copyright: (c) 2023 Bodigrim
-- License: BSD-3-Clause
module Main (main) where
import Cabal.Project (parseProject, prjPackages, resolveProject)
import Control.Exception (throwIO)
import Control.Monad (filterM)
import Data.Bifunctor (bimap)
import Data.ByteString (ByteString)
import Data.ByteString.Char8 qualified as B
import Data.Either (partitionEithers)
import Data.List qualified as L
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe (catMaybes, isJust)
import Distribution.CabalSpecVersion (CabalSpecVersion)
import Distribution.Client.Add
import Distribution.PackageDescription (
ComponentName,
GenericPackageDescription,
packageDescription,
specVersion,
)
import Distribution.PackageDescription.Quirks (patchQuirks)
import Options.Applicative (
Parser,
execParser,
fullDesc,
help,
helper,
info,
long,
metavar,
optional,
progDesc,
strArgument,
strOption,
)
import Options.Applicative.NonEmpty (some1)
import System.Directory (doesFileExist, listDirectory)
import System.Environment (getArgs, lookupEnv, withArgs)
import System.Exit (die)
import System.FilePath (takeDirectory, (</>))
data RawConfig = RawConfig
{ rcnfMProjectFile :: !(Maybe FilePath)
, rcnfArgs :: !(NonEmpty String)
}
deriving (Show)
parseRawConfig :: Parser RawConfig
parseRawConfig = do
rcnfMProjectFile <-
optional $
strOption $
long "project-file"
<> metavar "FILE"
<> help "Set the path of the cabal.project file. Detect cabal.project or *.cabal in the current folder, if omitted."
rcnfArgs <-
some1 $
strArgument $
metavar "ARGS"
<> help "Optional package component (wildcards such as 'exe', 'test' or 'bench' are supported) to update, followed by a non-empty list of package(s) to add to 'build-depends' section. Version bounds can be provided as well, use quotes to escape comparisons from your shell. E. g., 'foo < 0.2'."
pure RawConfig {..}
resolveCabalProjectInCurrentFolder :: IO (Maybe FilePath)
resolveCabalProjectInCurrentFolder = do
let fn = "cabal.project"
exists <- doesFileExist fn
pure $ if exists then Just fn else Nothing
resolveCabalFileInCurrentFolder :: IO (Either String FilePath)
resolveCabalFileInCurrentFolder = do
files <- listDirectory "."
-- filter in two steps to reduce IO
let cabalFiles' = filter (".cabal" `L.isSuffixOf`) files
-- make sure we don't catch directories
cabalFiles <- filterM doesFileExist cabalFiles'
pure $ case cabalFiles of
[] ->
Left "Found no cabal files in current folder. Giving up."
[fn] ->
Right fn
_ : _ : _ ->
Left "Found multiple cabal files in current folder. Giving up."
extractCabalFilesFromProject :: FilePath -> IO [FilePath]
extractCabalFilesFromProject projectFn = do
project <- B.readFile projectFn
parsed <- case parseProject projectFn project of
Left exc -> throwIO exc
Right p -> pure p
resolved <- resolveProject projectFn parsed
case resolved of
Left exc -> throwIO exc
Right prj -> pure $ map (takeDirectory projectFn </>) $ prjPackages prj
resolveCabalFiles :: Maybe FilePath -> IO [FilePath]
resolveCabalFiles = \case
Nothing -> do
projectFn <- resolveCabalProjectInCurrentFolder
case projectFn of
Nothing -> do
cabalFn <- resolveCabalFileInCurrentFolder
case cabalFn of
Left e -> die e
Right fn -> pure [fn]
Just fn -> extractCabalFilesFromProject fn
Just fn -> extractCabalFilesFromProject fn
readCabalFile :: FilePath -> IO (Maybe ByteString)
readCabalFile fileName = do
cabalFileExists <- doesFileExist fileName
if cabalFileExists
then Just . snd . patchQuirks <$> B.readFile fileName
else pure Nothing
stripAdd :: [String] -> [String]
stripAdd ("add" : xs) = xs
stripAdd xs = xs
data Input = Input
{ inpFilePath :: FilePath
, inpPackageDescription :: GenericPackageDescription
, inpConfig :: AddConfig
}
deriving (Show)
mkInputs
:: Bool
-- ^ Must the first argument be a component name?
-- As opposed to interpreting it as one of dependencies to add.
-> FilePath
-- ^ Cabal file name, primarily for error reporting.
-- Note that 'mkInputs' does not do any 'IO'.
-> ByteString
-- ^ Cabal file content.
-> NonEmpty String
-- ^ List of arguments. The first one is either a component name
-- or a dependency (see 'Bool' flag above), the rest are dependencies.
-> Either String Input
-- ^ Either an error or a tuple of input data.
mkInputs isCmpRequired cabalFile origContents args = do
(fields, packDescr) <- parseCabalFile cabalFile origContents
let specVer :: CabalSpecVersion
specVer = specVersion $ packageDescription packDescr
mkCmp :: Maybe String -> Either String (Either CommonStanza ComponentName)
mkCmp = resolveComponent cabalFile (fields, packDescr)
mkDeps :: NonEmpty String -> Either String (NonEmpty ByteString)
mkDeps = traverse (validateDependency specVer)
(cmp, deps) <- case args of
x :| (y : ys)
| Right c <- mkCmp (Just x) ->
(c,) <$> mkDeps (y :| ys)
| isCmpRequired -> Left $ "Target component '" ++ x ++ "' is not found"
_ ->
if isCmpRequired
then Left "Target component is required"
else (,) <$> mkCmp Nothing <*> mkDeps args
pure $
Input
cabalFile
packDescr
AddConfig
{ cnfOrigContents = origContents
, cnfFields = fields
, cnfComponent = cmp
, cnfTargetField = BuildDepends
, cnfAdditions = deps
}
disambiguateInputs
:: Maybe FilePath
-> [(FilePath, Either String Input)]
-> Either String Input
disambiguateInputs mProjectFile inputs = case inputs' of
([], []) -> Left $ case mProjectFile of
Nothing -> "No Cabal files or projects are found in the current folder, please specify --project-file."
Just projFn -> "No Cabal files are found in " ++ projFn
(errs, []) ->
Left $
L.intercalate "\n" $
map (\(fn, err) -> "Cannot add a dependency to " ++ fn ++ " because: " ++ err) errs
(_, [inp]) -> pure $ snd inp
(_, _inps) ->
Left
"Cannot add a dependency, because target component is ambiguous. Please specify it as package:type:component. See https://cabal.readthedocs.io/en/latest/cabal-commands.html#target-forms for reference"
where
inputs' = partitionEithers $ map (\(fn, e) -> bimap (fn,) (fn,) e) inputs
main :: IO ()
main = do
isCabalEnvVarSet <- isJust <$> lookupEnv "CABAL"
rawArgs <- getArgs
RawConfig {..} <-
withArgs ((if isCabalEnvVarSet then stripAdd else id) rawArgs) $
execParser $
info
(helper <*> parseRawConfig)
(fullDesc <> progDesc "Extend build-depends from the command line")
cabalFiles <- resolveCabalFiles rcnfMProjectFile
cabalFilesAndContent <-
catMaybes
<$> traverse (\fn -> fmap (fn,) <$> readCabalFile fn) cabalFiles
let getInput isCmpRequired =
disambiguateInputs rcnfMProjectFile $
map
(\(fn, cnt) -> (fn, mkInputs isCmpRequired fn cnt rcnfArgs))
cabalFilesAndContent
input <- case getInput False of
Right i -> pure i
Left errFalse -> case rcnfArgs of
_ :| [] -> die errFalse
_ -> case getInput True of
Right i -> pure i
Left errTrue ->
die $
"If the first argument is interpreted as a dependency:\n"
++ errFalse
++ "\n\nIf the first argument is interpreted as a target component:\n"
++ errTrue
let Input cabalFile origPackDescr cnf = input
case executeAddConfig (validateChanges origPackDescr) cnf of
Nothing ->
die $
"Cannot extend build-depends in "
++ cabalFile
++ ", please report as a bug at https://github.com/Bodigrim/cabal-add/issues"
Just r -> B.writeFile cabalFile r