diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 1a5c282e7cf..552e70f70f1 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -159,6 +159,7 @@ library Distribution.Client.Sandbox Distribution.Client.Sandbox.PackageEnvironment Distribution.Client.SavedFlags + Distribution.Client.ScriptUtils Distribution.Client.Security.DNS Distribution.Client.Security.HTTP Distribution.Client.Setup diff --git a/cabal-install/src/Distribution/Client/CmdBuild.hs b/cabal-install/src/Distribution/Client/CmdBuild.hs index ea59acfff19..ba47c5842a5 100644 --- a/cabal-install/src/Distribution/Client/CmdBuild.hs +++ b/cabal-install/src/Distribution/Client/CmdBuild.hs @@ -32,6 +32,8 @@ import Distribution.Verbosity ( normal ) import Distribution.Simple.Utils ( wrapText, die' ) +import Distribution.Client.ScriptUtils + ( withTempTempDirectory, getContextAndSelectorsWithScripts ) import qualified Data.Map as Map @@ -95,7 +97,7 @@ defaultBuildFlags = BuildFlags -- "Distribution.Client.ProjectOrchestration" -- buildAction :: NixStyleFlags BuildFlags -> [String] -> GlobalFlags -> IO () -buildAction flags@NixStyleFlags { extraFlags = buildFlags, ..} targetStrings globalFlags = do +buildAction flags@NixStyleFlags { extraFlags = buildFlags, ..} targetStrings globalFlags = withTempTempDirectory $ \tmpDir -> do -- TODO: This flags defaults business is ugly let onlyConfigure = fromFlag (buildOnlyConfigure defaultBuildFlags <> buildOnlyConfigure buildFlags) @@ -103,11 +105,7 @@ buildAction flags@NixStyleFlags { extraFlags = buildFlags, ..} targetStrings glo | onlyConfigure = TargetActionConfigure | otherwise = TargetActionBuild - baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand - - targetSelectors <- - either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) Nothing targetStrings + (baseCtx, targetSelectors) <- getContextAndSelectorsWithScripts flags targetStrings globalFlags tmpDir buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do @@ -141,8 +139,6 @@ buildAction flags@NixStyleFlags { extraFlags = buildFlags, ..} targetStrings glo runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes where verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - cliConfig = commandLineFlagsToProjectConfig globalFlags flags - mempty -- ClientInstallFlags, not needed here -- | This defines what a 'TargetSelector' means for the @bench@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, diff --git a/cabal-install/src/Distribution/Client/CmdRun.hs b/cabal-install/src/Distribution/Client/CmdRun.hs index be311cd9ee5..a5512120247 100644 --- a/cabal-install/src/Distribution/Client/CmdRun.hs +++ b/cabal-install/src/Distribution/Client/CmdRun.hs @@ -36,32 +36,21 @@ import Distribution.Client.Setup ( GlobalFlags(..), ConfigFlags(..) ) import Distribution.Client.GlobalFlags ( defaultGlobalFlags ) -import Distribution.Client.Config - ( getCabalDir ) import Distribution.Simple.Flag ( fromFlagOrDefault ) import Distribution.Simple.Command ( CommandUI(..), usageAlternatives ) import Distribution.Types.ComponentName ( showComponentName ) -import Distribution.CabalSpecVersion (CabalSpecVersion (..), cabalSpecLatest) import Distribution.Verbosity ( normal ) import Distribution.Simple.Utils - ( wrapText, warn, die', info, notice - , createTempDirectory, handleDoesNotExist ) -import Distribution.Client.ProjectConfig - ( ProjectConfig(..), ProjectConfigShared(..) - , withProjectOrGlobalConfig ) -import Distribution.Client.ProjectFlags - ( flagIgnoreProject ) + ( wrapText, die', info, notice ) import Distribution.Client.ProjectPlanning ( ElaboratedConfiguredPackage(..) , ElaboratedInstallPlan, binDirectoryFor ) import Distribution.Client.ProjectPlanning.Types ( dataDirsEnvironmentForPlan ) -import Distribution.Client.TargetSelector - ( TargetSelectorProblem(..), TargetString(..) ) import Distribution.Client.InstallPlan ( toList, foldPlanPackage ) import Distribution.Types.UnqualComponentName @@ -71,45 +60,14 @@ import Distribution.Simple.Program.Run emptyProgramInvocation ) import Distribution.Types.UnitId ( UnitId ) +import Distribution.Client.ScriptUtils + ( withTempTempDirectory, getContextAndSelectorsWithScripts ) -import Distribution.Client.Types - ( PackageLocation(..), PackageSpecifier(..) ) -import Distribution.FieldGrammar - ( takeFields, parseFieldGrammar ) -import Distribution.PackageDescription.FieldGrammar - ( executableFieldGrammar ) -import Distribution.PackageDescription.PrettyPrint - ( writeGenericPackageDescription ) -import Distribution.Parsec - ( Position(..) ) -import Distribution.Fields - ( ParseResult, parseString, parseFatalFailure, readFields ) -import qualified Distribution.SPDX.License as SPDX -import Distribution.Solver.Types.SourcePackage as SP - ( SourcePackage(..) ) -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 - ( fakePackageId ) -import Language.Haskell.Extension - ( Language(..) ) - -import qualified Data.ByteString.Char8 as BS import qualified Data.Set as Set -import qualified Text.Parsec as P import System.Directory - ( getTemporaryDirectory, removeDirectoryRecursive, doesFileExist, makeAbsolute ) + ( doesFileExist ) import System.FilePath - ( (), isValid, isPathSeparator, takeExtension ) - + ( (), isValid, isPathSeparator ) runCommand :: CommandUI (NixStyleFlags ()) runCommand = CommandUI @@ -160,51 +118,13 @@ runCommand = CommandUI -- "Distribution.Client.ProjectOrchestration" -- runAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () -runAction flags@NixStyleFlags {..} targetStrings globalFlags = do - globalTmp <- getTemporaryDirectory - tmpDir <- createTempDirectory globalTmp "cabal-repl." - - let - with = - establishProjectBaseContext verbosity cliConfig OtherCommand - without dir globalConfig = do - distDirLayout <- establishDummyDistDirLayout verbosity (globalConfig <> cliConfig) dir - establishDummyProjectBaseContext verbosity (globalConfig <> cliConfig) distDirLayout [] OtherCommand - - baseCtx <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag with (without tmpDir) - - let - scriptOrError script err = do - exists <- doesFileExist script - let pol | takeExtension script == ".lhs" = LiterateHaskell - | otherwise = PlainHaskell - if exists - then do - cacheDir <- getScriptCacheDirectory script - ctx <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag with (without cacheDir) - BS.readFile script >>= handleScriptCase verbosity pol ctx cacheDir - else reportTargetSelectorProblems verbosity err - - -- We pass the baseCtx made with tmpDir to readTargetSelectors and only create a ctx with cacheDir - -- if no target is found because we want global targets to have higher priority than scripts. - -- In case of a collision, `cabal run target` can be rewritten as `cabal run ./target` - -- to specify the script, but there is no alternate way to specify the global target. - (baseCtx', targetSelectors) <- - readTargetSelectors (localPackages baseCtx) (Just ExeKind) (take 1 targetStrings) - >>= \case - Left err@(TargetSelectorNoTargetsInProject:_) - | (script:_) <- targetStrings -> scriptOrError script err - Left err@(TargetSelectorNoSuch t _:_) - | TargetString1 script <- t -> scriptOrError script err - Left err@(TargetSelectorExpected t _ _:_) - | TargetString1 script <- t -> scriptOrError script err - Left err -> reportTargetSelectorProblems verbosity err - Right sels -> return (baseCtx, sels) +runAction flags@NixStyleFlags {..} targetStrings globalFlags = withTempTempDirectory $ \tmpDir -> do + (baseCtx, targetSelectors) <- getContextAndSelectorsWithScripts flags targetStrings globalFlags tmpDir buildCtx <- - runProjectPreBuildPhase verbosity baseCtx' $ \elaboratedPlan -> do + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do - when (buildSettingOnlyDeps (buildSettings baseCtx')) $ + when (buildSettingOnlyDeps (buildSettings baseCtx)) $ die' verbosity $ "The run command does not support '--only-dependencies'. " ++ "You may wish to use 'build --only-dependencies' and then " @@ -246,10 +166,10 @@ runAction flags@NixStyleFlags {..} targetStrings globalFlags = do ++ "phase has been reached. This is a bug.") $ targetsMap buildCtx - printPlan verbosity baseCtx' buildCtx + printPlan verbosity baseCtx buildCtx - buildOutcomes <- runProjectBuildPhase verbosity baseCtx' buildCtx - runProjectPostBuildPhase verbosity baseCtx' buildCtx buildOutcomes + buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx + runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes let elaboratedPlan = elaboratedPlanToExecute buildCtx @@ -287,14 +207,14 @@ runAction flags@NixStyleFlags {..} targetStrings globalFlags = do ++ exeName ++ ":\n" ++ unlines (fmap (\p -> " - in package " ++ prettyShow (elabUnitId p)) elabPkgs) - let exePath = binDirectoryFor (distDirLayout baseCtx') + let exePath = binDirectoryFor (distDirLayout baseCtx) (elaboratedShared buildCtx) pkg exeName exeName let args = drop 1 targetStrings - dryRun = buildSettingDryRun (buildSettings baseCtx') - || buildSettingOnlyDownload (buildSettings baseCtx') + dryRun = buildSettingDryRun (buildSettings baseCtx) + || buildSettingOnlyDownload (buildSettings baseCtx) if dryRun then notice verbosity "Running of executable suppressed by flag(s)" @@ -308,23 +228,8 @@ runAction flags@NixStyleFlags {..} targetStrings globalFlags = do (distDirLayout baseCtx) elaboratedPlan } - - handleDoesNotExist () (removeDirectoryRecursive tmpDir) where verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - ignoreProject = flagIgnoreProject projectFlags - cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here - globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) - --- | Get the directory for caching a script build. --- --- The only identity of a script is it's absolute path, so append that path --- to /script-builds/ to get the cache directory. -getScriptCacheDirectory :: FilePath -> IO FilePath -getScriptCacheDirectory script = do - scriptAbs <- dropWhile (\c -> c == '/' || c == '\\') <$> makeAbsolute script - cabalDir <- getCabalDir - return $ cabalDir "script-builds" scriptAbs -- | Used by the main CLI parser as heuristic to decide whether @cabal@ was -- invoked as a script interpreter, i.e. via @@ -352,120 +257,6 @@ handleShebang :: FilePath -> [String] -> IO () handleShebang script args = runAction (commandDefaultFlags runCommand) (script:args) defaultGlobalFlags -parseScriptBlock :: BS.ByteString -> ParseResult Executable -parseScriptBlock str = - case readFields str of - Right fs -> do - let (fields, _) = takeFields fs - parseFieldGrammar cabalSpecLatest fields (executableFieldGrammar "script") - Left perr -> parseFatalFailure pos (show perr) where - ppos = P.errorPos perr - pos = Position (P.sourceLine ppos) (P.sourceColumn ppos) - -readScriptBlock :: Verbosity -> BS.ByteString -> IO Executable -readScriptBlock verbosity = parseString parseScriptBlock verbosity "script block" - -readScriptBlockFromScript :: Verbosity -> PlainOrLiterate -> BS.ByteString -> IO (Executable, BS.ByteString) -readScriptBlockFromScript verbosity pol str = do - str' <- case extractScriptBlock pol str of - Left e -> die' verbosity $ "Failed extracting script block: " ++ e - Right x -> return x - when (BS.all isSpace str') $ warn verbosity "Empty script block" - (\x -> (x, noShebang)) <$> readScriptBlock verbosity str' - where - noShebang = BS.unlines . filter (not . BS.isPrefixOf "#!") . BS.lines $ str - --- | Extract the first encountered script metadata block started end --- terminated by the tokens --- --- * @{- cabal:@ --- --- * @-}@ --- --- 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 :: PlainOrLiterate -> BS.ByteString -> Either String BS.ByteString -extractScriptBlock _pol str = goPre (BS.lines str) - where - isStartMarker = (== startMarker) . stripTrailSpace - isEndMarker = (== endMarker) . stripTrailSpace - - stripTrailSpace = fst . BS.spanEnd isSpace - - -- before start marker - goPre ls = case dropWhile (not . isStartMarker) ls of - [] -> Left $ "`" ++ BS.unpack startMarker ++ "` start marker not found" - (_:ls') -> goBody [] ls' - - goBody _ [] = Left $ "`" ++ BS.unpack endMarker ++ "` end marker not found" - goBody acc (l:ls) - | isEndMarker l = Right $! BS.unlines $ reverse acc - | otherwise = goBody (l:acc) ls - - startMarker, endMarker :: BS.ByteString - startMarker = fromString "{- cabal:" - endMarker = fromString "-}" - -data PlainOrLiterate - = PlainHaskell - | LiterateHaskell - -handleScriptCase - :: Verbosity - -> PlainOrLiterate - -> ProjectBaseContext - -> FilePath - -> BS.ByteString - -> IO (ProjectBaseContext, [TargetSelector]) -handleScriptCase verbosity pol baseCtx tmpDir scriptContents = do - (executable, contents') <- readScriptBlockFromScript verbosity pol scriptContents - - -- We need to create a dummy package that lives in our dummy project. - let - mainName = case pol of - PlainHaskell -> "Main.hs" - LiterateHaskell -> "Main.lhs" - - sourcePackage = SourcePackage - { srcpkgPackageId = pkgId - , srcpkgDescription = genericPackageDescription - , srcpkgSource = LocalUnpackedPackage tmpDir - , srcpkgDescrOverride = Nothing - } - genericPackageDescription = emptyGenericPackageDescription - { GPD.packageDescription = packageDescription - , condExecutables = [("script", CondNode executable' targetBuildDepends [])] - } - executable' = executable - { modulePath = mainName - , buildInfo = binfo - { defaultLanguage = - case defaultLanguage of - just@(Just _) -> just - Nothing -> Just Haskell2010 - } - } - binfo@BuildInfo{..} = buildInfo executable - packageDescription = emptyPackageDescription - { package = pkgId - , specVersion = CabalSpecV2_2 - , licenseRaw = Left SPDX.NONE - } - pkgId = fakePackageId - - writeGenericPackageDescription (tmpDir "fake-package.cabal") genericPackageDescription - BS.writeFile (tmpDir mainName) contents' - - let - baseCtx' = baseCtx - { localPackages = localPackages baseCtx ++ [SpecificSourcePackage sourcePackage] } - targetSelectors = [TargetPackage TargetExplicitNamed [pkgId] Nothing] - - return (baseCtx', targetSelectors) - singleExeOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName) singleExeOrElse action targetsMap = case Set.toList . distinctTargetComponents $ targetsMap diff --git a/cabal-install/src/Distribution/Client/ScriptUtils.hs b/cabal-install/src/Distribution/Client/ScriptUtils.hs new file mode 100644 index 00000000000..153c8f922f5 --- /dev/null +++ b/cabal-install/src/Distribution/Client/ScriptUtils.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Utilities to help commands with scripts +-- +module Distribution.Client.ScriptUtils ( + getScriptCacheDirectory, + withTempTempDirectory, + getContextAndSelectorsWithScripts + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude hiding (toList) + +import Distribution.Client.ProjectOrchestration +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..) ) +import Distribution.Client.Setup + ( GlobalFlags(..), ConfigFlags(..) ) +import Distribution.Client.Config + ( getCabalDir ) +import Distribution.Simple.Flag + ( fromFlagOrDefault ) +import Distribution.CabalSpecVersion (CabalSpecVersion (..), cabalSpecLatest) +import Distribution.Verbosity + ( normal ) +import Distribution.Simple.Utils + ( warn, die' + , createTempDirectory, handleDoesNotExist ) +import Distribution.Client.ProjectConfig + ( ProjectConfig(..), ProjectConfigShared(..) + , withProjectOrGlobalConfig ) +import Distribution.Client.ProjectFlags + ( flagIgnoreProject ) +import Distribution.Client.TargetSelector + ( TargetSelectorProblem(..), TargetString(..) ) +import Distribution.Client.Types + ( PackageLocation(..), PackageSpecifier(..) ) +import Distribution.FieldGrammar + ( takeFields, parseFieldGrammar ) +import Distribution.PackageDescription.FieldGrammar + ( executableFieldGrammar ) +import Distribution.PackageDescription.PrettyPrint + ( writeGenericPackageDescription ) +import Distribution.Parsec + ( Position(..) ) +import Distribution.Fields + ( ParseResult, parseString, parseFatalFailure, readFields ) +import qualified Distribution.SPDX.License as SPDX +import Distribution.Solver.Types.SourcePackage as SP + ( SourcePackage(..) ) +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 + ( fakePackageId ) +import Language.Haskell.Extension + ( Language(..) ) + +import Control.Exception + ( bracket ) +import qualified Data.ByteString.Char8 as BS +import qualified Text.Parsec as P +import System.Directory + ( getTemporaryDirectory, removeDirectoryRecursive, doesFileExist, makeAbsolute ) +import System.FilePath + ( (), takeExtension ) + +-- | Get the directory for caching a script build. +-- +-- The only identity of a script is it's absolute path, so append that path +-- to /script-builds/ to get the cache directory. +getScriptCacheDirectory :: FilePath -> IO FilePath +getScriptCacheDirectory script = do + scriptAbs <- dropWhile (\c -> c == '/' || c == '\\') <$> makeAbsolute script + cabalDir <- getCabalDir + return $ cabalDir "script-builds" scriptAbs + +-- | Create a new temporary directory inside the directory for temporary files +-- and delete it after use. +withTempTempDirectory :: (FilePath -> IO a) -> IO a +withTempTempDirectory = bracket getTmp rmTmp + where + getTmp = getTemporaryDirectory >>= flip createTempDirectory "cabal-repl." + rmTmp = handleDoesNotExist () . removeDirectoryRecursive + +-- | Determine whether the targets represent regular targets or a script +-- invocation and return the proper context and target selectors. +-- Report problems if selectors are valid as neither regular targets +-- or as a script. +getContextAndSelectorsWithScripts :: NixStyleFlags a -> [String] -> GlobalFlags -> FilePath -> IO (ProjectBaseContext, [TargetSelector]) +getContextAndSelectorsWithScripts flags@NixStyleFlags {..} targetStrings globalFlags tmpDir = do + let + with = + establishProjectBaseContext verbosity cliConfig OtherCommand + without dir globalConfig = do + distDirLayout <- establishDummyDistDirLayout verbosity (globalConfig <> cliConfig) dir + establishDummyProjectBaseContext verbosity (globalConfig <> cliConfig) distDirLayout [] OtherCommand + + baseCtx <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag with (without tmpDir) + + let + scriptOrError script err = do + exists <- doesFileExist script + let pol | takeExtension script == ".lhs" = LiterateHaskell + | otherwise = PlainHaskell + if exists + then do + cacheDir <- getScriptCacheDirectory script + ctx <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag with (without cacheDir) + BS.readFile script >>= handleScriptCase verbosity pol ctx cacheDir + else reportTargetSelectorProblems verbosity err + + -- We pass the baseCtx made with tmpDir to readTargetSelectors and only create a ctx with cacheDir + -- if no target is found because we want global targets to have higher priority than scripts. + -- In case of a collision, `cabal run target` can be rewritten as `cabal run ./target` + -- to specify the script, but there is no alternate way to specify the global target. + readTargetSelectors (localPackages baseCtx) (Just ExeKind) (take 1 targetStrings) + >>= \case + Left err@(TargetSelectorNoTargetsInProject:_) + | (script:_) <- targetStrings -> scriptOrError script err + Left err@(TargetSelectorNoSuch t _:_) + | TargetString1 script <- t -> scriptOrError script err + Left err@(TargetSelectorExpected t _ _:_) + | TargetString1 script <- t -> scriptOrError script err + Left err -> reportTargetSelectorProblems verbosity err + Right sels -> return (baseCtx, sels) + where + verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + ignoreProject = flagIgnoreProject projectFlags + cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty + globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) + +parseScriptBlock :: BS.ByteString -> ParseResult Executable +parseScriptBlock str = + case readFields str of + Right fs -> do + let (fields, _) = takeFields fs + parseFieldGrammar cabalSpecLatest fields (executableFieldGrammar "script") + Left perr -> parseFatalFailure pos (show perr) where + ppos = P.errorPos perr + pos = Position (P.sourceLine ppos) (P.sourceColumn ppos) + +readScriptBlock :: Verbosity -> BS.ByteString -> IO Executable +readScriptBlock verbosity = parseString parseScriptBlock verbosity "script block" + +readScriptBlockFromScript :: Verbosity -> PlainOrLiterate -> BS.ByteString -> IO (Executable, BS.ByteString) +readScriptBlockFromScript verbosity pol str = do + str' <- case extractScriptBlock pol str of + Left e -> die' verbosity $ "Failed extracting script block: " ++ e + Right x -> return x + when (BS.all isSpace str') $ warn verbosity "Empty script block" + (\x -> (x, noShebang)) <$> readScriptBlock verbosity str' + where + noShebang = BS.unlines . filter (not . BS.isPrefixOf "#!") . BS.lines $ str + +-- | Extract the first encountered script metadata block started end +-- terminated by the tokens +-- +-- * @{- cabal:@ +-- +-- * @-}@ +-- +-- 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 :: PlainOrLiterate -> BS.ByteString -> Either String BS.ByteString +extractScriptBlock _pol str = goPre (BS.lines str) + where + isStartMarker = (== startMarker) . stripTrailSpace + isEndMarker = (== endMarker) . stripTrailSpace + + stripTrailSpace = fst . BS.spanEnd isSpace + + -- before start marker + goPre ls = case dropWhile (not . isStartMarker) ls of + [] -> Left $ "`" ++ BS.unpack startMarker ++ "` start marker not found" + (_:ls') -> goBody [] ls' + + goBody _ [] = Left $ "`" ++ BS.unpack endMarker ++ "` end marker not found" + goBody acc (l:ls) + | isEndMarker l = Right $! BS.unlines $ reverse acc + | otherwise = goBody (l:acc) ls + + startMarker, endMarker :: BS.ByteString + startMarker = fromString "{- cabal:" + endMarker = fromString "-}" + +data PlainOrLiterate + = PlainHaskell + | LiterateHaskell + +handleScriptCase + :: Verbosity + -> PlainOrLiterate + -> ProjectBaseContext + -> FilePath + -> BS.ByteString + -> IO (ProjectBaseContext, [TargetSelector]) +handleScriptCase verbosity pol baseCtx dir scriptContents = do + (executable, contents') <- readScriptBlockFromScript verbosity pol scriptContents + + -- We need to create a dummy package that lives in our dummy project. + let + mainName = case pol of + PlainHaskell -> "Main.hs" + LiterateHaskell -> "Main.lhs" + + sourcePackage = SourcePackage + { srcpkgPackageId = pkgId + , srcpkgDescription = genericPackageDescription + , srcpkgSource = LocalUnpackedPackage dir + , srcpkgDescrOverride = Nothing + } + genericPackageDescription = emptyGenericPackageDescription + { GPD.packageDescription = packageDescription + , condExecutables = [("script", CondNode executable' targetBuildDepends [])] + } + executable' = executable + { modulePath = mainName + , buildInfo = binfo + { defaultLanguage = + case defaultLanguage of + just@(Just _) -> just + Nothing -> Just Haskell2010 + } + } + binfo@BuildInfo{..} = buildInfo executable + packageDescription = emptyPackageDescription + { package = pkgId + , specVersion = CabalSpecV2_2 + , licenseRaw = Left SPDX.NONE + } + pkgId = fakePackageId + + writeGenericPackageDescription (dir "fake-package.cabal") genericPackageDescription + BS.writeFile (dir mainName) contents' + + let + baseCtx' = baseCtx + { localPackages = localPackages baseCtx ++ [SpecificSourcePackage sourcePackage] } + targetSelectors = [TargetPackage TargetExplicitNamed [pkgId] Nothing] + + return (baseCtx', targetSelectors) +