{-# 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
  , movedExePath
  ) where

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

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

import Distribution.CabalSpecVersion
  ( CabalSpecVersion (..)
  , cabalSpecLatest
  )
import Distribution.Client.Config
  ( defaultScriptBuildsDir
  )
import Distribution.Client.DistDirLayout
  ( DistDirLayout (..)
  , DistDirParams (..)
  )
import Distribution.Client.HashValue
  ( hashValue
  , showHashValue
  , truncateHash
  )
import Distribution.Client.HttpUtils
  ( HttpTransport
  , configureTransport
  )
import Distribution.Client.NixStyleOptions
  ( NixStyleFlags (..)
  )
import Distribution.Client.ProjectConfig
  ( PackageConfig (..)
  , ProjectConfig (..)
  , ProjectConfigShared (..)
  , projectConfigHttpTransport
  , reportParseResult
  , withGlobalConfig
  , withProjectOrGlobalConfig
  )
import Distribution.Client.ProjectConfig.Legacy
  ( ProjectConfigSkeleton
  , instantiateProjectConfigSkeletonFetchingCompiler
  , parseProject
  )
import Distribution.Client.ProjectConfig.Types (ProjectConfigToParse (..))
import Distribution.Client.ProjectFlags
  ( flagIgnoreProject
  )
import Distribution.Client.ProjectOrchestration
import Distribution.Client.ProjectPlanning
  ( ElaboratedConfiguredPackage (..)
  , ElaboratedSharedConfig (..)
  , configureCompiler
  )
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.Compiler
  ( CompilerId (..)
  , perCompilerFlavorToList
  )
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 qualified Distribution.SPDX.License as SPDX
import Distribution.Simple.Compiler
  ( Compiler (..)
  , OptimisationLevel (..)
  , compilerInfo
  )
import Distribution.Simple.Flag
  ( flagToMaybe
  , fromFlagOrDefault
  )
import Distribution.Simple.PackageDescription
  ( parseString
  )
import Distribution.Simple.Setup
  ( Flag (..)
  )
import Distribution.Simple.Utils
  ( createDirectoryIfMissingVerbose
  , createTempDirectory
  , dieWithException
  , handleDoesNotExist
  , readUTF8File
  , warn
  , writeUTF8File
  )
import Distribution.Solver.Types.SourcePackage as SP
  ( SourcePackage (..)
  )
import Distribution.System
  ( Platform (..)
  )
import Distribution.Types.BuildInfo
  ( BuildInfo (..)
  )
import Distribution.Types.ComponentId
  ( mkComponentId
  )
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.Types.UnitId
  ( newSimpleUnitId
  )
import Distribution.Types.UnqualComponentName
  ( UnqualComponentName
  )
import Distribution.Utils.NubList
  ( fromNubList
  )
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 Distribution.Client.Errors
import System.Directory
  ( canonicalizePath
  , doesFileExist
  , getTemporaryDirectory
  , removeDirectoryRecursive
  )
import System.FilePath
  ( makeRelative
  , takeDirectory
  , 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 =
  -- Truncation here tries to help with long path issues on Windows.
  HashValue -> [Char]
showHashValue
    (HashValue -> [Char]) -> ([Char] -> HashValue) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> HashValue -> HashValue
truncateHash Int
26
    (HashValue -> HashValue)
-> ([Char] -> HashValue) -> [Char] -> HashValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> HashValue
hashValue
    (ByteString -> HashValue)
-> ([Char] -> ByteString) -> [Char] -> HashValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ByteString
forall a. IsString a => [Char] -> a
fromString
    ([Char] -> [Char]) -> IO [Char] -> IO [Char]
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]
(</>) ([Char] -> [Char] -> [Char]) -> IO [Char] -> IO ([Char] -> [Char])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [Char]
defaultScriptBuildsDir IO ([Char] -> [Char]) -> IO [Char] -> IO [Char]
forall a b. IO (a -> b) -> IO a -> IO b
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
  cacheDir <- [Char] -> IO [Char]
getScriptCacheDirectory [Char]
script
  createDirectoryIfMissingVerbose verbosity True cacheDir
  return cacheDir

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

