{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

-- | Utilities to help commands with scripts
--
module Distribution.Client.ScriptUtils (
    getScriptHash, getScriptCacheDirectory, ensureScriptCacheDirectory,
    withContextAndSelectors, AcceptNoTargets(..), TargetContext(..),
    updateContextAndWriteProjectFile, updateContextAndWriteProjectFile',
    fakeProjectSourcePackage, lSrcpkgDescription
  ) where

import Prelude ()
import Distribution.Client.Compat.Prelude hiding (toList)

import Distribution.Compat.Lens
import qualified Distribution.Types.Lens as L

import Distribution.CabalSpecVersion
    ( CabalSpecVersion (..), cabalSpecLatest)
import Distribution.Client.ProjectOrchestration
import Distribution.Client.Config
    ( defaultScriptBuildsDir )
import Distribution.Client.DistDirLayout
    ( DistDirLayout(..) )
import Distribution.Client.HashValue
    ( hashValue, showHashValue )
import Distribution.Client.HttpUtils
         ( HttpTransport, configureTransport )
import Distribution.Client.NixStyleOptions
    ( NixStyleFlags (..) )
import Distribution.Client.ProjectConfig
    ( ProjectConfig(..), ProjectConfigShared(..)
    , reportParseResult, withProjectOrGlobalConfig
    , projectConfigHttpTransport )
import Distribution.Client.ProjectConfig.Legacy
    ( ProjectConfigSkeleton
    , parseProjectSkeleton, instantiateProjectConfigSkeletonFetchingCompiler )
import Distribution.Client.ProjectFlags
    ( flagIgnoreProject )
import Distribution.Client.RebuildMonad
    ( runRebuild )
import Distribution.Client.Setup
    ( ConfigFlags(..), GlobalFlags(..) )
import Distribution.Client.TargetSelector
    ( TargetSelectorProblem(..), TargetString(..) )
import Distribution.Client.Types
    ( PackageLocation(..), PackageSpecifier(..), UnresolvedSourcePackage )
import Distribution.FieldGrammar
    ( parseFieldGrammar, takeFields )
import Distribution.Fields
    ( ParseResult, parseFatalFailure, readFields )
import Distribution.PackageDescription
    ( ignoreConditions )
import Distribution.PackageDescription.FieldGrammar
    ( executableFieldGrammar )
import Distribution.PackageDescription.PrettyPrint
    ( showGenericPackageDescription )
import Distribution.Parsec
    ( Position(..) )
import Distribution.Simple.Flag
    ( fromFlagOrDefault, flagToMaybe )
import Distribution.Simple.PackageDescription
    ( parseString )
import Distribution.Simple.Setup
    ( Flag(..) )
import Distribution.Simple.Compiler
    ( compilerInfo )
import Distribution.Simple.Utils
    ( createDirectoryIfMissingVerbose, createTempDirectory, die', handleDoesNotExist, readUTF8File, warn, writeUTF8File )
import qualified Distribution.SPDX.License as SPDX
import Distribution.Solver.Types.SourcePackage as SP
    ( SourcePackage(..) )
import Distribution.System
    ( Platform(..) )
import Distribution.Types.BuildInfo
    ( BuildInfo(..) )
import Distribution.Types.CondTree
    ( CondTree(..) )
import Distribution.Types.Executable
    ( Executable(..) )
import Distribution.Types.GenericPackageDescription as GPD
    ( GenericPackageDescription(..), emptyGenericPackageDescription )
import Distribution.Types.PackageDescription
    ( PackageDescription(..), emptyPackageDescription )
import Distribution.Types.PackageName.Magic
    ( fakePackageCabalFileName, fakePackageId )
import Distribution.Utils.NubList
    ( fromNubList )
import Distribution.Client.ProjectPlanning
    ( configureCompiler )
import Distribution.Verbosity
    ( normal )
import Language.Haskell.Extension
    ( Language(..) )

import Control.Concurrent.MVar
    ( newEmptyMVar, putMVar, tryTakeMVar )
import Control.Exception
    ( bracket )
import qualified Data.ByteString.Char8 as BS
import Data.ByteString.Lazy ()
import qualified Data.Set as S
import System.Directory
    ( canonicalizePath, doesFileExist, getTemporaryDirectory, removeDirectoryRecursive )
import System.FilePath
    ( (</>), takeFileName )
import qualified Text.Parsec as P

-- A note on multi-module script support #6787:
-- Multi-module scripts are not supported and support is non-trivial.
-- What you want to do is pass the absolute path to the script's directory in hs-source-dirs,
-- but hs-source-dirs only accepts relative paths. This leaves you with several options none
-- of which are particularly appealing.
-- 1) Loosen the requirement that hs-source-dirs take relative paths
-- 2) Add a field to BuildInfo that acts like an hs-source-dir, but accepts an absolute path
-- 3) Use a path relative to the project root in hs-source-dirs, and pass extra flags to the
--    repl to deal with the fact that the repl is relative to the working directory and not
--    the project root.

-- | Get the hash of a script's absolute path)
--
-- Two hashes will be the same as long as the absolute paths
-- are the same.
getScriptHash :: FilePath -> IO String
getScriptHash :: [Char] -> IO [Char]
getScriptHash [Char]
script = HashValue -> [Char]
showHashValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> HashValue
hashValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => [Char] -> a
fromString forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [Char]
canonicalizePath [Char]
script

