{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Distribution.Client.ScriptUtils (
getScriptCacheDirectoryRoot, getScriptHash, getScriptCacheDirectory, ensureScriptCacheDirectory,
withContextAndSelectors, AcceptNoTargets(..), TargetContext(..),
updateContextAndWriteProjectFile, updateContextAndWriteProjectFile',
fakeProjectSourcePackage, lSrcpkgDescription
) where
import Prelude ()
import Distribution.Client.Compat.Prelude hiding (toList)
import Distribution.Compat.Lens
import qualified Distribution.Types.Lens as L
import Distribution.CabalSpecVersion
( CabalSpecVersion (..), cabalSpecLatest)
import Distribution.Client.ProjectOrchestration
import Distribution.Client.Config
( getCabalDir )
import Distribution.Client.DistDirLayout
( DistDirLayout(..) )
import Distribution.Client.HashValue
( hashValue, showHashValue )
import Distribution.Client.HttpUtils
( HttpTransport, configureTransport )
import Distribution.Client.NixStyleOptions
( NixStyleFlags (..) )
import Distribution.Client.ProjectConfig
( ProjectConfig(..), ProjectConfigShared(..)
, reportParseResult, withProjectOrGlobalConfig
, projectConfigHttpTransport )
import Distribution.Client.ProjectConfig.Legacy
( ProjectConfigSkeleton
, parseProjectSkeleton, instantiateProjectConfigSkeleton )
import Distribution.Client.ProjectFlags
( flagIgnoreProject )
import Distribution.Client.RebuildMonad
( runRebuild )
import Distribution.Client.Setup
( ConfigFlags(..), GlobalFlags(..) )
import Distribution.Client.TargetSelector
( TargetSelectorProblem(..), TargetString(..) )
import Distribution.Client.Types
( PackageLocation(..), PackageSpecifier(..), UnresolvedSourcePackage )
import Distribution.FieldGrammar
( parseFieldGrammar, takeFields )
import Distribution.Fields
( ParseResult, parseFatalFailure, readFields )
import Distribution.PackageDescription
( ignoreConditions )
import Distribution.PackageDescription.FieldGrammar
( executableFieldGrammar )
import Distribution.PackageDescription.PrettyPrint
( showGenericPackageDescription )
import Distribution.Parsec
( Position(..) )
import Distribution.Simple.Flag
( fromFlagOrDefault, flagToMaybe )
import Distribution.Simple.PackageDescription
( parseString )
import Distribution.Simple.Setup
( Flag(..) )
import Distribution.Simple.Compiler
( compilerInfo )
import Distribution.Simple.Utils
( createDirectoryIfMissingVerbose, createTempDirectory, die', handleDoesNotExist, readUTF8File, warn, writeUTF8File )
import qualified Distribution.SPDX.License as SPDX
import Distribution.Solver.Types.SourcePackage as SP
( SourcePackage(..) )
import Distribution.System
( Platform(..) )
import Distribution.Types.BuildInfo
( BuildInfo(..) )
import Distribution.Types.CondTree
( CondTree(..) )
import Distribution.Types.Executable
( Executable(..) )
import Distribution.Types.GenericPackageDescription as GPD
( GenericPackageDescription(..), emptyGenericPackageDescription )
import Distribution.Types.PackageDescription
( PackageDescription(..), emptyPackageDescription )
import Distribution.Types.PackageName.Magic
( fakePackageCabalFileName, fakePackageId )
import Distribution.Utils.NubList
( fromNubList )
import Distribution.Client.ProjectPlanning
( configureCompiler )
import Distribution.Verbosity
( normal )
import Language.Haskell.Extension
( Language(..) )
import Control.Concurrent.MVar
( newEmptyMVar, putMVar, tryTakeMVar )
import Control.Exception
( bracket )
import qualified Data.ByteString.Char8 as BS
import Data.ByteString.Lazy ()
import qualified Data.Set as S
import System.Directory
( canonicalizePath, doesFileExist, getTemporaryDirectory, removeDirectoryRecursive )
import System.FilePath
( (</>), takeFileName )
import qualified Text.Parsec as P
getScriptCacheDirectoryRoot :: IO FilePath
getScriptCacheDirectoryRoot :: IO FilePath
getScriptCacheDirectoryRoot = do
FilePath
cabalDir <- IO FilePath
getCabalDir
FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
cabalDir FilePath -> FilePath -> FilePath
</> FilePath
"script-builds"
getScriptHash :: FilePath -> IO String
getScriptHash :: FilePath -> IO FilePath
getScriptHash FilePath
script = HashValue -> FilePath
showHashValue (HashValue -> FilePath)
-> (FilePath -> HashValue) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> HashValue
hashValue (ByteString -> HashValue)
-> (FilePath -> ByteString) -> FilePath -> HashValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ByteString
forall a. IsString a => FilePath -> a
fromString (FilePath -> FilePath) -> IO FilePath -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO FilePath
canonicalizePath FilePath
script
getScriptCacheDirectory :: FilePath -> IO FilePath
getScriptCacheDirectory :: FilePath -> IO FilePath
getScriptCacheDirectory FilePath
script = FilePath -> FilePath -> FilePath
(</>) (FilePath -> FilePath -> FilePath)
-> IO FilePath -> IO (FilePath -> FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO FilePath
getScriptCacheDirectoryRoot IO (FilePath -> FilePath) -> IO FilePath -> IO FilePath
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FilePath -> IO FilePath
getScriptHash FilePath
script
ensureScriptCacheDirectory :: Verbosity -> FilePath -> IO FilePath
ensureScriptCacheDirectory :: Verbosity -> FilePath -> IO FilePath
ensureScriptCacheDirectory Verbosity
verbosity FilePath
script = do
FilePath
cacheDir <- FilePath -> IO FilePath
getScriptCacheDirectory FilePath
script
Verbosity -> Bool -> FilePath -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True FilePath
cacheDir
FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
cacheDir
data AcceptNoTargets
= RejectNoTargets
| AcceptNoTargets
deriving (AcceptNoTargets -> AcceptNoTargets -> Bool
(AcceptNoTargets -> AcceptNoTargets -> Bool)
-> (AcceptNoTargets -> AcceptNoTargets -> Bool)
-> Eq AcceptNoTargets
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AcceptNoTargets -> AcceptNoTargets -> Bool
$c/= :: AcceptNoTargets -> AcceptNoTargets -> Bool
== :: AcceptNoTargets -> AcceptNoTargets -> Bool
$c== :: AcceptNoTargets -> AcceptNoTargets -> Bool
Eq, Int -> AcceptNoTargets -> FilePath -> FilePath
[AcceptNoTargets] -> FilePath -> FilePath
AcceptNoTargets -> FilePath
(Int -> AcceptNoTargets -> FilePath -> FilePath)
-> (AcceptNoTargets -> FilePath)
-> ([AcceptNoTargets] -> FilePath -> FilePath)
-> Show AcceptNoTargets
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [AcceptNoTargets] -> FilePath -> FilePath
$cshowList :: [AcceptNoTargets] -> FilePath -> FilePath
show :: AcceptNoTargets -> FilePath
$cshow :: AcceptNoTargets -> FilePath
showsPrec :: Int -> AcceptNoTargets -> FilePath -> FilePath
$cshowsPrec :: Int -> AcceptNoTargets -> FilePath -> FilePath
Show)
data TargetContext
= ProjectContext
| GlobalContext
| 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
/= :: TargetContext -> TargetContext -> Bool
$c/= :: TargetContext -> TargetContext -> Bool
== :: TargetContext -> TargetContext -> Bool
$c== :: TargetContext -> TargetContext -> Bool
Eq, Int -> TargetContext -> FilePath -> FilePath
[TargetContext] -> FilePath -> FilePath
TargetContext -> FilePath
(Int -> TargetContext -> FilePath -> FilePath)
-> (TargetContext -> FilePath)
-> ([TargetContext] -> FilePath -> FilePath)
-> Show TargetContext
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [TargetContext] -> FilePath -> FilePath
$cshowList :: [TargetContext] -> FilePath -> FilePath
show :: TargetContext -> FilePath
$cshow :: TargetContext -> FilePath
showsPrec :: Int -> TargetContext -> FilePath -> FilePath
$cshowsPrec :: Int -> TargetContext -> FilePath -> FilePath
Show)
withContextAndSelectors
:: AcceptNoTargets
-> Maybe ComponentKind
-> NixStyleFlags a
-> [String]
-> GlobalFlags
-> (TargetContext -> ProjectBaseContext -> [TargetSelector] -> IO b)
-> IO b
withContextAndSelectors :: AcceptNoTargets
-> Maybe ComponentKind
-> NixStyleFlags a
-> [FilePath]
-> GlobalFlags
-> (TargetContext
-> ProjectBaseContext -> [TargetSelector] -> IO b)
-> IO b
withContextAndSelectors AcceptNoTargets
noTargets Maybe ComponentKind
kind flags :: NixStyleFlags a
flags@NixStyleFlags {a
ConfigFlags
HaddockFlags
TestFlags
BenchmarkFlags
ProjectFlags
InstallFlags
ConfigExFlags
extraFlags :: forall a. NixStyleFlags a -> a
projectFlags :: forall a. NixStyleFlags a -> ProjectFlags
benchmarkFlags :: forall a. NixStyleFlags a -> BenchmarkFlags
testFlags :: forall a. NixStyleFlags a -> TestFlags
haddockFlags :: forall a. NixStyleFlags a -> HaddockFlags
installFlags :: forall a. NixStyleFlags a -> InstallFlags
configExFlags :: forall a. NixStyleFlags a -> ConfigExFlags
configFlags :: forall a. NixStyleFlags a -> ConfigFlags
extraFlags :: a
projectFlags :: ProjectFlags
benchmarkFlags :: BenchmarkFlags
testFlags :: TestFlags
haddockFlags :: HaddockFlags
installFlags :: InstallFlags
configExFlags :: ConfigExFlags
configFlags :: ConfigFlags
..} [FilePath]
targetStrings GlobalFlags
globalFlags TargetContext -> ProjectBaseContext -> [TargetSelector] -> IO b
act
= (IO FilePath -> IO b) -> IO b
forall a. (IO FilePath -> IO a) -> IO a
withTemporaryTempDirectory ((IO FilePath -> IO b) -> IO b) -> (IO FilePath -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \IO FilePath
mkTmpDir -> do
(TargetContext
tc, ProjectBaseContext
ctx) <- Verbosity
-> Flag Bool
-> Flag FilePath
-> IO (TargetContext, ProjectBaseContext)
-> (ProjectConfig -> IO (TargetContext, ProjectBaseContext))
-> IO (TargetContext, ProjectBaseContext)
forall a.
Verbosity
-> Flag Bool
-> Flag FilePath
-> IO a
-> (ProjectConfig -> IO a)
-> IO a
withProjectOrGlobalConfig Verbosity
verbosity Flag Bool
ignoreProject Flag FilePath
globalConfigFlag IO (TargetContext, ProjectBaseContext)
with (IO FilePath
-> ProjectConfig -> IO (TargetContext, ProjectBaseContext)
without IO FilePath
mkTmpDir)
(TargetContext
tc', ProjectBaseContext
ctx', [TargetSelector]
sels) <- case [FilePath]
targetStrings of
[FilePath
target] | (Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Char
c -> Char -> Bool
isSpace Char
c) FilePath
target Bool -> Bool -> Bool
|| FilePath
":" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FilePath
target -> do
FilePath
-> [TargetSelectorProblem]
-> IO (TargetContext, ProjectBaseContext, [TargetSelector])
scriptOrError FilePath
target [TargetString -> TargetSelectorProblem
TargetSelectorNoScript (TargetString -> TargetSelectorProblem)
-> TargetString -> TargetSelectorProblem
forall a b. (a -> b) -> a -> b
$ FilePath -> TargetString
TargetString1 FilePath
target]
[FilePath]
_ -> do
[PackageSpecifier
(SourcePackage (PackageLocation (Maybe FilePath)))]
-> Maybe ComponentKind
-> [FilePath]
-> IO (Either [TargetSelectorProblem] [TargetSelector])
forall a.
[PackageSpecifier (SourcePackage (PackageLocation a))]
-> Maybe ComponentKind
-> [FilePath]
-> IO (Either [TargetSelectorProblem] [TargetSelector])
readTargetSelectors (ProjectBaseContext
-> [PackageSpecifier
(SourcePackage (PackageLocation (Maybe FilePath)))]
localPackages ProjectBaseContext
ctx) Maybe ComponentKind
kind [FilePath]
targetStrings IO (Either [TargetSelectorProblem] [TargetSelector])
-> (Either [TargetSelectorProblem] [TargetSelector]
-> IO (TargetContext, ProjectBaseContext, [TargetSelector]))
-> IO (TargetContext, ProjectBaseContext, [TargetSelector])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left err :: [TargetSelectorProblem]
err@(TargetSelectorProblem
TargetSelectorNoTargetsInProject:[TargetSelectorProblem]
_)
| [] <- [FilePath]
targetStrings
, AcceptNoTargets
AcceptNoTargets <- AcceptNoTargets
noTargets -> (TargetContext, ProjectBaseContext, [TargetSelector])
-> IO (TargetContext, ProjectBaseContext, [TargetSelector])
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetContext
tc, ProjectBaseContext
ctx, [TargetSelector]
defaultTarget)
| (FilePath
script:[FilePath]
_) <- [FilePath]
targetStrings -> FilePath
-> [TargetSelectorProblem]
-> IO (TargetContext, ProjectBaseContext, [TargetSelector])
scriptOrError FilePath
script [TargetSelectorProblem]
err
Left err :: [TargetSelectorProblem]
err@(TargetSelectorNoSuch TargetString
t [(Maybe (FilePath, FilePath), FilePath, FilePath, [FilePath])]
_:[TargetSelectorProblem]
_)
| TargetString1 FilePath
script <- TargetString
t -> FilePath
-> [TargetSelectorProblem]
-> IO (TargetContext, ProjectBaseContext, [TargetSelector])
scriptOrError FilePath
script [TargetSelectorProblem]
err
Left err :: [TargetSelectorProblem]
err@(TargetSelectorExpected TargetString
t [FilePath]
_ FilePath
_:[TargetSelectorProblem]
_)
| TargetString1 FilePath
script <- TargetString
t -> FilePath
-> [TargetSelectorProblem]
-> IO (TargetContext, ProjectBaseContext, [TargetSelector])
scriptOrError FilePath
script [TargetSelectorProblem]
err
Left err :: [TargetSelectorProblem]
err@(MatchingInternalError TargetString
_ TargetSelector
_ [(TargetString, [TargetSelector])]
_:[TargetSelectorProblem]
_)
| [FilePath
script] <- [FilePath]
targetStrings -> FilePath
-> [TargetSelectorProblem]
-> IO (TargetContext, ProjectBaseContext, [TargetSelector])
scriptOrError FilePath
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 (m :: * -> *) a. Monad m => a -> m a
return (TargetContext
tc, ProjectBaseContext
ctx, [TargetSelector]
sels)
TargetContext -> ProjectBaseContext -> [TargetSelector] -> IO b
act TargetContext
tc' ProjectBaseContext
ctx' [TargetSelector]
sels
where
verbosity :: Verbosity
verbosity = 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 FilePath
globalConfigFlag = ProjectConfigShared -> Flag FilePath
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]
with :: IO (TargetContext, ProjectBaseContext)
with = do
ProjectBaseContext
ctx <- Verbosity
-> ProjectConfig -> CurrentCommand -> IO ProjectBaseContext
establishProjectBaseContext Verbosity
verbosity ProjectConfig
cliConfig CurrentCommand
OtherCommand
(TargetContext, ProjectBaseContext)
-> IO (TargetContext, ProjectBaseContext)
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetContext
ProjectContext, ProjectBaseContext
ctx)
without :: IO FilePath
-> ProjectConfig -> IO (TargetContext, ProjectBaseContext)
without IO FilePath
mkDir ProjectConfig
globalConfig = do
DistDirLayout
distDirLayout <- Verbosity -> ProjectConfig -> FilePath -> IO DistDirLayout
establishDummyDistDirLayout Verbosity
verbosity (ProjectConfig
globalConfig ProjectConfig -> ProjectConfig -> ProjectConfig
forall a. Semigroup a => a -> a -> a
<> ProjectConfig
cliConfig) (FilePath -> IO DistDirLayout) -> IO FilePath -> IO DistDirLayout
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO FilePath
mkDir
ProjectBaseContext
ctx <- Verbosity
-> ProjectConfig
-> DistDirLayout
-> [PackageSpecifier
(SourcePackage (PackageLocation (Maybe FilePath)))]
-> CurrentCommand
-> IO ProjectBaseContext
establishDummyProjectBaseContext Verbosity
verbosity (ProjectConfig
globalConfig ProjectConfig -> ProjectConfig -> ProjectConfig
forall a. Semigroup a => a -> a -> a
<> ProjectConfig
cliConfig) DistDirLayout
distDirLayout [] CurrentCommand
OtherCommand
(TargetContext, ProjectBaseContext)
-> IO (TargetContext, ProjectBaseContext)
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetContext
GlobalContext, ProjectBaseContext
ctx)
scriptOrError :: FilePath
-> [TargetSelectorProblem]
-> IO (TargetContext, ProjectBaseContext, [TargetSelector])
scriptOrError FilePath
script [TargetSelectorProblem]
err = do
Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
script
if Bool
exists then do
let mkCacheDir :: IO FilePath
mkCacheDir = Verbosity -> FilePath -> IO FilePath
ensureScriptCacheDirectory Verbosity
verbosity FilePath
script
(TargetContext
_, ProjectBaseContext
ctx) <- Verbosity
-> Flag Bool
-> Flag FilePath
-> IO (TargetContext, ProjectBaseContext)
-> (ProjectConfig -> IO (TargetContext, ProjectBaseContext))
-> IO (TargetContext, ProjectBaseContext)
forall a.
Verbosity
-> Flag Bool
-> Flag FilePath
-> IO a
-> (ProjectConfig -> IO a)
-> IO a
withProjectOrGlobalConfig Verbosity
verbosity (Bool -> Flag Bool
forall a. a -> Flag a
Flag Bool
True) Flag FilePath
globalConfigFlag IO (TargetContext, ProjectBaseContext)
with (IO FilePath
-> ProjectConfig -> IO (TargetContext, ProjectBaseContext)
without IO FilePath
mkCacheDir)
let projectRoot :: FilePath
projectRoot = DistDirLayout -> FilePath
distProjectRootDirectory (DistDirLayout -> FilePath) -> DistDirLayout -> FilePath
forall a b. (a -> b) -> a -> b
$ ProjectBaseContext -> DistDirLayout
distDirLayout ProjectBaseContext
ctx
FilePath -> FilePath -> IO ()
writeFile (FilePath
projectRoot FilePath -> FilePath -> FilePath
</> FilePath
"scriptlocation") (FilePath -> IO ()) -> IO FilePath -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO FilePath
canonicalizePath FilePath
script
ByteString
scriptContents <- FilePath -> IO ByteString
BS.readFile FilePath
script
Executable
executable <- Verbosity -> ByteString -> IO Executable
readExecutableBlockFromScript Verbosity
verbosity ByteString
scriptContents
HttpTransport
httpTransport <- Verbosity -> [FilePath] -> Maybe FilePath -> IO HttpTransport
configureTransport Verbosity
verbosity
(NubList FilePath -> [FilePath]
forall a. NubList a -> [a]
fromNubList (NubList FilePath -> [FilePath])
-> (ProjectConfigShared -> NubList FilePath)
-> ProjectConfigShared
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectConfigShared -> NubList FilePath
projectConfigProgPathExtra (ProjectConfigShared -> [FilePath])
-> ProjectConfigShared -> [FilePath]
forall a b. (a -> b) -> a -> b
$ ProjectConfig -> ProjectConfigShared
projectConfigShared ProjectConfig
cliConfig)
(Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe (Flag FilePath -> Maybe FilePath)
-> (ProjectConfigBuildOnly -> Flag FilePath)
-> ProjectConfigBuildOnly
-> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectConfigBuildOnly -> Flag FilePath
projectConfigHttpTransport (ProjectConfigBuildOnly -> Maybe FilePath)
-> ProjectConfigBuildOnly -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ ProjectConfig -> ProjectConfigBuildOnly
projectConfigBuildOnly ProjectConfig
cliConfig)
ProjectConfigSkeleton
projectCfgSkeleton <- Verbosity
-> HttpTransport
-> DistDirLayout
-> FilePath
-> ByteString
-> IO ProjectConfigSkeleton
readProjectBlockFromScript Verbosity
verbosity HttpTransport
httpTransport (ProjectBaseContext -> DistDirLayout
distDirLayout ProjectBaseContext
ctx) (FilePath -> FilePath
takeFileName FilePath
script) ByteString
scriptContents
(Compiler
compiler, Platform Arch
arch OS
os, ProgramDb
_) <- FilePath
-> Rebuild (Compiler, Platform, ProgramDb)
-> IO (Compiler, Platform, ProgramDb)
forall a. FilePath -> Rebuild a -> IO a
runRebuild (DistDirLayout -> FilePath
distProjectRootDirectory (DistDirLayout -> FilePath)
-> (ProjectBaseContext -> DistDirLayout)
-> ProjectBaseContext
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectBaseContext -> DistDirLayout
distDirLayout (ProjectBaseContext -> FilePath) -> ProjectBaseContext -> FilePath
forall a b. (a -> b) -> a -> b
$ ProjectBaseContext
ctx) (Rebuild (Compiler, Platform, ProgramDb)
-> IO (Compiler, Platform, ProgramDb))
-> Rebuild (Compiler, Platform, ProgramDb)
-> IO (Compiler, Platform, ProgramDb)
forall a b. (a -> b) -> a -> b
$ Verbosity
-> DistDirLayout
-> ProjectConfig
-> Rebuild (Compiler, Platform, ProgramDb)
configureCompiler Verbosity
verbosity (ProjectBaseContext -> DistDirLayout
distDirLayout ProjectBaseContext
ctx) (((ProjectConfig, [FilePath]) -> ProjectConfig
forall a b. (a, b) -> a
fst ((ProjectConfig, [FilePath]) -> ProjectConfig)
-> (ProjectConfig, [FilePath]) -> ProjectConfig
forall a b. (a -> b) -> a -> b
$ ProjectConfigSkeleton -> (ProjectConfig, [FilePath])
forall a c v.
(Semigroup a, Semigroup c) =>
CondTree v c a -> (a, c)
ignoreConditions ProjectConfigSkeleton
projectCfgSkeleton) ProjectConfig -> ProjectConfig -> ProjectConfig
forall a. Semigroup a => a -> a -> a
<> ProjectBaseContext -> ProjectConfig
projectConfig ProjectBaseContext
ctx)
let projectCfg :: ProjectConfig
projectCfg = OS
-> Arch
-> CompilerInfo
-> FlagAssignment
-> ProjectConfigSkeleton
-> ProjectConfig
instantiateProjectConfigSkeleton OS
os Arch
arch (Compiler -> CompilerInfo
compilerInfo Compiler
compiler) FlagAssignment
forall a. Monoid a => a
mempty ProjectConfigSkeleton
projectCfgSkeleton :: ProjectConfig
let executable' :: Executable
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
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)
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
ctx' :: ProjectBaseContext
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)
(TargetContext, ProjectBaseContext, [TargetSelector])
-> IO (TargetContext, ProjectBaseContext, [TargetSelector])
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Executable -> TargetContext
ScriptContext FilePath
script Executable
executable', ProjectBaseContext
ctx', [TargetSelector]
defaultTarget)
else Verbosity
-> [TargetSelectorProblem]
-> IO (TargetContext, ProjectBaseContext, [TargetSelector])
forall a. Verbosity -> [TargetSelectorProblem] -> IO a
reportTargetSelectorProblems Verbosity
verbosity [TargetSelectorProblem]
err
withTemporaryTempDirectory :: (IO FilePath -> IO a) -> IO a
withTemporaryTempDirectory :: (IO FilePath -> IO a) -> IO a
withTemporaryTempDirectory IO FilePath -> IO a
act = IO (MVar FilePath)
forall a. IO (MVar a)
newEmptyMVar IO (MVar FilePath) -> (MVar FilePath -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \MVar FilePath
m -> IO (IO FilePath)
-> (IO FilePath -> IO ()) -> (IO FilePath -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (MVar FilePath -> IO (IO FilePath)
forall (m :: * -> *). Monad m => MVar FilePath -> m (IO FilePath)
getMkTmp MVar FilePath
m) (MVar FilePath -> IO FilePath -> IO ()
forall p. MVar FilePath -> p -> IO ()
rmTmp MVar FilePath
m) IO FilePath -> IO a
act
where
getMkTmp :: MVar FilePath -> m (IO FilePath)
getMkTmp MVar FilePath
m = IO FilePath -> m (IO FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (IO FilePath -> m (IO FilePath)) -> IO FilePath -> m (IO FilePath)
forall a b. (a -> b) -> a -> b
$ do
FilePath
tmpDir <- IO FilePath
getTemporaryDirectory IO FilePath -> (FilePath -> IO FilePath) -> IO FilePath
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (FilePath -> FilePath -> IO FilePath)
-> FilePath -> FilePath -> IO FilePath
forall a b c. (a -> b -> c) -> b -> a -> c
flip FilePath -> FilePath -> IO FilePath
createTempDirectory FilePath
"cabal-repl."
MVar FilePath -> FilePath -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar FilePath
m FilePath
tmpDir
FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
tmpDir
rmTmp :: MVar FilePath -> p -> IO ()
rmTmp MVar FilePath
m p
_ = MVar FilePath -> IO (Maybe FilePath)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar FilePath
m IO (Maybe FilePath) -> (Maybe FilePath -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> (FilePath -> IO ()) -> Maybe FilePath -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (() -> IO () -> IO ()
forall a. a -> IO a -> IO a
handleDoesNotExist () (IO () -> IO ()) -> (FilePath -> IO ()) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ()
removeDirectoryRecursive)
updateContextAndWriteProjectFile' :: ProjectBaseContext -> SourcePackage (PackageLocation (Maybe FilePath)) -> IO ProjectBaseContext
updateContextAndWriteProjectFile' :: ProjectBaseContext
-> SourcePackage (PackageLocation (Maybe FilePath))
-> IO ProjectBaseContext
updateContextAndWriteProjectFile' ProjectBaseContext
ctx SourcePackage (PackageLocation (Maybe FilePath))
srcPkg = do
let projectRoot :: FilePath
projectRoot = DistDirLayout -> FilePath
distProjectRootDirectory (DistDirLayout -> FilePath) -> DistDirLayout -> FilePath
forall a b. (a -> b) -> a -> b
$ ProjectBaseContext -> DistDirLayout
distDirLayout ProjectBaseContext
ctx
packageFile :: FilePath
packageFile = FilePath
projectRoot FilePath -> FilePath -> FilePath
</> FilePath
fakePackageCabalFileName
contents :: FilePath
contents = GenericPackageDescription -> FilePath
showGenericPackageDescription (SourcePackage (PackageLocation (Maybe FilePath))
-> GenericPackageDescription
forall loc. SourcePackage loc -> GenericPackageDescription
srcpkgDescription SourcePackage (PackageLocation (Maybe FilePath))
srcPkg)
writePackageFile :: IO ()
writePackageFile = FilePath -> FilePath -> IO ()
writeUTF8File FilePath
packageFile FilePath
contents
Bool
packageFileExists <- FilePath -> IO Bool
doesFileExist FilePath
packageFile
if Bool
packageFileExists then do
FilePath
cached <- FilePath -> FilePath
forall a. NFData a => a -> a
force (FilePath -> FilePath) -> IO FilePath -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO FilePath
readUTF8File FilePath
packageFile
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath
cached FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
contents)
IO ()
writePackageFile
else IO ()
writePackageFile
ProjectBaseContext -> IO ProjectBaseContext
forall (m :: * -> *) a. Monad m => a -> m a
return (ProjectBaseContext
ctx ProjectBaseContext
-> (ProjectBaseContext -> ProjectBaseContext) -> ProjectBaseContext
forall a b. a -> (a -> b) -> b
& LensLike
Identity
ProjectBaseContext
ProjectBaseContext
[PackageSpecifier
(SourcePackage (PackageLocation (Maybe FilePath)))]
[PackageSpecifier
(SourcePackage (PackageLocation (Maybe FilePath)))]
Lens'
ProjectBaseContext
[PackageSpecifier
(SourcePackage (PackageLocation (Maybe FilePath)))]
lLocalPackages LensLike
Identity
ProjectBaseContext
ProjectBaseContext
[PackageSpecifier
(SourcePackage (PackageLocation (Maybe FilePath)))]
[PackageSpecifier
(SourcePackage (PackageLocation (Maybe FilePath)))]
-> ([PackageSpecifier
(SourcePackage (PackageLocation (Maybe FilePath)))]
-> [PackageSpecifier
(SourcePackage (PackageLocation (Maybe FilePath)))])
-> ProjectBaseContext
-> ProjectBaseContext
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ([PackageSpecifier
(SourcePackage (PackageLocation (Maybe FilePath)))]
-> [PackageSpecifier
(SourcePackage (PackageLocation (Maybe FilePath)))]
-> [PackageSpecifier
(SourcePackage (PackageLocation (Maybe FilePath)))]
forall a. [a] -> [a] -> [a]
++ [SourcePackage (PackageLocation (Maybe FilePath))
-> PackageSpecifier
(SourcePackage (PackageLocation (Maybe FilePath)))
forall pkg. pkg -> PackageSpecifier pkg
SpecificSourcePackage SourcePackage (PackageLocation (Maybe FilePath))
srcPkg]))
updateContextAndWriteProjectFile :: ProjectBaseContext -> FilePath -> Executable -> IO ProjectBaseContext
updateContextAndWriteProjectFile :: ProjectBaseContext
-> FilePath -> Executable -> IO ProjectBaseContext
updateContextAndWriteProjectFile ProjectBaseContext
ctx FilePath
scriptPath Executable
scriptExecutable = do
let projectRoot :: FilePath
projectRoot = DistDirLayout -> FilePath
distProjectRootDirectory (DistDirLayout -> FilePath) -> DistDirLayout -> FilePath
forall a b. (a -> b) -> a -> b
$ ProjectBaseContext -> DistDirLayout
distDirLayout ProjectBaseContext
ctx
FilePath
absScript <- FilePath -> IO FilePath
canonicalizePath FilePath
scriptPath
let
scriptExeName :: FilePath
scriptExeName = FilePath
"cabal-script-" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (Char -> Char) -> FilePath -> FilePath
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
censor (FilePath -> FilePath
takeFileName FilePath
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
'_'
sourcePackage :: SourcePackage (PackageLocation loc)
sourcePackage = FilePath -> SourcePackage (PackageLocation loc)
forall loc. FilePath -> SourcePackage (PackageLocation loc)
fakeProjectSourcePackage FilePath
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. Lens' (SourcePackage loc) 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
.~ [(FilePath -> UnqualComponentName
forall a. IsString a => FilePath -> a
fromString FilePath
scriptExeName, 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
executable = Executable
scriptExecutable
Executable -> (Executable -> Executable) -> Executable
forall a b. a -> (a -> b) -> b
& LensLike Identity Executable Executable FilePath FilePath
Lens' Executable FilePath
L.modulePath LensLike Identity Executable Executable FilePath FilePath
-> FilePath -> Executable -> Executable
forall s t a b. ASetter s t a b -> b -> s -> t
.~ FilePath
absScript
ProjectBaseContext
-> SourcePackage (PackageLocation (Maybe FilePath))
-> IO ProjectBaseContext
updateContextAndWriteProjectFile' ProjectBaseContext
ctx SourcePackage (PackageLocation (Maybe FilePath))
forall loc. SourcePackage (PackageLocation loc)
sourcePackage
parseScriptBlock :: BS.ByteString -> ParseResult Executable
parseScriptBlock :: ByteString -> ParseResult Executable
parseScriptBlock ByteString
str =
case ByteString -> Either ParseError [Field Position]
readFields ByteString
str of
Right [Field Position]
fs -> do
let (Fields Position
fields, [Field Position]
_) = [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 FilePath), c (List FSep Token FilePath),
c (List
FSep
(Identity (SymbolicPath PackageDir SourceDir))
(SymbolicPath PackageDir SourceDir)),
c (List NoCommaFSep Token' FilePath),
c (List VCat (MQuoted ModuleName) ModuleName),
c (List VCat FilePathNT FilePath), c (List VCat Token FilePath),
c (MQuoted Language)) =>
UnqualComponentName -> g Executable Executable
executableFieldGrammar UnqualComponentName
"script")
Left ParseError
perr -> Position -> FilePath -> ParseResult Executable
forall a. Position -> FilePath -> ParseResult a
parseFatalFailure Position
pos (ParseError -> FilePath
forall a. Show a => a -> FilePath
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 -> FilePath -> ByteString -> IO Executable
forall a.
(ByteString -> ParseResult a)
-> Verbosity -> FilePath -> ByteString -> IO a
parseString ByteString -> ParseResult Executable
parseScriptBlock Verbosity
verbosity FilePath
"script block"
readExecutableBlockFromScript :: Verbosity -> BS.ByteString -> IO Executable
readExecutableBlockFromScript :: Verbosity -> ByteString -> IO Executable
readExecutableBlockFromScript Verbosity
verbosity ByteString
str = do
ByteString
str' <- case ByteString -> ByteString -> Either FilePath ByteString
extractScriptBlock ByteString
"cabal" ByteString
str of
Left FilePath
e -> Verbosity -> FilePath -> IO ByteString
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO ByteString) -> FilePath -> IO ByteString
forall a b. (a -> b) -> a -> b
$ FilePath
"Failed extracting script block: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
e
Right ByteString
x -> ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
x
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Char -> Bool) -> ByteString -> Bool
BS.all Char -> Bool
isSpace ByteString
str') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity FilePath
"Empty script block"
Verbosity -> ByteString -> IO Executable
readScriptBlock Verbosity
verbosity ByteString
str'
readProjectBlockFromScript :: Verbosity -> HttpTransport -> DistDirLayout -> String -> BS.ByteString -> IO ProjectConfigSkeleton
readProjectBlockFromScript :: Verbosity
-> HttpTransport
-> DistDirLayout
-> FilePath
-> ByteString
-> IO ProjectConfigSkeleton
readProjectBlockFromScript Verbosity
verbosity HttpTransport
httpTransport DistDirLayout{FilePath
distDownloadSrcDirectory :: DistDirLayout -> FilePath
distDownloadSrcDirectory :: FilePath
distDownloadSrcDirectory} FilePath
scriptName ByteString
str = do
case ByteString -> ByteString -> Either FilePath ByteString
extractScriptBlock ByteString
"project" ByteString
str of
Left FilePath
_ -> ProjectConfigSkeleton -> IO ProjectConfigSkeleton
forall (m :: * -> *) a. Monad m => a -> m a
return ProjectConfigSkeleton
forall a. Monoid a => a
mempty
Right ByteString
x -> Verbosity
-> FilePath
-> FilePath
-> ParseResult ProjectConfigSkeleton
-> IO ProjectConfigSkeleton
reportParseResult Verbosity
verbosity FilePath
"script" FilePath
scriptName
(ParseResult ProjectConfigSkeleton -> IO ProjectConfigSkeleton)
-> IO (ParseResult ProjectConfigSkeleton)
-> IO ProjectConfigSkeleton
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath
-> HttpTransport
-> Verbosity
-> [FilePath]
-> FilePath
-> ByteString
-> IO (ParseResult ProjectConfigSkeleton)
parseProjectSkeleton FilePath
distDownloadSrcDirectory HttpTransport
httpTransport Verbosity
verbosity [] FilePath
scriptName ByteString
x
extractScriptBlock :: BS.ByteString -> BS.ByteString -> Either String BS.ByteString
ByteString
header ByteString
str = [ByteString] -> Either FilePath 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
goPre :: [ByteString] -> Either FilePath 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
[] -> FilePath -> Either FilePath ByteString
forall a b. a -> Either a b
Left (FilePath -> Either FilePath ByteString)
-> FilePath -> Either FilePath ByteString
forall a b. (a -> b) -> a -> b
$ FilePath
"`" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ByteString -> FilePath
BS.unpack ByteString
startMarker FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"` start marker not found"
(ByteString
_:[ByteString]
ls') -> [ByteString] -> [ByteString] -> Either FilePath ByteString
goBody [] [ByteString]
ls'
goBody :: [ByteString] -> [ByteString] -> Either FilePath ByteString
goBody [ByteString]
_ [] = FilePath -> Either FilePath ByteString
forall a b. a -> Either a b
Left (FilePath -> Either FilePath ByteString)
-> FilePath -> Either FilePath ByteString
forall a b. (a -> b) -> a -> b
$ FilePath
"`" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ByteString -> FilePath
BS.unpack ByteString
endMarker FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"` end marker not found"
goBody [ByteString]
acc (ByteString
l:[ByteString]
ls)
| ByteString -> Bool
isEndMarker ByteString
l = ByteString -> Either FilePath ByteString
forall a b. b -> Either a b
Right (ByteString -> Either FilePath ByteString)
-> ByteString -> Either FilePath 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 FilePath ByteString
goBody (ByteString
lByteString -> [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
"-}"
fakeProjectSourcePackage :: FilePath -> SourcePackage (PackageLocation loc)
fakeProjectSourcePackage :: FilePath -> SourcePackage (PackageLocation loc)
fakeProjectSourcePackage FilePath
projectRoot = SourcePackage (PackageLocation loc)
forall loc. SourcePackage (PackageLocation loc)
sourcePackage
where
sourcePackage :: SourcePackage (PackageLocation local)
sourcePackage = SourcePackage :: forall loc.
PackageId
-> GenericPackageDescription
-> loc
-> PackageDescriptionOverride
-> SourcePackage loc
SourcePackage
{ srcpkgPackageId :: PackageId
srcpkgPackageId = PackageId
fakePackageId
, srcpkgDescription :: GenericPackageDescription
srcpkgDescription = GenericPackageDescription
genericPackageDescription
, srcpkgSource :: PackageLocation local
srcpkgSource = FilePath -> PackageLocation local
forall local. FilePath -> PackageLocation local
LocalUnpackedPackage FilePath
projectRoot
, srcpkgDescrOverride :: PackageDescriptionOverride
srcpkgDescrOverride = PackageDescriptionOverride
forall a. Maybe a
Nothing
}
genericPackageDescription :: GenericPackageDescription
genericPackageDescription = GenericPackageDescription
emptyGenericPackageDescription
{ packageDescription :: PackageDescription
GPD.packageDescription = PackageDescription
packageDescription }
packageDescription :: PackageDescription
packageDescription = PackageDescription
emptyPackageDescription
{ package :: PackageId
package = PackageId
fakePackageId
, specVersion :: CabalSpecVersion
specVersion = CabalSpecVersion
CabalSpecV2_2
, licenseRaw :: Either License License
licenseRaw = License -> Either License License
forall a b. a -> Either a b
Left License
SPDX.NONE
}
lSrcpkgDescription :: Lens' (SourcePackage loc) GenericPackageDescription
lSrcpkgDescription :: 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\GenericPackageDescription
x -> SourcePackage loc
s { srcpkgDescription :: GenericPackageDescription
srcpkgDescription = GenericPackageDescription
x }) (GenericPackageDescription -> f GenericPackageDescription
f (SourcePackage loc -> GenericPackageDescription
forall loc. SourcePackage loc -> GenericPackageDescription
srcpkgDescription SourcePackage loc
s))
{-# inline lSrcpkgDescription #-}
lLocalPackages :: Lens' ProjectBaseContext [PackageSpecifier UnresolvedSourcePackage]
lLocalPackages :: LensLike
f
ProjectBaseContext
ProjectBaseContext
[PackageSpecifier
(SourcePackage (PackageLocation (Maybe FilePath)))]
[PackageSpecifier
(SourcePackage (PackageLocation (Maybe FilePath)))]
lLocalPackages [PackageSpecifier
(SourcePackage (PackageLocation (Maybe FilePath)))]
-> f [PackageSpecifier
(SourcePackage (PackageLocation (Maybe FilePath)))]
f ProjectBaseContext
s = ([PackageSpecifier
(SourcePackage (PackageLocation (Maybe FilePath)))]
-> ProjectBaseContext)
-> f [PackageSpecifier
(SourcePackage (PackageLocation (Maybe FilePath)))]
-> f ProjectBaseContext
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[PackageSpecifier
(SourcePackage (PackageLocation (Maybe FilePath)))]
x -> ProjectBaseContext
s { localPackages :: [PackageSpecifier
(SourcePackage (PackageLocation (Maybe FilePath)))]
localPackages = [PackageSpecifier
(SourcePackage (PackageLocation (Maybe FilePath)))]
x }) ([PackageSpecifier
(SourcePackage (PackageLocation (Maybe FilePath)))]
-> f [PackageSpecifier
(SourcePackage (PackageLocation (Maybe FilePath)))]
f (ProjectBaseContext
-> [PackageSpecifier
(SourcePackage (PackageLocation (Maybe FilePath)))]
localPackages ProjectBaseContext
s))
{-# inline lLocalPackages #-}
lProjectConfig :: Lens' ProjectBaseContext ProjectConfig
lProjectConfig :: LensLike
f ProjectBaseContext ProjectBaseContext ProjectConfig ProjectConfig
lProjectConfig ProjectConfig -> f ProjectConfig
f ProjectBaseContext
s = (ProjectConfig -> ProjectBaseContext)
-> f ProjectConfig -> f ProjectBaseContext
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ProjectConfig
x -> ProjectBaseContext
s { projectConfig :: ProjectConfig
projectConfig = ProjectConfig
x }) (ProjectConfig -> f ProjectConfig
f (ProjectBaseContext -> ProjectConfig
projectConfig ProjectBaseContext
s))
{-# inline lProjectConfig #-}
ccSpace, ccCtrlchar, ccPrintable, ccSymbol', ccParen, ccNamecore :: Set Char
ccSpace :: Set Char
ccSpace = FilePath -> Set Char
forall a. Ord a => [a] -> Set a
S.fromList FilePath
" "
ccCtrlchar :: Set Char
ccCtrlchar = FilePath -> Set Char
forall a. Ord a => [a] -> Set a
S.fromList (FilePath -> Set Char) -> FilePath -> Set Char
forall a b. (a -> b) -> a -> b
$ [Int -> Char
chr Int
0x0 .. Int -> Char
chr Int
0x1f] FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [Int -> Char
chr Int
0x7f]
ccPrintable :: Set Char
ccPrintable = FilePath -> 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' = FilePath -> Set Char
forall a. Ord a => [a] -> Set a
S.fromList FilePath
",=<>+*&|!$%^@#?/\\~"
ccParen :: Set Char
ccParen = FilePath -> Set Char
forall a. Ord a => [a] -> Set a
S.fromList FilePath
"()[]"
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, FilePath -> Set Char
forall a. Ord a => [a] -> Set a
S.fromList FilePath
":\"{}", Set Char
ccParen, Set Char
ccSymbol']