-- | Information about the context in which we found the 'TargetSelector's.
data TargetContext
  = -- | The target selectors are part of a project.
    ProjectContext
  | -- | The target selectors are from the global context.
    GlobalContext
  | -- | The target selectors refer to a script. Contains the path to the script and
    -- the executable metadata parsed from the script
    ScriptContext FilePath Executable
  deriving (TargetContext -> TargetContext -> Bool
(TargetContext -> TargetContext -> Bool)
-> (TargetContext -> TargetContext -> Bool) -> Eq TargetContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TargetContext -> TargetContext -> Bool
== :: TargetContext -> TargetContext -> Bool
$c/= :: TargetContext -> TargetContext -> Bool
/= :: TargetContext -> TargetContext -> Bool
Eq, Int -> TargetContext -> [Char] -> [Char]
[TargetContext] -> [Char] -> [Char]
TargetContext -> [Char]
(Int -> TargetContext -> [Char] -> [Char])
-> (TargetContext -> [Char])
-> ([TargetContext] -> [Char] -> [Char])
-> Show TargetContext
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> TargetContext -> [Char] -> [Char]
showsPrec :: Int -> TargetContext -> [Char] -> [Char]
$cshow :: TargetContext -> [Char]
show :: TargetContext -> [Char]
$cshowList :: [TargetContext] -> [Char] -> [Char]
showList :: [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
HaddockFlags
BenchmarkFlags
ConfigFlags
TestFlags
ProjectFlags
InstallFlags
ConfigExFlags
configFlags :: ConfigFlags
configExFlags :: ConfigExFlags
installFlags :: InstallFlags
haddockFlags :: HaddockFlags
testFlags :: TestFlags
benchmarkFlags :: BenchmarkFlags
projectFlags :: ProjectFlags
extraFlags :: a
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
..} [[Char]]
targetStrings GlobalFlags
globalFlags CurrentCommand
cmd TargetContext -> ProjectBaseContext -> [TargetSelector] -> IO b
act =
  (IO [Char] -> IO b) -> IO b
forall a. (IO [Char] -> IO a) -> IO a
withTemporaryTempDirectory ((IO [Char] -> IO b) -> IO b) -> (IO [Char] -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \IO [Char]
mkTmpDir -> do
    (tc, ctx) <-
      Flag Bool
-> IO (TargetContext, ProjectBaseContext)
-> IO (TargetContext, ProjectBaseContext)
-> IO (TargetContext, ProjectBaseContext)
forall a. Flag Bool -> IO a -> IO a -> IO a
withProjectOrGlobalConfig
        Flag Bool
ignoreProject
        IO (TargetContext, ProjectBaseContext)
withProject
        (Verbosity
-> Flag [Char]
-> (ProjectConfig -> IO (TargetContext, ProjectBaseContext))
-> IO (TargetContext, ProjectBaseContext)
forall a.
Verbosity -> Flag [Char] -> (ProjectConfig -> IO a) -> IO a
withGlobalConfig Verbosity
verbosity Flag [Char]
globalConfigFlag ((ProjectConfig -> IO (TargetContext, ProjectBaseContext))
 -> IO (TargetContext, ProjectBaseContext))
-> (ProjectConfig -> IO (TargetContext, ProjectBaseContext))
-> IO (TargetContext, ProjectBaseContext)
forall a b. (a -> b) -> a -> b
$ IO [Char]
-> ProjectConfig -> IO (TargetContext, ProjectBaseContext)
withoutProject IO [Char]
mkTmpDir)

    (tc', ctx', sels) <- case targetStrings of
      -- Only script targets may end with ':'.
      -- Trying to readTargetSelectors such a target leads to a parse error.
      [[Char]
target] | [Char]
":" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
target -> do
        [Char]
-> [TargetSelectorProblem]
-> IO (TargetContext, ProjectBaseContext, [TargetSelector])
scriptOrError [Char]
target [TargetString -> TargetSelectorProblem
TargetSelectorNoScript (TargetString -> TargetSelectorProblem)
-> TargetString -> TargetSelectorProblem
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"
        [PackageSpecifier (SourcePackage (PackageLocation (Maybe [Char])))]
-> Maybe ComponentKind
-> [[Char]]
-> IO (Either [TargetSelectorProblem] [TargetSelector])
forall a.
[PackageSpecifier (SourcePackage (PackageLocation a))]
-> Maybe ComponentKind
-> [[Char]]
-> IO (Either [TargetSelectorProblem] [TargetSelector])
readTargetSelectors (ProjectBaseContext
-> [PackageSpecifier
      (SourcePackage (PackageLocation (Maybe [Char])))]
localPackages ProjectBaseContext
ctx) Maybe ComponentKind
kind [[Char]]
targetStrings IO (Either [TargetSelectorProblem] [TargetSelector])
-> (Either [TargetSelectorProblem] [TargetSelector]
    -> IO (TargetContext, ProjectBaseContext, [TargetSelector]))
-> IO (TargetContext, ProjectBaseContext, [TargetSelector])
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          -- If there are no target selectors and no targets are fine, return
          -- the context
          Left (TargetSelectorNoTargetsInCwd{} : [TargetSelectorProblem]
_)
            | [] <- [[Char]]
targetStrings
            , AcceptNoTargets
AcceptNoTargets <- AcceptNoTargets
noTargets ->
                (TargetContext, ProjectBaseContext, [TargetSelector])
-> IO (TargetContext, ProjectBaseContext, [TargetSelector])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetContext
tc, ProjectBaseContext
ctx, [TargetSelector]
defaultTarget)
          Left err :: [TargetSelectorProblem]
err@(TargetSelectorProblem
TargetSelectorNoTargetsInProject : [TargetSelectorProblem]
_)
            -- If there are no target selectors and no targets are fine, return
            -- the context
            | [] <- [[Char]]
targetStrings
            , AcceptNoTargets
AcceptNoTargets <- AcceptNoTargets
noTargets ->
                (TargetContext, ProjectBaseContext, [TargetSelector])
-> IO (TargetContext, ProjectBaseContext, [TargetSelector])
forall a. a -> IO a
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 -> Verbosity
-> [TargetSelectorProblem]
-> IO (TargetContext, ProjectBaseContext, [TargetSelector])
forall a. Verbosity -> [TargetSelectorProblem] -> IO a
reportTargetSelectorProblems Verbosity
verbosity [TargetSelectorProblem]
err
          Right [TargetSelector]
sels -> (TargetContext, ProjectBaseContext, [TargetSelector])
-> IO (TargetContext, ProjectBaseContext, [TargetSelector])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetContext
tc, ProjectBaseContext
ctx, [TargetSelector]
sels)

    act tc' ctx' sels
  where
    verbosity :: Verbosity
verbosity = Verbosity -> Flag 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 = GlobalFlags
-> NixStyleFlags a -> ClientInstallFlags -> ProjectConfig
forall a.
GlobalFlags
-> NixStyleFlags a -> ClientInstallFlags -> ProjectConfig
commandLineFlagsToProjectConfig GlobalFlags
globalFlags NixStyleFlags a
flags ClientInstallFlags
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] Maybe ComponentKind
forall a. Maybe a
Nothing]

    withProject :: IO (TargetContext, ProjectBaseContext)