-- | Get the directory for caching a script build.
--
-- The only identity of a script is it's absolute path, so append the
-- hashed path to the @script-builds@ dir to get the cache directory.
getScriptCacheDirectory :: FilePath -> IO FilePath
getScriptCacheDirectory :: [Char] -> IO [Char]
getScriptCacheDirectory [Char]
script = [Char] -> [Char] -> [Char]
(</>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [Char]
defaultScriptBuildsDir forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> IO [Char]
getScriptHash [Char]
script

-- | Get the directory for caching a script build and ensure it exists.
--
-- The only identity of a script is it's absolute path, so append the
-- hashed path to the @script-builds@ dir to get the cache directory.
ensureScriptCacheDirectory :: Verbosity -> FilePath -> IO FilePath
ensureScriptCacheDirectory :: Verbosity -> [Char] -> IO [Char]
ensureScriptCacheDirectory Verbosity
verbosity [Char]
script = do
  [Char]
cacheDir <- [Char] -> IO [Char]
getScriptCacheDirectory [Char]
script
  Verbosity -> Bool -> [Char] -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True [Char]
cacheDir
  forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
cacheDir

-- | What your command should do when no targets are found.
data AcceptNoTargets
  = RejectNoTargets -- ^ die on 'TargetSelectorNoTargetsInProject'
  | AcceptNoTargets -- ^ return a default 'TargetSelector'
  deriving (AcceptNoTargets -> AcceptNoTargets -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AcceptNoTargets -> AcceptNoTargets -> Bool
$c/= :: AcceptNoTargets -> AcceptNoTargets -> Bool
== :: AcceptNoTargets -> AcceptNoTargets -> Bool
$c== :: AcceptNoTargets -> AcceptNoTargets -> Bool
Eq, Int -> AcceptNoTargets -> [Char] -> [Char]
[AcceptNoTargets] -> [Char] -> [Char]
AcceptNoTargets -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [AcceptNoTargets] -> [Char] -> [Char]
$cshowList :: [AcceptNoTargets] -> [Char] -> [Char]
show :: AcceptNoTargets -> [Char]
$cshow :: AcceptNoTargets -> [Char]
showsPrec :: Int -> AcceptNoTargets -> [Char] -> [Char]
$cshowsPrec :: Int -> AcceptNoTargets -> [Char] -> [Char]
Show)

-- | Information about the context in which we found the 'TargetSelector's.
data TargetContext
  = ProjectContext -- ^ The target selectors are part of a project.
  | GlobalContext  -- ^ The target selectors are from the global context.
  | ScriptContext FilePath Executable
  -- ^ The target selectors refer to a script. Contains the path to the script and
  -- the executable metadata parsed from the script
  deriving (TargetContext -> TargetContext -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TargetContext -> TargetContext -> Bool
$c/= :: TargetContext -> TargetContext -> Bool
== :: TargetContext -> TargetContext -> Bool
$c== :: TargetContext -> TargetContext -> Bool
Eq, Int -> TargetContext -> [Char] -> [Char]
[TargetContext] -> [Char] -> [Char]
TargetContext -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [TargetContext] -> [Char] -> [Char]
$cshowList :: [TargetContext] -> [Char] -> [Char]
show :: TargetContext -> [Char]
$cshow :: TargetContext -> [Char]
showsPrec :: Int -> TargetContext -> [Char] -> [Char]
$cshowsPrec :: Int -> TargetContext -> [Char] -> [Char]
Show)

-- | Determine whether the targets represent regular targets or a script
-- and return the proper context and target selectors.
-- Die with an error message if selectors are valid as neither regular targets or as a script.
--
-- In the case that the context refers to a temporary directory,
-- delete it after the action finishes.
withContextAndSelectors
  :: AcceptNoTargets     -- ^ What your command should do when no targets are found.
  -> Maybe ComponentKind -- ^ A target filter
  -> NixStyleFlags a     -- ^ Command line flags
  -> [String]            -- ^ Target strings or a script and args.
  -> GlobalFlags         -- ^ Global flags.
  -> CurrentCommand      -- ^ Current Command (usually for error reporting).
  -> (TargetContext -> ProjectBaseContext -> [TargetSelector] -> IO b)
  -- ^ The body of your command action.
  -> IO b
withContextAndSelectors :: forall a b.
AcceptNoTargets
-> Maybe ComponentKind
-> NixStyleFlags a
-> [[Char]]
-> GlobalFlags
-> CurrentCommand
-> (TargetContext
    -> ProjectBaseContext -> [TargetSelector] -> IO b)
-> IO b
withContextAndSelectors AcceptNoTargets
noTargets Maybe ComponentKind
kind flags :: NixStyleFlags a
flags@NixStyleFlags {a
ConfigFlags
HaddockFlags
TestFlags
BenchmarkFlags
ProjectFlags
InstallFlags
ConfigExFlags
extraFlags :: forall a. NixStyleFlags a -> a
projectFlags :: forall a. NixStyleFlags a -> ProjectFlags
benchmarkFlags :: forall a. NixStyleFlags a -> BenchmarkFlags
testFlags :: forall a. NixStyleFlags a -> TestFlags
haddockFlags :: forall a. NixStyleFlags a -> HaddockFlags
installFlags :: forall a. NixStyleFlags a -> InstallFlags
configExFlags :: forall a. NixStyleFlags a -> ConfigExFlags
configFlags :: forall a. NixStyleFlags a -> ConfigFlags
extraFlags :: a
projectFlags :: ProjectFlags
benchmarkFlags :: BenchmarkFlags
testFlags :: TestFlags
haddockFlags :: HaddockFlags
installFlags :: InstallFlags
configExFlags :: ConfigExFlags
configFlags :: ConfigFlags
..} [[Char]]
targetStrings GlobalFlags
globalFlags CurrentCommand
cmd TargetContext -> ProjectBaseContext -> [TargetSelector] -> IO b
act
  = forall a. (IO [Char] -> IO a) -> IO a
withTemporaryTempDirectory forall a b. (a -> b) -> a -> b
$ \IO [Char]
mkTmpDir -> do
    (TargetContext
tc, ProjectBaseContext
ctx) <- forall a.
Verbosity
-> Flag Bool
-> Flag [Char]
-> IO a
-> (ProjectConfig -> IO a)
-> IO a
withProjectOrGlobalConfig Verbosity
verbosity Flag Bool
ignoreProject Flag [Char]
globalConfigFlag IO (TargetContext, ProjectBaseContext)
with (IO [Char]
-> ProjectConfig -> IO (TargetContext, ProjectBaseContext)
without IO [Char]
mkTmpDir)

    (TargetContext
tc', ProjectBaseContext
ctx', [TargetSelector]
sels) <- case [[Char]]
targetStrings of
      -- Only script targets may contain spaces and or end with ':'.
      -- Trying to readTargetSelectors such a target leads to a parse error.
      [[Char]
target] | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Char
c -> Char -> Bool
isSpace Char
c) [Char]
target Bool -> Bool -> Bool
|| [Char]
":" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
target -> do
          [Char]
