{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# 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
  ( 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 (..)
  )
import Distribution.Simple.Flag
  ( flagToMaybe
  , fromFlagOrDefault
  )
import Distribution.Simple.PackageDescription
  ( parseString
  )
import Distribution.Simple.Setup
  ( pattern 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 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 Distribution.Utils.Path
  ( unsafeMakeSymbolicPath
  )
import System.Directory
  ( canonicalizePath
  , doesFileExist
  , getTemporaryDirectory
  , removeDirectoryRecursive
  )
import System.FilePath
  ( makeRelative
  , normalise
  , 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
  :: Verbosity
  -> 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.
Verbosity
-> AcceptNoTargets
-> Maybe ComponentKind
-> NixStyleFlags a
-> [[Char]]
-> GlobalFlags
-> CurrentCommand
-> (TargetContext
    -> ProjectBaseContext -> [TargetSelector] -> IO b)
-> IO b
withContextAndSelectors Verbosity
verbosity AcceptNoTargets
noTargets Maybe ComponentKind
kind flags :: NixStyleFlags a
flags@NixStyleFlags{a
TestFlags
HaddockFlags
ConfigFlags
BenchmarkFlags
ProjectFlags
ConfigExFlags
InstallFlags
configFlags :: ConfigFlags
configExFlags :: ConfigExFlags
installFlags :: InstallFlags
haddockFlags :: HaddockFlags
testFlags :: TestFlags
benchmarkFlags :: BenchmarkFlags
projectFlags :: ProjectFlags
extraFlags :: a
benchmarkFlags :: forall a. NixStyleFlags a -> BenchmarkFlags
configExFlags :: forall a. NixStyleFlags a -> ConfigExFlags
configFlags :: forall a. NixStyleFlags a -> ConfigFlags
extraFlags :: forall a. NixStyleFlags a -> a
haddockFlags :: forall a. NixStyleFlags a -> HaddockFlags
installFlags :: forall a. NixStyleFlags a -> InstallFlags
projectFlags :: forall a. NixStyleFlags a -> ProjectFlags
testFlags :: forall a. NixStyleFlags a -> TestFlags
..} [[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, [])
          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, [])
            | ([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
    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, 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] -> [Char]
normalise [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
      tmpBaseDir <- IO [Char]
getTemporaryDirectory
      tmpRelDir <- createTempDirectory tmpBaseDir "cabal-repl."
      let tmpDir = [Char]
tmpBaseDir [Char] -> [Char] -> [Char]
</> [Char]
tmpRelDir
      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)

scriptComponentName :: IsString s => FilePath -> s
scriptComponentName :: forall a. IsString a => [Char] -> a
scriptComponentName [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
scriptComponentName [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 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] -> SymbolicPathX 'OnlyRelative Source 'File
forall (allowAbs :: AllowAbsolute) from (to :: FileOrDir).
[Char] -> SymbolicPathX allowAbs from to
unsafeMakeSymbolicPath ([Char] -> SymbolicPathX 'OnlyRelative Source 'File)
-> ([Char] -> [Char])
-> [Char]
-> SymbolicPathX 'OnlyRelative Source 'File
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [Char]
makeRelative ([Char] -> [Char]
normalise [Char]
projectRoot) ([Char] -> SymbolicPathX 'OnlyRelative Source 'File)
-> IO [Char] -> IO (SymbolicPathX 'OnlyRelative Source 'File)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [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
scriptComponentName [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
  (SymbolicPathX 'OnlyRelative Source 'File)
  (SymbolicPathX 'OnlyRelative Source 'File)
Lens' Executable (SymbolicPathX 'OnlyRelative Source 'File)
L.modulePath LensLike
  Identity
  Executable
  Executable
  (SymbolicPathX 'OnlyRelative Source 'File)
  (SymbolicPathX 'OnlyRelative Source 'File)
-> SymbolicPathX 'OnlyRelative Source 'File
-> Executable
-> Executable
forall s t a b. ASetter s t a b -> b -> s -> t
.~ SymbolicPathX 'OnlyRelative Source 'File
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 Token [Char]),
 forall from (to :: FileOrDir).
 c (List FSep (SymbolicPathNT from to) (SymbolicPath from to)),
 forall from (to :: FileOrDir).
 c (List FSep (RelativePathNT from to) (RelativePath from to)),
 forall from (to :: FileOrDir).
 c (List FSep (SymbolicPathNT from to) (SymbolicPath from to)),
 forall from (to :: FileOrDir).
 c (List FSep (RelativePathNT from to) (RelativePath from to)),
 forall from (to :: FileOrDir).
 c (List VCat (SymbolicPathNT from to) (SymbolicPath from to)),
 forall from (to :: FileOrDir). c (SymbolicPathNT from to),
 forall from (to :: FileOrDir). c (RelativePathNT from to),
 c (List NoCommaFSep Token' [Char]),
 c (List VCat (MQuoted ModuleName) ModuleName),
 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]
-> ProjectParseResult ProjectConfigSkeleton
-> IO ProjectConfigSkeleton
reportParseResult Verbosity
verbosity [Char]
"script" [Char]
scriptName
        (ProjectParseResult ProjectConfigSkeleton
 -> IO ProjectConfigSkeleton)
-> IO (ProjectParseResult ProjectConfigSkeleton)
-> IO ProjectConfigSkeleton
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char]
-> [Char]
-> HttpTransport
-> Verbosity
-> ProjectConfigToParse
-> IO (ProjectParseResult 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']