withProject = do
      ctx <- Verbosity
-> ProjectConfig -> CurrentCommand -> IO ProjectBaseContext
establishProjectBaseContext Verbosity
verbosity ProjectConfig
cliConfig CurrentCommand
cmd
      return (ProjectContext, ctx)
    withoutProject :: IO [Char]
-> ProjectConfig -> IO (TargetContext, ProjectBaseContext)
withoutProject IO [Char]
mkTmpDir ProjectConfig
globalConfig = do
      distDirLayout <- Verbosity -> ProjectConfig -> [Char] -> IO DistDirLayout
establishDummyDistDirLayout Verbosity
verbosity (ProjectConfig
globalConfig ProjectConfig -> ProjectConfig -> ProjectConfig
forall a. Semigroup a => a -> a -> a
<> ProjectConfig
cliConfig) ([Char] -> IO DistDirLayout) -> IO [Char] -> IO DistDirLayout
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [Char]
mkTmpDir
      ctx <- establishDummyProjectBaseContext verbosity (globalConfig <> cliConfig) distDirLayout [] cmd
      return (GlobalContext, ctx)

    scriptBaseCtx :: [Char] -> ProjectConfig -> IO ProjectBaseContext
scriptBaseCtx [Char]
script ProjectConfig
globalConfig = do
      let noDistDir :: ProjectConfig
noDistDir = ProjectConfig
forall a. Monoid a => a
mempty{projectConfigShared = mempty{projectConfigDistDir = Flag ""}}
      let cfg :: ProjectConfig
cfg = ProjectConfig
noDistDir ProjectConfig -> ProjectConfig -> ProjectConfig
forall a. Semigroup a => a -> a -> a
<> ProjectConfig
globalConfig ProjectConfig -> ProjectConfig -> ProjectConfig
forall a. Semigroup a => a -> a -> a
<> ProjectConfig
cliConfig
      rootDir <- Verbosity -> [Char] -> IO [Char]
ensureScriptCacheDirectory Verbosity
verbosity [Char]
script
      distDirLayout <- establishDummyDistDirLayout verbosity cfg rootDir
      establishDummyProjectBaseContext verbosity cfg distDirLayout [] cmd

    scriptOrError :: [Char]
-> [TargetSelectorProblem]
-> IO (TargetContext, ProjectBaseContext, [TargetSelector])
scriptOrError [Char]
script [TargetSelectorProblem]
err = do
      exists <- [Char] -> IO Bool
doesFileExist [Char]
script
      if exists
        then do
          ctx <- withGlobalConfig verbosity globalConfigFlag (scriptBaseCtx script)

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

          scriptContents <- BS.readFile script
          executable <- readExecutableBlockFromScript verbosity scriptContents

          httpTransport <-
            configureTransport
              verbosity
              (fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig)
              (flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig)

          projectCfgSkeleton <- readProjectBlockFromScript verbosity httpTransport (distDirLayout ctx) (takeFileName script) scriptContents

          createDirectoryIfMissingVerbose verbosity True (distProjectCacheDirectory $ distDirLayout ctx)
          (compiler, platform@(Platform arch os), _) <- runRebuild projectRoot $ configureCompiler verbosity (distDirLayout ctx) (fst (ignoreConditions projectCfgSkeleton) <> projectConfig ctx)

          projectCfg <- instantiateProjectConfigSkeletonFetchingCompiler (pure (os, arch, compilerInfo compiler)) mempty projectCfgSkeleton

          let ctx' = ProjectBaseContext