-> [TargetSelectorProblem]
-> IO (TargetContext, ProjectBaseContext, [TargetSelector])
scriptOrError [Char]
target [TargetString -> TargetSelectorProblem
TargetSelectorNoScript forall a b. (a -> b) -> a -> b
$ [Char] -> TargetString
TargetString1 [Char]
target]
      [[Char]]
_                                                   -> do
        -- In the case where a selector is both a valid target and script, assume it is a target,
        -- because you can disambiguate the script with "./script"
        forall a.
[PackageSpecifier (SourcePackage (PackageLocation a))]
-> Maybe ComponentKind
-> [[Char]]
-> IO (Either [TargetSelectorProblem] [TargetSelector])
readTargetSelectors (ProjectBaseContext -> [PackageSpecifier UnresolvedSourcePackage]
localPackages ProjectBaseContext
ctx) Maybe ComponentKind
kind [[Char]]
targetStrings forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Left err :: [TargetSelectorProblem]
err@(TargetSelectorProblem
TargetSelectorNoTargetsInProject:[TargetSelectorProblem]
_)
            | [] <- [[Char]]
targetStrings
            , AcceptNoTargets
AcceptNoTargets <- AcceptNoTargets
noTargets -> forall (m :: * -> *) a. Monad m => a -> m a
return (TargetContext
tc, ProjectBaseContext
ctx, [TargetSelector]
defaultTarget)
            | ([Char]
script:[[Char]]
_) <- [[Char]]
targetStrings  -> [Char]
-> [TargetSelectorProblem]
-> IO (TargetContext, ProjectBaseContext, [TargetSelector])
scriptOrError [Char]
script [TargetSelectorProblem]
err
          Left err :: [TargetSelectorProblem]
err@(TargetSelectorNoSuch TargetString
t [(Maybe ([Char], [Char]), [Char], [Char], [[Char]])]
_:[TargetSelectorProblem]
_)
            | TargetString1 [Char]
script <- TargetString
t    -> [Char]
-> [TargetSelectorProblem]
-> IO (TargetContext, ProjectBaseContext, [TargetSelector])
scriptOrError [Char]
script [TargetSelectorProblem]
err
          Left err :: [TargetSelectorProblem]
err@(TargetSelectorExpected TargetString
t [[Char]]
_ [Char]
_:[TargetSelectorProblem]
_)
            | TargetString1 [Char]
script <- TargetString
t    -> [Char]
-> [TargetSelectorProblem]
-> IO (TargetContext, ProjectBaseContext, [TargetSelector])
scriptOrError [Char]
script [TargetSelectorProblem]
err
          Left err :: [TargetSelectorProblem]
err@(MatchingInternalError TargetString
_ TargetSelector
_ [(TargetString, [TargetSelector])]
_:[TargetSelectorProblem]
_) -- Handle ':' in middle of script name.
            | [[Char]
script] <- [[Char]]
targetStrings    -> [Char]
-> [TargetSelectorProblem]
-> IO (TargetContext, ProjectBaseContext, [TargetSelector])
scriptOrError [Char]
script [TargetSelectorProblem]
err
          Left [TargetSelectorProblem]
err                         -> forall a. Verbosity -> [TargetSelectorProblem] -> IO a
reportTargetSelectorProblems Verbosity
verbosity [TargetSelectorProblem]
err
          Right [TargetSelector]
sels                       -> forall (m :: * -> *) a. Monad m => a -> m a
return (TargetContext
tc, ProjectBaseContext
ctx, [TargetSelector]
sels)

    TargetContext -> ProjectBaseContext -> [TargetSelector] -> IO b
act TargetContext
tc' ProjectBaseContext
ctx' [TargetSelector]
sels
  where
    verbosity :: Verbosity
verbosity = forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal (ConfigFlags -> Flag Verbosity
configVerbosity ConfigFlags
configFlags)
    ignoreProject :: Flag Bool
ignoreProject = ProjectFlags -> Flag Bool
flagIgnoreProject ProjectFlags
projectFlags
    cliConfig :: ProjectConfig
cliConfig = forall a.
GlobalFlags
-> NixStyleFlags a -> ClientInstallFlags -> ProjectConfig
commandLineFlagsToProjectConfig GlobalFlags
globalFlags NixStyleFlags a
flags forall a. Monoid a => a
mempty
    globalConfigFlag :: Flag [Char]
