From 0579010bbee7050903034a1b1a4d6ceb095e29e7 Mon Sep 17 00:00:00 2001 From: Mel Zuser Date: Thu, 2 Dec 2021 16:05:17 -0500 Subject: [PATCH] Add script support to cabal repl repl starts in the correct directory and points directly to rather than a dummy, so that reloading works properly. There is a downside to the current approach which is that it uses a different fake-project.cabal file from run and build, so it cannot share the same cache with them. WIP: #7842 WIP: #6149 --- .../src/Distribution/Client/CmdRepl.hs | 85 +++++++++++++++---- .../src/Distribution/Client/ScriptUtils.hs | 20 ++++- 2 files changed, 84 insertions(+), 21 deletions(-) diff --git a/cabal-install/src/Distribution/Client/CmdRepl.hs b/cabal-install/src/Distribution/Client/CmdRepl.hs index fc7880b2370..cec5fb017b9 100644 --- a/cabal-install/src/Distribution/Client/CmdRepl.hs +++ b/cabal-install/src/Distribution/Client/CmdRepl.hs @@ -46,6 +46,8 @@ import Distribution.Client.ProjectPlanning ( ElaboratedSharedConfig(..), ElaboratedInstallPlan ) import Distribution.Client.ProjectPlanning.Types ( elabOrderExeDependencies ) +import Distribution.Client.ScriptUtils + ( getScriptCacheDirectory, isLiterate, readScriptBlockFromScript ) import Distribution.Client.Setup ( GlobalFlags, ConfigFlags(..) ) import qualified Distribution.Client.Setup as Client @@ -85,6 +87,8 @@ import Distribution.Types.PackageDescription ( PackageDescription(..), emptyPackageDescription ) import Distribution.Types.PackageName.Magic ( fakePackageId ) +import Distribution.Types.Executable + ( Executable(..), emptyExecutable ) import Distribution.Types.Library ( Library(..), emptyLibrary ) import Distribution.Types.Version @@ -93,6 +97,8 @@ import Distribution.Types.VersionRange ( anyVersion ) import Distribution.Utils.Generic ( safeHead ) +import Distribution.Utils.Path + ( unsafeMakeSymbolicPath ) import Distribution.Verbosity ( normal, lessVerbose ) import Distribution.Simple.Utils @@ -102,14 +108,18 @@ import Language.Haskell.Extension import Distribution.CabalSpecVersion ( CabalSpecVersion (..) ) +import Control.Monad + ( (<=<) ) +import qualified Data.ByteString.Char8 as BS import Data.List ( (\\) ) import qualified Data.Map as Map import qualified Data.Set as Set import System.Directory - ( getCurrentDirectory, getTemporaryDirectory, removeDirectoryRecursive ) + ( getCurrentDirectory, getTemporaryDirectory, removeDirectoryRecursive + , doesFileExist, canonicalizePath) import System.FilePath - ( () ) + ( (), joinPath, splitPath, pathSeparator, takeFileName ) data EnvFlags = EnvFlags { envPackages :: [Dependency] @@ -345,43 +355,68 @@ withProject cliConfig verbosity targetStrings = do withoutProject :: ProjectConfig -> Verbosity -> [String] -> IO (ProjectBaseContext, [TargetSelector], IO (), ReplType) withoutProject config verbosity extraArgs = do - unless (null extraArgs) $ - die' verbosity $ "'repl' doesn't take any extra arguments when outside a project: " ++ unwords extraArgs + maybeScript <- case extraArgs of + [] -> return Nothing + [script] -> do + exists <- doesFileExist script + if exists + then return $ Just script + else die' verbosity $ "'repl' argument is not an script file: " ++ unwords extraArgs + _ -> die' verbosity $ "'repl' takes a single script argument: " ++ unwords extraArgs - globalTmp <- getTemporaryDirectory - tempDir <- createTempDirectory globalTmp "cabal-repl." + + let + mkTmpDir = do + globalTmp <- getTemporaryDirectory + createTempDirectory globalTmp "cabal-repl." + readExec script = + fmap fst . readScriptBlockFromScript verbosity (isLiterate script) =<< BS.readFile script + + dir <- maybe mkTmpDir (getScriptCacheDirectory . ("repl:" ++)) maybeScript + scriptExecutable <- maybe (return emptyExecutable) readExec maybeScript + -- For scripts, we want to use cwd in hs-source-dirs, but hs-source-dirs wants a relative path + backtocwd <- relativePathBackToCurrentDirectory dir -- We need to create a dummy package that lives in our dummy project. let sourcePackage = SourcePackage { srcpkgPackageId = pkgId , srcpkgDescription = genericPackageDescription - , srcpkgSource = LocalUnpackedPackage tempDir + , srcpkgSource = LocalUnpackedPackage dir , srcpkgDescrOverride = Nothing } genericPackageDescription = emptyGenericPackageDescription & L.packageDescription .~ packageDescription - & L.condLibrary .~ Just (CondNode library [baseDep] []) + & ( if isNothing maybeScript + then L.condLibrary .~ Just (CondNode library [baseDep] []) + else L.condExecutables .~ [("script", CondNode executable (targetBuildDepends eBuildInfo) [])] ) packageDescription = emptyPackageDescription { package = pkgId , specVersion = CabalSpecV2_2 , licenseRaw = Left SPDX.NONE } - library = emptyLibrary { libBuildInfo = buildInfo } - buildInfo = emptyBuildInfo + pkgId = fakePackageId + + library = emptyLibrary { libBuildInfo = lBuildInfo } + lBuildInfo = emptyBuildInfo { targetBuildDepends = [baseDep] , defaultLanguage = Just Haskell2010 } baseDep = Dependency "base" anyVersion mainLibSet - pkgId = fakePackageId - writeGenericPackageDescription (tempDir "fake-package.cabal") genericPackageDescription - - let ghciScriptPath = tempDir "setcwd.ghci" - cwd <- getCurrentDirectory - writeFile ghciScriptPath (":cd " ++ cwd) + executable = scriptExecutable + { modulePath = maybe "" takeFileName maybeScript + , buildInfo = eBuildInfo + { defaultLanguage = + case defaultLanguage eBuildInfo of + just@(Just _) -> just + Nothing -> Just Haskell2010 + , hsSourceDirs = [unsafeMakeSymbolicPath backtocwd] + } + } + eBuildInfo = buildInfo scriptExecutable - distDirLayout <- establishDummyDistDirLayout verbosity config tempDir + distDirLayout <- establishDummyDistDirLayout verbosity config dir baseCtx <- establishDummyProjectBaseContext verbosity @@ -390,12 +425,26 @@ withoutProject config verbosity extraArgs = do [SpecificSourcePackage sourcePackage] OtherCommand + writeGenericPackageDescription (dir "fake-package.cabal") genericPackageDescription + maybe (return ()) (writeFile (dir "scriptlocation") <=< canonicalizePath) maybeScript + + let ghciScriptPath = dir "setcwd.ghci" + cwd <- getCurrentDirectory + writeFile ghciScriptPath (":cd " ++ cwd) + let targetSelectors = [TargetPackage TargetExplicitNamed [pkgId] Nothing] - finalizer = handleDoesNotExist () (removeDirectoryRecursive tempDir) + finalizer | isNothing maybeScript = handleDoesNotExist () (removeDirectoryRecursive dir) + | otherwise = return () return (baseCtx, targetSelectors, finalizer, GlobalRepl ghciScriptPath) +relativePathBackToCurrentDirectory :: FilePath -> IO FilePath +relativePathBackToCurrentDirectory d = do + toRoot <- joinPath . map (const "..") . splitPath . dropWhile (== pathSeparator) <$> canonicalizePath d + cwd <- dropWhile (== pathSeparator) <$> getCurrentDirectory + return $ toRoot cwd + addDepsToProjectTarget :: [Dependency] -> PackageId -> ProjectBaseContext diff --git a/cabal-install/src/Distribution/Client/ScriptUtils.hs b/cabal-install/src/Distribution/Client/ScriptUtils.hs index 42e00a605d2..82fe1b444a5 100644 --- a/cabal-install/src/Distribution/Client/ScriptUtils.hs +++ b/cabal-install/src/Distribution/Client/ScriptUtils.hs @@ -8,7 +8,8 @@ module Distribution.Client.ScriptUtils ( getScriptCacheDirectoryRoot, getScriptCacheDirectory, withTempTempDirectory, - getContextAndSelectorsWithScripts + getContextAndSelectorsWithScripts, + isLiterate, readScriptBlockFromScript ) where import Prelude () @@ -123,8 +124,7 @@ getContextAndSelectorsWithScripts flags@NixStyleFlags {..} targetStrings globalF let scriptOrError script err = do exists <- doesFileExist script - let pol | takeExtension script == ".lhs" = LiterateHaskell - | otherwise = PlainHaskell + let pol = isLiterate script if exists then do cacheDir <- getScriptCacheDirectory script @@ -165,6 +165,14 @@ parseScriptBlock str = readScriptBlock :: Verbosity -> BS.ByteString -> IO Executable readScriptBlock verbosity = parseString parseScriptBlock verbosity "script block" +-- | Extract the first encountered script metadata block started end +-- terminated by the bellow tokens or die. +-- +-- * @{- cabal:@ +-- +-- * @-}@ +-- +-- Return the metadata and the contents of the file without the #! line. readScriptBlockFromScript :: Verbosity -> PlainOrLiterate -> BS.ByteString -> IO (Executable, BS.ByteString) readScriptBlockFromScript verbosity pol str = do str' <- case extractScriptBlock pol str of @@ -213,6 +221,12 @@ data PlainOrLiterate = PlainHaskell | LiterateHaskell +-- | Test if a filepath is for a literate Haskell file. +-- +isLiterate :: FilePath -> PlainOrLiterate +isLiterate p | takeExtension p == ".lhs" = LiterateHaskell + | otherwise = PlainHaskell + handleScriptCase :: Verbosity -> PlainOrLiterate