ctx ProjectBaseContext
-> (ProjectBaseContext -> ProjectBaseContext) -> ProjectBaseContext
forall a b. a -> (a -> b) -> b
& LensLike
  Identity
  ProjectBaseContext
  ProjectBaseContext
  ProjectConfig
  ProjectConfig
Lens' ProjectBaseContext ProjectConfig
lProjectConfig LensLike
  Identity
  ProjectBaseContext
  ProjectBaseContext
  ProjectConfig
  ProjectConfig
-> (ProjectConfig -> ProjectConfig)
-> ProjectBaseContext
-> ProjectBaseContext
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (ProjectConfig -> ProjectConfig -> ProjectConfig
forall a. Semigroup a => a -> a -> a
<> ProjectConfig
projectCfg)

              build_dir = DistDirLayout -> DistDirParams -> [Char]
distBuildDirectory (ProjectBaseContext -> DistDirLayout
distDirLayout ProjectBaseContext
ctx') (DistDirParams -> [Char]) -> DistDirParams -> [Char]
forall a b. (a -> b) -> a -> b
$ ([Char]
-> ProjectBaseContext -> Compiler -> Platform -> DistDirParams
scriptDistDirParams [Char]
script) ProjectBaseContext
ctx' Compiler
compiler Platform
platform
              exePath = [Char]
build_dir [Char] -> [Char] -> [Char]
</> [Char]
"bin" [Char] -> [Char] -> [Char]
</> [Char] -> [Char]
scriptExeFileName [Char]
script
              exePathRel = [Char] -> [Char] -> [Char]
makeRelative [Char]
projectRoot [Char]
exePath

              executable' =
                Executable
executable
                  Executable -> (Executable -> Executable) -> Executable
forall a b. a -> (a -> b) -> b
& LensLike Identity Executable Executable BuildInfo BuildInfo
forall a. HasBuildInfo a => Lens' a BuildInfo
Lens' Executable BuildInfo
L.buildInfo LensLike Identity Executable Executable BuildInfo BuildInfo
-> ((Maybe Language -> Identity (Maybe Language))
    -> BuildInfo -> Identity BuildInfo)
-> (Maybe Language -> Identity (Maybe Language))
-> Executable
-> Identity Executable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Language -> Identity (Maybe Language))
-> BuildInfo -> Identity BuildInfo
forall a. HasBuildInfo a => Lens' a (Maybe Language)
Lens' BuildInfo (Maybe Language)
L.defaultLanguage ((Maybe Language -> Identity (Maybe Language))
 -> Executable -> Identity Executable)
-> (Maybe Language -> Maybe Language) -> Executable -> Executable
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Maybe Language
-> (Language -> Maybe Language) -> Maybe Language -> Maybe Language
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Language -> Maybe Language
forall a. a -> Maybe a
Just Language
Haskell2010) Language -> Maybe Language
forall a. a -> Maybe a
Just
                  Executable -> (Executable -> Executable) -> Executable
forall a b. a -> (a -> b) -> b
& LensLike Identity Executable Executable BuildInfo BuildInfo
forall a. HasBuildInfo a => Lens' a BuildInfo
Lens' Executable BuildInfo
L.buildInfo LensLike Identity Executable Executable BuildInfo BuildInfo
-> ((PerCompilerFlavor [[Char]]
     -> Identity (PerCompilerFlavor [[Char]]))
    -> BuildInfo -> Identity BuildInfo)
-> (PerCompilerFlavor [[Char]]
    -> Identity (PerCompilerFlavor [[Char]]))
-> Executable
-> Identity Executable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PerCompilerFlavor [[Char]]
 -> Identity (PerCompilerFlavor [[Char]]))
-> BuildInfo -> Identity BuildInfo
forall a. HasBuildInfo a => Lens' a (PerCompilerFlavor [[Char]])
Lens' BuildInfo (PerCompilerFlavor [[Char]])
L.options ((PerCompilerFlavor [[Char]]
  -> Identity (PerCompilerFlavor [[Char]]))
 -> Executable -> Identity Executable)
-> (PerCompilerFlavor [[Char]] -> PerCompilerFlavor [[Char]])
-> Executable
-> Executable
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ([[Char]] -> [[Char]])
-> PerCompilerFlavor [[Char]] -> PerCompilerFlavor [[Char]]
forall a b. (a -> b) -> PerCompilerFlavor a -> PerCompilerFlavor b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char] -> [[Char]] -> [[Char]]
setExePath [Char]
exePathRel)

          createDirectoryIfMissingVerbose verbosity True (takeDirectory exePath)

          return (ScriptContext script executable', ctx', defaultTarget)
        else reportTargetSelectorProblems verbosity err