globalConfigFlag = ProjectConfigShared -> Flag [Char]
projectConfigConfigFile (ProjectConfig -> ProjectConfigShared
projectConfigShared ProjectConfig
cliConfig)
    defaultTarget :: [TargetSelector]
defaultTarget = [TargetImplicitCwd
-> [PackageId] -> Maybe ComponentKind -> TargetSelector
TargetPackage TargetImplicitCwd
TargetExplicitNamed [PackageId
fakePackageId] forall a. Maybe a
Nothing]

    with :: IO (TargetContext, ProjectBaseContext)
with = do
      ProjectBaseContext
ctx <- Verbosity
-> ProjectConfig -> CurrentCommand -> IO ProjectBaseContext
establishProjectBaseContext Verbosity
verbosity ProjectConfig
cliConfig CurrentCommand
cmd
      forall (m :: * -> *) a. Monad m => a -> m a
return (TargetContext
ProjectContext, ProjectBaseContext
ctx)
    without :: IO [Char]
-> ProjectConfig -> IO (TargetContext, ProjectBaseContext)
without IO [Char]
mkDir ProjectConfig
globalConfig = do
      DistDirLayout
distDirLayout <- Verbosity -> ProjectConfig -> [Char] -> IO DistDirLayout
establishDummyDistDirLayout Verbosity
verbosity (ProjectConfig
globalConfig forall a. Semigroup a => a -> a -> a
<> ProjectConfig
cliConfig) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [Char]
mkDir
      ProjectBaseContext
ctx <- Verbosity
-> ProjectConfig
-> DistDirLayout
-> [PackageSpecifier UnresolvedSourcePackage]
-> CurrentCommand
-> IO ProjectBaseContext
establishDummyProjectBaseContext Verbosity
verbosity (ProjectConfig
globalConfig forall a. Semigroup a => a -> a -> a
<> ProjectConfig
cliConfig) DistDirLayout
distDirLayout [] CurrentCommand
cmd
      forall (m :: * -> *) a. Monad m => a -> m a
return (TargetContext
GlobalContext, ProjectBaseContext
ctx)
    scriptOrError :: [Char]
-> [TargetSelectorProblem]
-> IO (TargetContext, ProjectBaseContext, [TargetSelector])
scriptOrError [Char]
script [TargetSelectorProblem]
err = do
      Bool
exists <- [Char] -> IO Bool
doesFileExist [Char]
script
      if Bool
exists then do
        -- In the script case we always want a dummy context even when ignoreProject is False
        let mkCacheDir :: IO [Char]
mkCacheDir = Verbosity -> [Char] -> IO [Char]
ensureScriptCacheDirectory Verbosity
verbosity [Char]
script
        (TargetContext
_, ProjectBaseContext
ctx) <- forall a.
Verbosity
-> Flag Bool
-> Flag [Char]
-> IO a
-> (ProjectConfig -> IO a)
-> IO a
withProjectOrGlobalConfig Verbosity
verbosity (forall a. a -> Flag a
Flag Bool
True) Flag [Char]
globalConfigFlag IO (TargetContext, ProjectBaseContext)
with (IO [Char]
-> ProjectConfig -> IO (TargetContext, ProjectBaseContext)
without IO [Char]
mkCacheDir)

        let projectRoot :: [Char]
projectRoot = DistDirLayout -> [Char]
distProjectRootDirectory forall a b. (a -> b) -> a -> b
$ ProjectBaseContext -> DistDirLayout
distDirLayout ProjectBaseContext
ctx
        [Char] -> [Char] -> IO ()
writeFile ([Char]
projectRoot [Char] -> [Char] -> [Char]
</> [Char]
"scriptlocation") forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> IO [Char]
canonicalizePath [Char]
script

        ByteString
scriptContents <- [Char] -> IO ByteString
BS.readFile [Char]
script
        Executable
executable     <- Verbosity -> ByteString -> IO Executable
readExecutableBlockFromScript Verbosity
verbosity ByteString
scriptContents


        HttpTransport
httpTransport <- Verbosity -> [[Char]] -> Maybe [Char] -> IO HttpTransport
configureTransport Verbosity
verbosity
                     (forall a. NubList a -> [a]
fromNubList forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectConfigShared -> NubList [Char]
projectConfigProgPathExtra forall a b. (a -> b) -> a -> b
$ ProjectConfig -> ProjectConfigShared
projectConfigShared ProjectConfig
cliConfig)
                     (forall a. Flag a -> Maybe a
flagToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectConfigBuildOnly -> Flag [Char]
projectConfigHttpTransport forall a b. (a -> b) -> a -> b
$ ProjectConfig -> ProjectConfigBuildOnly
projectConfigBuildOnly ProjectConfig
cliConfig)

        ProjectConfigSkeleton
projectCfgSkeleton <- Verbosity
-> HttpTransport
-> DistDirLayout
-> [Char]
-> ByteString
-> IO ProjectConfigSkeleton
readProjectBlockFromScript Verbosity
verbosity HttpTransport
httpTransport (ProjectBaseContext -> DistDirLayout
distDirLayout ProjectBaseContext
ctx) ([Char] -> [Char]
takeFileName [Char]
script) ByteString
scriptContents

        let fetchCompiler :: IO (OS, Arch, CompilerInfo)