withTemporaryTempDirectory :: (IO FilePath -> IO a) -> IO a
withTemporaryTempDirectory :: forall a. (IO [Char] -> IO a) -> IO a
withTemporaryTempDirectory IO [Char] -> IO a
act = IO (MVar [Char])
forall a. IO (MVar a)
newEmptyMVar IO (MVar [Char]) -> (MVar [Char] -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \MVar [Char]
m -> IO (IO [Char])
-> (IO [Char] -> IO ()) -> (IO [Char] -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (MVar [Char] -> IO (IO [Char])
forall {m :: * -> *}. Monad m => MVar [Char] -> m (IO [Char])
getMkTmp MVar [Char]
m) (MVar [Char] -> IO [Char] -> IO ()
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 = IO [Char] -> m (IO [Char])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO [Char] -> m (IO [Char])) -> IO [Char] -> m (IO [Char])
forall a b. (a -> b) -> a -> b
$ do
      tmpDir <- IO [Char]
getTemporaryDirectory IO [Char] -> ([Char] -> IO [Char]) -> IO [Char]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([Char] -> [Char] -> IO [Char]) -> [Char] -> [Char] -> IO [Char]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Char] -> [Char] -> IO [Char]
createTempDirectory [Char]
"cabal-repl."
      putMVar m tmpDir
      return tmpDir
    rmTmp :: MVar [Char] -> p -> IO ()
rmTmp MVar [Char]
m p
_ = MVar [Char] -> IO (Maybe [Char])
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar [Char]
m IO (Maybe [Char]) -> (Maybe [Char] -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> ([Char] -> IO ()) -> Maybe [Char] -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (() -> IO () -> IO ()
forall a. a -> IO a -> IO a
handleDoesNotExist () (IO () -> IO ()) -> ([Char] -> IO ()) -> [Char] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ()
removeDirectoryRecursive)

scriptComponenetName :: IsString s => FilePath -> s
scriptComponenetName :: forall a. IsString a => [Char] -> a
scriptComponenetName [Char]
scriptPath = [Char] -> s
forall a. IsString a => [Char] -> a
fromString [Char]
cname
  where
    cname :: [Char]
cname = [Char]
"script-" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
censor ([Char] -> [Char]
takeFileName [Char]
scriptPath)
    censor :: Char -> Char
censor Char
c
      | Char
c Char -> Set Char -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Char
ccNamecore = Char
c
      | Bool
otherwise = Char
'_'

scriptExeFileName :: FilePath -> FilePath
scriptExeFileName :: [Char] -> [Char]
scriptExeFileName [Char]
scriptPath = [Char]
"cabal-script-" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
takeFileName [Char]
scriptPath

scriptDistDirParams :: FilePath -> ProjectBaseContext -> Compiler -> Platform -> DistDirParams
scriptDistDirParams :: [Char]
-> ProjectBaseContext -> Compiler -> Platform -> DistDirParams
scriptDistDirParams [Char]
scriptPath ProjectBaseContext
ctx Compiler
compiler Platform
platform =
  DistDirParams
    { distParamUnitId :: UnitId
distParamUnitId = ComponentId -> UnitId
newSimpleUnitId ComponentId
cid
    , distParamPackageId :: PackageId
distParamPackageId = PackageId
fakePackageId
    , distParamComponentId :: ComponentId
distParamComponentId = ComponentId
cid
    , distParamComponentName :: Maybe ComponentName
distParamComponentName = ComponentName -> Maybe ComponentName
forall a. a -> Maybe a
Just (ComponentName -> Maybe ComponentName)
-> ComponentName -> Maybe ComponentName
forall a b. (a -> b) -> a -> b
$ UnqualComponentName -> ComponentName
CExeName UnqualComponentName
cn
    , distParamCompilerId :: CompilerId
distParamCompilerId = Compiler -> CompilerId
compilerId Compiler
compiler
    , distParamPlatform :: Platform
distParamPlatform = Platform
platform
    , distParamOptimization :: OptimisationLevel
distParamOptimization = OptimisationLevel -> Flag OptimisationLevel -> OptimisationLevel
forall a. a -> Flag a -> a
fromFlagOrDefault OptimisationLevel
NormalOptimisation Flag OptimisationLevel
optimization
    }
  where
    cn :: UnqualComponentName
cn = [Char] -> UnqualComponentName
forall a. IsString a => [Char] -> a
scriptComponenetName [Char]
scriptPath
    cid :: ComponentId
cid = [Char] -> ComponentId
mkComponentId ([Char] -> ComponentId) -> [Char] -> ComponentId
forall a b. (a -> b) -> a -> b
$ PackageId -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow PackageId
fakePackageId [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"-inplace-" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> UnqualComponentName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow UnqualComponentName
cn
    optimization :: Flag OptimisationLevel
optimization = (PackageConfig -> Flag OptimisationLevel
packageConfigOptimization (PackageConfig -> Flag OptimisationLevel)
-> (ProjectBaseContext -> PackageConfig)
-> ProjectBaseContext
-> Flag OptimisationLevel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectConfig -> PackageConfig
projectConfigLocalPackages (ProjectConfig -> PackageConfig)
-> (ProjectBaseContext -> ProjectConfig)
-> ProjectBaseContext
-> PackageConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectBaseContext -> ProjectConfig
projectConfig) ProjectBaseContext
ctx

setExePath :: FilePath -> [String] -> [String]
setExePath :: [Char] -> [[Char]] -> [[Char]]
setExePath [Char]
exePath [[Char]]
options
  | [Char]
"-o" [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [[Char]]
options = [Char]
"-o" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [Char]
exePath [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
options
  | Bool
otherwise = [[Char]]
options

-- | Add the 'SourcePackage' to the context and use it to write a .cabal file.
updateContextAndWriteProjectFile' :: ProjectBaseContext -> SourcePackage (PackageLocation (Maybe FilePath)) -> IO ProjectBaseContext
updateContextAndWriteProjectFile' :: ProjectBaseContext
-> SourcePackage (PackageLocation (Maybe [Char]))
-> IO ProjectBaseContext
updateContextAndWriteProjectFile' ProjectBaseContext
ctx SourcePackage (PackageLocation (Maybe [Char]))
srcPkg = do
  let projectRoot :: [Char]
projectRoot = DistDirLayout -> [Char]
distProjectRootDirectory (DistDirLayout -> [Char]) -> DistDirLayout -> [Char]
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 (SourcePackage (PackageLocation (Maybe [Char]))
-> GenericPackageDescription
forall loc. SourcePackage loc -> GenericPackageDescription
srcpkgDescription SourcePackage (PackageLocation (Maybe [Char]))
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.
  packageFileExists <- [Char] -> IO Bool
doesFileExist [Char]
packageFile
  if packageFileExists
    then do
      cached <- force <$> readUTF8File packageFile
      when
        (cached /= contents)
        writePackageFile
    else writePackageFile
  return (ctx & lLocalPackages %~ (++ [SpecificSourcePackage 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 (DistDirLayout -> [Char]) -> DistDirLayout -> [Char]
forall a b. (a -> b) -> a -> b
$ ProjectBaseContext -> DistDirLayout
distDirLayout ProjectBaseContext
ctx

  absScript <- [Char] -> IO [Char]
canonicalizePath [Char]
scriptPath
  let
    sourcePackage =
      [Char] -> SourcePackage (PackageLocation loc)
forall loc. [Char] -> SourcePackage (PackageLocation loc)
fakeProjectSourcePackage [Char]
projectRoot
        SourcePackage (PackageLocation loc)
-> (SourcePackage (PackageLocation loc)
    -> SourcePackage (PackageLocation loc))
-> SourcePackage (PackageLocation loc)
forall a b. a -> (a -> b) -> b
& LensLike
  Identity
  (SourcePackage (PackageLocation loc))
  (SourcePackage (PackageLocation loc))
  GenericPackageDescription
  GenericPackageDescription
forall loc (f :: * -> *).
Functor f =>
LensLike
  f
  (SourcePackage loc)
  (SourcePackage loc)
  GenericPackageDescription
  GenericPackageDescription
lSrcpkgDescription LensLike
  Identity
  (SourcePackage (PackageLocation loc))
  (SourcePackage (PackageLocation loc))
  GenericPackageDescription
  GenericPackageDescription
-> (([(UnqualComponentName,
       CondTree ConfVar [Dependency] Executable)]
     -> Identity
          [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)])
    -> GenericPackageDescription -> Identity GenericPackageDescription)
-> ([(UnqualComponentName,
      CondTree ConfVar [Dependency] Executable)]
    -> Identity
         [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)])
-> SourcePackage (PackageLocation loc)
-> Identity (SourcePackage (PackageLocation loc))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(UnqualComponentName, CondTree ConfVar [Dependency] Executable)]
 -> Identity
      [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)])
-> GenericPackageDescription -> Identity GenericPackageDescription
Lens'
  GenericPackageDescription
  [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)]
L.condExecutables
          (([(UnqualComponentName, CondTree ConfVar [Dependency] Executable)]
  -> Identity
       [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)])
 -> SourcePackage (PackageLocation loc)
 -> Identity (SourcePackage (PackageLocation loc)))
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] Executable)]
-> SourcePackage (PackageLocation loc)
-> SourcePackage (PackageLocation loc)
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [([Char] -> UnqualComponentName
forall a. IsString a => [Char] -> a
scriptComponenetName [Char]
scriptPath, Executable
-> [Dependency]
-> [CondBranch ConfVar [Dependency] Executable]
-> CondTree ConfVar [Dependency] Executable
forall v c a. a -> c -> [CondBranch v c a] -> CondTree v c a
CondNode Executable
executable (BuildInfo -> [Dependency]
targetBuildDepends (BuildInfo -> [Dependency]) -> BuildInfo -> [Dependency]
forall a b. (a -> b) -> a -> b
$ Executable -> BuildInfo
buildInfo Executable
executable) [])]
    executable =
      Executable
scriptExecutable
        Executable -> (Executable -> Executable) -> Executable
forall a b. a -> (a -> b) -> b
& LensLike Identity Executable Executable [Char] [Char]
Lens' Executable [Char]
L.modulePath LensLike Identity Executable Executable [Char] [Char]
-> [Char] -> Executable -> Executable
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Char]
absScript

  updateContextAndWriteProjectFile' ctx 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]
_) = [Field Position] -> (Fields Position, [Field Position])
forall ann. [Field ann] -> (Fields ann, [Field ann])
takeFields [Field Position]
fs
      CabalSpecVersion
-> Fields Position
-> ParsecFieldGrammar Executable Executable
-> ParseResult Executable
forall s a.
CabalSpecVersion
-> Fields Position -> ParsecFieldGrammar s a -> ParseResult a
parseFieldGrammar CabalSpecVersion
cabalSpecLatest Fields Position
fields (UnqualComponentName -> ParsecFieldGrammar Executable Executable
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 -> Position -> [Char] -> ParseResult Executable
forall a. Position -> [Char] -> ParseResult a
parseFatalFailure Position
pos (ParseError -> [Char]
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 = (ByteString -> ParseResult Executable)
-> Verbosity -> [Char] -> ByteString -> IO Executable
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
  str' <- case ByteString -> ByteString -> Either [Char] ByteString
extractScriptBlock ByteString
"cabal" ByteString
str of
    Left [Char]
e -> Verbosity -> CabalInstallException -> IO ByteString
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ByteString)
-> CabalInstallException -> IO ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> CabalInstallException
FailedExtractingScriptBlock [Char]
e
    Right ByteString
x -> ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
x
  when (BS.all isSpace str') $ warn verbosity "Empty script block"
  readScriptBlock verbosity 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 :: [Char]
distDownloadSrcDirectory :: DistDirLayout -> [Char]
distDownloadSrcDirectory} [Char]
scriptName ByteString
str = do
  case ByteString -> ByteString -> Either [Char] ByteString
extractScriptBlock ByteString
"project" ByteString
str of
    Left [Char]
_ -> ProjectConfigSkeleton -> IO ProjectConfigSkeleton
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ProjectConfigSkeleton
forall a. Monoid a => a
mempty
    Right ByteString
x ->
      Verbosity
-> [Char]
-> [Char]
-> ParseResult ProjectConfigSkeleton
-> IO ProjectConfigSkeleton
reportParseResult Verbosity
verbosity [Char]
"script" [Char]
scriptName
        (ParseResult ProjectConfigSkeleton -> IO ProjectConfigSkeleton)
-> IO (ParseResult ProjectConfigSkeleton)
-> IO ProjectConfigSkeleton
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char]
-> [Char]
-> HttpTransport
-> Verbosity
-> ProjectConfigToParse
-> IO (ParseResult ProjectConfigSkeleton)
parseProject [Char]
scriptName [Char]
distDownloadSrcDirectory HttpTransport
httpTransport Verbosity
verbosity (ByteString -> ProjectConfigToParse
ProjectConfigToParse 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 = (ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
startMarker) (ByteString -> Bool)
-> (ByteString -> ByteString) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
stripTrailSpace
    isEndMarker :: ByteString -> Bool
isEndMarker = (ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
endMarker) (ByteString -> Bool)
-> (ByteString -> ByteString) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
stripTrailSpace

    stripTrailSpace :: ByteString -> ByteString
stripTrailSpace = (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, ByteString) -> ByteString)
-> (ByteString -> (ByteString, ByteString))
-> ByteString
-> ByteString
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 (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (ByteString -> Bool) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bool
isStartMarker) [ByteString]
ls of
      [] -> [Char] -> Either [Char] ByteString