fetchCompiler = do
               (Compiler
compiler, Platform Arch
arch OS
os, ProgramDb
_) <- forall a. [Char] -> Rebuild a -> IO a
runRebuild (DistDirLayout -> [Char]
distProjectRootDirectory forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectBaseContext -> DistDirLayout
distDirLayout forall a b. (a -> b) -> a -> b
$ ProjectBaseContext
ctx) forall a b. (a -> b) -> a -> b
$ Verbosity
-> DistDirLayout
-> ProjectConfig
-> Rebuild (Compiler, Platform, ProgramDb)
configureCompiler Verbosity
verbosity (ProjectBaseContext -> DistDirLayout
distDirLayout ProjectBaseContext
ctx) ((forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a c v.
(Semigroup a, Semigroup c) =>
CondTree v c a -> (a, c)
ignoreConditions ProjectConfigSkeleton
projectCfgSkeleton) forall a. Semigroup a => a -> a -> a
<> ProjectBaseContext -> ProjectConfig
projectConfig ProjectBaseContext
ctx)
               forall (f :: * -> *) a. Applicative f => a -> f a
pure (OS
os, Arch
arch, Compiler -> CompilerInfo
compilerInfo Compiler
compiler)

        ProjectConfig
projectCfg <- forall (m :: * -> *).
Monad m =>
m (OS, Arch, CompilerInfo)
-> FlagAssignment -> ProjectConfigSkeleton -> m ProjectConfig
instantiateProjectConfigSkeletonFetchingCompiler IO (OS, Arch, CompilerInfo)
fetchCompiler forall a. Monoid a => a
mempty ProjectConfigSkeleton
projectCfgSkeleton

        let executable' :: Executable
executable' = Executable
executable forall a b. a -> (a -> b) -> b
& forall a. HasBuildInfo a => Lens' a BuildInfo
L.buildInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasBuildInfo a => Lens' a (Maybe Language)
L.defaultLanguage forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. a -> Maybe a
Just Language
Haskell2010) forall a. a -> Maybe a
Just
            ctx' :: ProjectBaseContext
ctx'        = ProjectBaseContext
ctx forall a b. a -> (a -> b) -> b
& Lens' ProjectBaseContext ProjectConfig
lProjectConfig forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. Semigroup a => a -> a -> a
<> ProjectConfig
projectCfg)
        forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Executable -> TargetContext
ScriptContext [Char]
script Executable
executable', ProjectBaseContext
ctx', [TargetSelector]
defaultTarget)
      else forall a. Verbosity -> [TargetSelectorProblem] -> IO a
reportTargetSelectorProblems Verbosity
verbosity [TargetSelectorProblem]
err

withTemporaryTempDirectory :: (IO FilePath -> IO a) -> IO a
withTemporaryTempDirectory :: forall a. (IO [Char] -> IO a) -> IO a
withTemporaryTempDirectory IO [Char] -> IO a
act = forall a. IO (MVar a)
newEmptyMVar forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \MVar [Char]
m -> forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (forall {m :: * -> *}. Monad m => MVar [Char] -> m (IO [Char])
getMkTmp MVar [Char]
m) (forall {p}. MVar [Char] -> p -> IO ()
rmTmp MVar [Char]
m) IO [Char] -> IO a
act
  where
    -- We return an (IO Filepath) instead of a FilePath for two reasons:
    -- 1) To give the consumer the discretion to not create the tmpDir,
    --    but still grantee that it's deleted if they do create it
    -- 2) Because the path returned by createTempDirectory is not predicable
    getMkTmp :: MVar [Char] -> m (IO [Char])
getMkTmp MVar [Char]
m = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
      [Char]
tmpDir <- IO [Char]
getTemporaryDirectory forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip [Char] -> [Char] -> IO [Char]
createTempDirectory [Char]
"cabal-repl."
      forall a. MVar a -> a -> IO ()
putMVar MVar [Char]
m [Char]
tmpDir
      forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
tmpDir
    rmTmp :: MVar [Char] -> p -> IO ()
rmTmp MVar [Char]
m p
_ = forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar [Char]
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (forall a. a -> IO a -> IO a
handleDoesNotExist () forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ()
removeDirectoryRecursive)

-- | Add the 'SourcePackage' to the context and use it to write a .cabal file.
updateContextAndWriteProjectFile' :: ProjectBaseContext -> SourcePackage (PackageLocation (Maybe FilePath)) -> IO ProjectBaseContext
updateContextAndWriteProjectFile' :: ProjectBaseContext
-> UnresolvedSourcePackage -> IO ProjectBaseContext
updateContextAndWriteProjectFile' ProjectBaseContext
ctx UnresolvedSourcePackage
srcPkg = do
  let projectRoot :: [Char]
projectRoot      = DistDirLayout -> [Char]
distProjectRootDirectory forall a b. (a -> b) -> a -> b
$ ProjectBaseContext -> DistDirLayout
distDirLayout ProjectBaseContext
ctx
      packageFile :: [Char]
packageFile      = [Char]
projectRoot [Char] -> [Char] -> [Char]
</> [Char]
fakePackageCabalFileName
      contents :: [Char]
contents         = GenericPackageDescription -> [Char]
showGenericPackageDescription (forall loc. SourcePackage loc -> GenericPackageDescription
srcpkgDescription UnresolvedSourcePackage
srcPkg)
      writePackageFile :: IO ()
writePackageFile = [Char] -> [Char] -> IO ()
writeUTF8File [Char]
packageFile [Char]
contents
  -- TODO This is here to prevent reconfiguration of cached repl packages.
  -- It's worth investigating why it's needed in the first place.
  Bool
packageFileExists <- [Char] -> IO Bool
doesFileExist [Char]
packageFile
  if Bool
packageFileExists then do
    [Char]
cached <- forall a. NFData a => a -> a
force forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [Char]
readUTF8File [Char]
packageFile
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Char]
cached forall a. Eq a => a -> a -> Bool
/= [Char]
contents)
      IO ()
writePackageFile
  else IO ()
writePackageFile
  forall (m :: * -> *) a. Monad m => a -> m a