forall a b. a -> Either a b
Left ([Char] -> Either [Char] ByteString)
-> [Char] -> Either [Char] ByteString
forall a b. (a -> b) -> a -> b
$ [Char]
"`" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
BS.unpack ByteString
startMarker [Char] -> [Char] -> [Char]
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]
_ [] = [Char] -> Either [Char] ByteString
forall a b. a -> Either a b
Left ([Char] -> Either [Char] ByteString)
-> [Char] -> Either [Char] ByteString
forall a b. (a -> b) -> a -> b
$ [Char]
"`" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
BS.unpack ByteString
endMarker [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"` end marker not found"
    goBody [ByteString]
acc (ByteString
l : [ByteString]
ls)
      | ByteString -> Bool
isEndMarker ByteString
l = ByteString -> Either [Char] ByteString
forall a b. b -> Either a b
Right (ByteString -> Either [Char] ByteString)
-> ByteString -> Either [Char] ByteString
forall a b. (a -> b) -> a -> b
$! [ByteString] -> ByteString
BS.unlines ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse [ByteString]
acc
      | Bool
otherwise = [ByteString] -> [ByteString] -> Either [Char] ByteString
goBody (ByteString
l ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
acc) [ByteString]
ls

    startMarker, endMarker :: BS.ByteString
    startMarker :: ByteString
startMarker = ByteString
"{- " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
header ByteString -> ByteString -> ByteString
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 = SourcePackage (PackageLocation loc)
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 = [Char] -> PackageLocation local
forall local. [Char] -> PackageLocation local
LocalUnpackedPackage [Char]
projectRoot
        , srcpkgDescrOverride :: PackageDescriptionOverride
srcpkgDescrOverride = PackageDescriptionOverride
forall a. Maybe a
Nothing
        }
    genericPackageDescription :: GenericPackageDescription
genericPackageDescription =
      GenericPackageDescription
emptyGenericPackageDescription
        { GPD.packageDescription = packageDescription
        }
    packageDescription :: PackageDescription
packageDescription =
      PackageDescription
emptyPackageDescription
        { package = fakePackageId
        , specVersion = CabalSpecV2_2
        , licenseRaw = Left SPDX.NONE
        }

-- | Find the path of an exe that has been relocated with a "-o" option
movedExePath :: UnqualComponentName -> DistDirLayout -> ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> Maybe FilePath
movedExePath :: UnqualComponentName
-> DistDirLayout
-> ElaboratedSharedConfig
-> ElaboratedConfiguredPackage
-> Maybe [Char]
movedExePath UnqualComponentName
selectedComponent DistDirLayout
distDirLayout ElaboratedSharedConfig
elabShared ElaboratedConfiguredPackage
elabConfigured = do
  exe <- (Executable -> Bool) -> [Executable] -> Maybe Executable
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((UnqualComponentName -> UnqualComponentName -> Bool
forall a. Eq a => a -> a -> Bool
== UnqualComponentName
selectedComponent) (UnqualComponentName -> Bool)
-> (Executable -> UnqualComponentName) -> Executable -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Executable -> UnqualComponentName
exeName) ([Executable] -> Maybe Executable)
-> (PackageDescription -> [Executable])
-> PackageDescription
-> Maybe Executable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageDescription -> [Executable]
executables (PackageDescription -> Maybe Executable)
-> PackageDescription -> Maybe Executable
forall a b. (a -> b) -> a -> b
$ ElaboratedConfiguredPackage -> PackageDescription
elabPkgDescription ElaboratedConfiguredPackage
elabConfigured
  let CompilerId flavor _ = (compilerId . pkgConfigCompiler) elabShared
  opts <- lookup flavor (perCompilerFlavorToList . options $ buildInfo exe)
  let projectRoot = DistDirLayout -> [Char]
distProjectRootDirectory DistDirLayout
distDirLayout
  fmap (projectRoot </>) . lookup "-o" $ reverse (zip opts (drop 1 opts))

-- Lenses

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

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

lProjectConfig :: Lens' ProjectBaseContext ProjectConfig
lProjectConfig :: Lens' ProjectBaseContext ProjectConfig
lProjectConfig ProjectConfig -> f ProjectConfig
f ProjectBaseContext
s = (ProjectConfig -> ProjectBaseContext)
-> f ProjectConfig -> f ProjectBaseContext
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ProjectConfig
x -> ProjectBaseContext
s{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 = [Char] -> Set Char
forall a. Ord a => [a] -> Set a
S.fromList [Char]
" "
ccCtrlchar :: Set Char
ccCtrlchar = [Char] -> Set Char
forall a. Ord a => [a] -> Set a
S.fromList ([Char] -> Set Char) -> [Char] -> Set Char
forall a b. (a -> b) -> a -> b
$ [Int -> Char
chr Int
0x0 .. Int -> Char
chr Int
0x1f] [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Int -> Char
chr Int
0x7f]
ccPrintable :: Set Char
ccPrintable = [Char] -> Set Char
forall a. Ord a => [a] -> Set a
S.fromList [Int -> Char
chr Int
0x0 .. Int -> Char
chr Int
0xff] Set Char -> Set Char -> Set Char
forall a. Ord a => Set a -> Set a -> Set a
S.\\ Set Char
ccCtrlchar
ccSymbol' :: Set Char
ccSymbol' = [Char] -> Set Char
forall a. Ord a => [a] -> Set a
S.fromList [Char]
",=<>+*&|!$%^@#?/\\~"
ccParen :: Set Char
ccParen = [Char] -> Set Char
forall a. Ord a => [a] -> Set a
S.fromList [Char]
"()[]"
ccNamecore :: Set Char
ccNamecore = Set Char
ccPrintable Set Char -> Set Char -> Set Char
forall a. Ord a => Set a -> Set a -> Set a
S.\\ [Set Char] -> Set Char
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions [Set Char
ccSpace, [Char] -> Set Char
forall a. Ord a => [a] -> Set a
S.fromList [Char]
":\"{}", Set Char
ccParen, Set Char
ccSymbol']