return (ProjectBaseContext
ctx forall a b. a -> (a -> b) -> b
& Lens' ProjectBaseContext [PackageSpecifier UnresolvedSourcePackage]
lLocalPackages forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. [a] -> [a] -> [a]
++ [forall pkg. pkg -> PackageSpecifier pkg
SpecificSourcePackage UnresolvedSourcePackage
srcPkg]))

-- | Add add the executable metadata to the context and write a .cabal file.
updateContextAndWriteProjectFile :: ProjectBaseContext -> FilePath -> Executable -> IO ProjectBaseContext
updateContextAndWriteProjectFile :: ProjectBaseContext -> [Char] -> Executable -> IO ProjectBaseContext
updateContextAndWriteProjectFile ProjectBaseContext
ctx [Char]
scriptPath Executable
scriptExecutable = do
  let projectRoot :: [Char]
projectRoot = DistDirLayout -> [Char]
distProjectRootDirectory forall a b. (a -> b) -> a -> b
$ ProjectBaseContext -> DistDirLayout
distDirLayout ProjectBaseContext
ctx

  [Char]
absScript <- [Char] -> IO [Char]
canonicalizePath [Char]
scriptPath
  let
    -- Replace characters which aren't allowed in the executable component name with '_'
    -- Prefix with "cabal-script-" to make it clear to end users that the name may be mangled
    scriptExeName :: [Char]
scriptExeName = [Char]
"cabal-script-" forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
censor ([Char] -> [Char]
takeFileName [Char]
scriptPath)
    censor :: Char -> Char
censor Char
c | Char
c forall a. Ord a => a -> Set a -> Bool
`S.member` Set Char
ccNamecore = Char
c
             | Bool
otherwise               = Char
'_'

    sourcePackage :: SourcePackage (PackageLocation loc)
sourcePackage = forall loc. [Char] -> SourcePackage (PackageLocation loc)
fakeProjectSourcePackage [Char]
projectRoot
      forall a b. a -> (a -> b) -> b
& forall loc. Lens' (SourcePackage loc) GenericPackageDescription
lSrcpkgDescription forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens'
  GenericPackageDescription
  [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)]
L.condExecutables
      forall s t a b. ASetter s t a b -> b -> s -> t
.~ [(forall a. IsString a => [Char] -> a
fromString [Char]
scriptExeName, forall v c a. a -> c -> [CondBranch v c a] -> CondTree v c a
CondNode Executable
executable (BuildInfo -> [Dependency]
targetBuildDepends forall a b. (a -> b) -> a -> b
$ Executable -> BuildInfo
buildInfo Executable
executable) [])]
    executable :: Executable
executable = Executable
scriptExecutable
      forall a b. a -> (a -> b) -> b
& Lens' Executable [Char]
L.modulePath forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Char]
absScript

  ProjectBaseContext
-> UnresolvedSourcePackage -> IO ProjectBaseContext
updateContextAndWriteProjectFile' ProjectBaseContext
ctx forall {loc}. SourcePackage (PackageLocation loc)
sourcePackage

parseScriptBlock :: BS.ByteString -> ParseResult Executable
parseScriptBlock :: ByteString -> ParseResult Executable
parseScriptBlock ByteString
str =
    case ByteString -> Either ParseError [Field Position]
readFields ByteString
str of
        Right [Field Position]
fs -> do
            let (Fields Position
fields, [Field Position]
_) = forall ann. [Field ann] -> (Fields ann, [Field ann])
takeFields [Field Position]
fs
            forall s a.
CabalSpecVersion
-> Fields Position -> ParsecFieldGrammar s a -> ParseResult a
parseFieldGrammar CabalSpecVersion
cabalSpecLatest Fields Position
fields (forall (c :: * -> Constraint) (g :: * -> * -> *).
(FieldGrammar c g, Applicative (g Executable),
 Applicative (g BuildInfo), c (Identity ExecutableScope),
 c (List CommaFSep (Identity ExeDependency) ExeDependency),
 c (List
      CommaFSep (Identity LegacyExeDependency) LegacyExeDependency),
 c (List
      CommaFSep (Identity PkgconfigDependency) PkgconfigDependency),
 c (List CommaVCat (Identity Dependency) Dependency),
 c (List CommaVCat (Identity Mixin) Mixin),
 c (List FSep (MQuoted Extension) Extension),
 c (List FSep (MQuoted Language) Language),
 c (List FSep FilePathNT [Char]), c (List FSep Token [Char]),
 c (List
      FSep
      (Identity (SymbolicPath PackageDir SourceDir))
      (SymbolicPath PackageDir SourceDir)),
 c (List NoCommaFSep Token' [Char]),
 c (List VCat (MQuoted ModuleName) ModuleName),
 c (List VCat FilePathNT [Char]), c (List VCat Token [Char]),
 c (MQuoted Language)) =>
UnqualComponentName -> g Executable Executable
executableFieldGrammar UnqualComponentName
"script")
        Left ParseError
perr -> forall a. Position -> [Char] -> ParseResult a
parseFatalFailure Position
pos (forall a. Show a => a -> [Char]
show ParseError
perr) where
            ppos :: SourcePos
ppos = ParseError -> SourcePos
P.errorPos ParseError
perr
            pos :: Position
pos  = Int -> Int -> Position
Position (SourcePos -> Int
P.sourceLine SourcePos
ppos) (SourcePos -> Int
P.sourceColumn SourcePos
ppos)

readScriptBlock :: Verbosity -> BS.ByteString -> IO Executable
readScriptBlock :: Verbosity -> ByteString -> IO Executable
readScriptBlock Verbosity
verbosity = forall a.
(ByteString -> ParseResult a)
-> Verbosity -> [Char] -> ByteString -> IO a
parseString ByteString -> ParseResult Executable
parseScriptBlock Verbosity
verbosity [Char]
"script block"

-- | Extract the first encountered executable metadata block started and
-- terminated by the below tokens or die.
--
-- * @{- cabal:@
--
-- * @-}@
--
-- Return the metadata.
readExecutableBlockFromScript :: Verbosity -> BS.ByteString -> IO Executable
readExecutableBlockFromScript :: Verbosity -> ByteString -> IO Executable
readExecutableBlockFromScript Verbosity
verbosity ByteString
str = do
    ByteString
str' <- case ByteString -> ByteString -> Either [Char] ByteString
extractScriptBlock ByteString
"cabal" ByteString
str of
              Left [Char]
e -> forall a. Verbosity -> [Char] -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [Char]
"Failed extracting script block: " forall a. [a] -> [a] -> [a]
++ [Char]
e
              Right ByteString
x -> forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
x
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Char -> Bool) -> ByteString -> Bool
BS.all Char -> Bool
isSpace ByteString
str') forall a b. (a -> b) -> a -> b
$ Verbosity -> [Char] -> IO ()
warn Verbosity
verbosity [Char]
"Empty script block"
    Verbosity -> ByteString -> IO Executable
readScriptBlock Verbosity
verbosity ByteString
str'

-- | Extract the first encountered project metadata block started and
-- terminated by the below tokens.
--
-- * @{- project:@
--
-- * @-}@
--
-- Return the metadata.
readProjectBlockFromScript :: Verbosity -> HttpTransport -> DistDirLayout -> String -> BS.ByteString -> IO ProjectConfigSkeleton
readProjectBlockFromScript :: Verbosity
-> HttpTransport
-> DistDirLayout
-> [Char]
-> ByteString
-> IO ProjectConfigSkeleton
readProjectBlockFromScript Verbosity
verbosity HttpTransport
httpTransport DistDirLayout{[Char]
distDownloadSrcDirectory :: DistDirLayout -> [Char]
distDownloadSrcDirectory :: [Char]
distDownloadSrcDirectory} [Char]
scriptName ByteString
str = do
    case ByteString -> ByteString -> Either [Char] ByteString
extractScriptBlock ByteString
"project" ByteString
str of
        Left  [Char]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
        Right ByteString
x ->    Verbosity
-> [Char]
-> [Char]
-> ParseResult ProjectConfigSkeleton
-> IO ProjectConfigSkeleton
reportParseResult Verbosity
verbosity [Char]
"script" [Char]
scriptName
                  forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char]
-> HttpTransport
-> Verbosity
-> [[Char]]
-> [Char]
-> ByteString
-> IO (ParseResult ProjectConfigSkeleton)
parseProjectSkeleton [Char]
distDownloadSrcDirectory HttpTransport
httpTransport Verbosity
verbosity [] [Char]
scriptName ByteString
x

-- | Extract the first encountered script metadata block started end
-- terminated by the tokens
--
-- * @{- <header>:@
--
-- * @-}@
--
-- appearing alone on lines (while tolerating trailing whitespace).
-- These tokens are not part of the 'Right' result.
--
-- In case of missing or unterminated blocks a 'Left'-error is
-- returned.
extractScriptBlock :: BS.ByteString -> BS.ByteString -> Either String BS.ByteString
extractScriptBlock :: ByteString -> ByteString -> Either [Char] ByteString
extractScriptBlock ByteString
header ByteString
str = [ByteString] -> Either [Char] ByteString
goPre (ByteString -> [ByteString]
BS.lines ByteString
str)
  where
    isStartMarker :: ByteString -> Bool
isStartMarker = (forall a. Eq a => a -> a -> Bool
== ByteString
startMarker) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
stripTrailSpace
    isEndMarker :: ByteString -> Bool
isEndMarker   = (forall a. Eq a => a -> a -> Bool
== ByteString
endMarker) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
stripTrailSpace

    stripTrailSpace :: ByteString -> ByteString
stripTrailSpace = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> (ByteString, ByteString)
BS.spanEnd Char -> Bool
isSpace

    -- before start marker
    goPre :: [ByteString] -> Either [Char] ByteString
goPre [ByteString]
ls = case forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bool
isStartMarker) [ByteString]
ls of
                 [] -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Char]
"`" forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
BS.unpack ByteString
startMarker forall a. [a] -> [a] -> [a]
++ [Char]
"` start marker not found"
                 (ByteString
_:[ByteString]
ls') -> [ByteString] -> [ByteString] -> Either [Char] ByteString
goBody [] [ByteString]
ls'

    goBody :: [ByteString] -> [ByteString] -> Either [Char] ByteString
goBody [ByteString]
_ [] = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Char]
"`" forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
BS.unpack ByteString
endMarker forall a. [a] -> [a] -> [a]
++ [Char]
"` end marker not found"
    goBody [ByteString]
acc (ByteString
l:[ByteString]
ls)
      | ByteString -> Bool
isEndMarker ByteString
l = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$! [ByteString] -> ByteString
BS.unlines forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [ByteString]
acc
      | Bool
otherwise     = [ByteString] -> [ByteString] -> Either [Char] ByteString
goBody (ByteString
lforall a. a -> [a] -> [a]
:[ByteString]
acc) [ByteString]
ls

    startMarker, endMarker :: BS.ByteString
    startMarker :: ByteString
startMarker = ByteString
"{- " forall a. Semigroup a => a -> a -> a
<> ByteString
header forall a. Semigroup a => a -> a -> a
<> ByteString
":"
    endMarker :: ByteString
endMarker   = ByteString
"-}"

-- | The base for making a 'SourcePackage' for a fake project.
-- It needs a 'Distribution.Types.Library.Library' or 'Executable' depending on the command.
fakeProjectSourcePackage :: FilePath -> SourcePackage (PackageLocation loc)
fakeProjectSourcePackage :: forall loc. [Char] -> SourcePackage (PackageLocation loc)
fakeProjectSourcePackage [Char]
projectRoot = forall {loc}. SourcePackage (PackageLocation loc)
sourcePackage
  where
    sourcePackage :: SourcePackage (PackageLocation local)
sourcePackage = SourcePackage
      { srcpkgPackageId :: PackageId
srcpkgPackageId     = PackageId
fakePackageId
      , srcpkgDescription :: GenericPackageDescription
srcpkgDescription   = GenericPackageDescription
genericPackageDescription
      , srcpkgSource :: PackageLocation local
srcpkgSource        = forall local. [Char] -> PackageLocation local
LocalUnpackedPackage [Char]
projectRoot
      , srcpkgDescrOverride :: PackageDescriptionOverride
srcpkgDescrOverride = forall a. Maybe a
Nothing
      }
    genericPackageDescription :: GenericPackageDescription
genericPackageDescription = GenericPackageDescription
emptyGenericPackageDescription
      { packageDescription :: PackageDescription
GPD.packageDescription = PackageDescription
packageDescription }
    packageDescription :: PackageDescription
packageDescription = PackageDescription
emptyPackageDescription
      { package :: PackageId
package = PackageId
fakePackageId
      , specVersion :: CabalSpecVersion
specVersion = CabalSpecVersion
CabalSpecV2_2
      , licenseRaw :: Either License License
licenseRaw = forall a b. a -> Either a b
Left License
SPDX.NONE
      }

-- Lenses
-- | A lens for the 'srcpkgDescription' field of 'SourcePackage'
lSrcpkgDescription :: Lens' (SourcePackage loc) GenericPackageDescription
lSrcpkgDescription :: forall loc. Lens' (SourcePackage loc) GenericPackageDescription
lSrcpkgDescription GenericPackageDescription -> f GenericPackageDescription
f SourcePackage loc
s = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\GenericPackageDescription
x -> SourcePackage loc
s { srcpkgDescription :: GenericPackageDescription
srcpkgDescription = GenericPackageDescription
x }) (GenericPackageDescription -> f GenericPackageDescription
f (forall loc. SourcePackage loc -> GenericPackageDescription
srcpkgDescription SourcePackage loc
s))
{-# inline lSrcpkgDescription #-}

lLocalPackages :: Lens' ProjectBaseContext [PackageSpecifier UnresolvedSourcePackage]
lLocalPackages :: Lens' ProjectBaseContext [PackageSpecifier UnresolvedSourcePackage]
lLocalPackages [PackageSpecifier UnresolvedSourcePackage]
-> f [PackageSpecifier UnresolvedSourcePackage]
f ProjectBaseContext
s = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[PackageSpecifier UnresolvedSourcePackage]
x -> ProjectBaseContext
s { localPackages :: [PackageSpecifier UnresolvedSourcePackage]
localPackages = [PackageSpecifier UnresolvedSourcePackage]
x }) ([PackageSpecifier UnresolvedSourcePackage]
-> f [PackageSpecifier UnresolvedSourcePackage]
f (ProjectBaseContext -> [PackageSpecifier UnresolvedSourcePackage]
localPackages ProjectBaseContext
s))
{-# inline lLocalPackages #-}

lProjectConfig :: Lens' ProjectBaseContext ProjectConfig
lProjectConfig :: Lens' ProjectBaseContext ProjectConfig
lProjectConfig ProjectConfig -> f ProjectConfig
f ProjectBaseContext
s = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ProjectConfig
x -> ProjectBaseContext
s { projectConfig :: ProjectConfig
projectConfig = ProjectConfig
x }) (ProjectConfig -> f ProjectConfig
f (ProjectBaseContext -> ProjectConfig
projectConfig ProjectBaseContext
s))
{-# inline lProjectConfig #-}

-- Character classes
-- Transcribed from "templates/Lexer.x"
ccSpace, ccCtrlchar, ccPrintable, ccSymbol', ccParen, ccNamecore :: Set Char
ccSpace :: Set Char
ccSpace     = forall a. Ord a => [a] -> Set a
S.fromList [Char]
" "
ccCtrlchar :: Set Char
ccCtrlchar  = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ [Int -> Char
chr Int
0x0 .. Int -> Char
chr Int
0x1f] forall a. [a] -> [a] -> [a]
++ [Int -> Char
chr Int
0x7f]
ccPrintable :: Set Char
ccPrintable = forall a. Ord a => [a] -> Set a
S.fromList [Int -> Char
chr Int
0x0 .. Int -> Char
chr Int
0xff] forall a. Ord a => Set a -> Set a -> Set a
S.\\ Set Char
ccCtrlchar
ccSymbol' :: Set Char
ccSymbol'   = forall a. Ord a => [a] -> Set a
S.fromList [Char]
",=<>+*&|!$%^@#?/\\~"
ccParen :: Set Char
ccParen     = forall a. Ord a => [a] -> Set a
S.fromList [Char]
"()[]"
ccNamecore :: Set Char
ccNamecore  = Set Char
ccPrintable forall a. Ord a => Set a -> Set a -> Set a
S.\\ forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions [Set Char
ccSpace, forall a. Ord a => [a] -> Set a
S.fromList [Char]
":\"{}", Set Char
ccParen, Set Char
ccSymbol']