diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -26,7 +26,7 @@ _ -> do contents <- TIO.readFile path let sf = parseScript contents - runScript sf + runScript path sf -- TODO: This is kinda brittle but I don't wanna -- include the whole opt parser lib just to diff --git a/scripths.cabal b/scripths.cabal --- a/scripths.cabal +++ b/scripths.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: scripths -version: 0.2.0.2 +version: 0.3.0.0 synopsis: GHCi scripts for standalone execution and Markdown documentation. description: GHCi scripts for standalone execution (with dependency resolution) and Markdown documentation (produces inline output). homepage: https://www.datahaskell.org/ @@ -29,9 +29,9 @@ ScriptHs.Notebook, ScriptHs.Run build-depends: base >= 4 && < 5, + directory >= 1.3 && < 1.4, filepath >= 1.4 && < 1.6, process >= 1.6 && < 1.8, - temporary >= 1.3 && < 1.4, text >= 2.0 && < 3 hs-source-dirs: src default-language: Haskell2010 @@ -58,7 +58,8 @@ other-modules: Test.Parser, Test.Render, Test.Markdown, - Test.Notebook + Test.Notebook, + Test.Run build-depends: base >= 4 && < 5, scripths, diff --git a/src/ScriptHs/Notebook.hs b/src/ScriptHs/Notebook.hs --- a/src/ScriptHs/Notebook.hs +++ b/src/ScriptHs/Notebook.hs @@ -27,24 +27,25 @@ runNotebook :: FilePath -> Maybe FilePath -> IO () runNotebook path outputPath = do contents <- TIO.readFile path - outputMd <- processNotebook contents + outputMd <- processNotebook path contents case outputPath of Nothing -> TIO.putStr outputMd Just output -> TIO.writeFile output outputMd -processNotebook :: Text -> IO Text -processNotebook contents = do +processNotebook :: FilePath -> Text -> IO Text +processNotebook notebookPath contents = do let indexedSegments = zip [0 ..] (parseMarkdown contents) (metas, indexedCodeBlocks) = parseBlocks indexedSegments if null indexedCodeBlocks then pure contents - else executeCodeCells metas indexedSegments indexedCodeBlocks + else executeCodeCells notebookPath metas indexedSegments indexedCodeBlocks -executeCodeCells :: CabalMeta -> IndexedSegments -> IndexedBlocks -> IO Text -executeCodeCells meta allSegments codeBlocks = do +executeCodeCells :: + FilePath -> CabalMeta -> IndexedSegments -> IndexedBlocks -> IO Text +executeCodeCells notebookPath meta allSegments codeBlocks = do let ghciScript = generatedMarkedScript codeBlocks sf = ScriptFile{scriptMeta = meta, scriptLines = ghciScript} - rawOutput <- runScriptCapture sf + rawOutput <- runScriptCapture notebookPath sf let outputs = splitByMarkers rawOutput (map fst codeBlocks) blocksWithOutput = addOutputToSegments outputs allSegments pure $ reassemble blocksWithOutput diff --git a/src/ScriptHs/Run.hs b/src/ScriptHs/Run.hs --- a/src/ScriptHs/Run.hs +++ b/src/ScriptHs/Run.hs @@ -2,86 +2,117 @@ module ScriptHs.Run where +import Control.Monad (unless) +import Data.Char (isAlphaNum) +import Data.List (intercalate) import qualified Data.Text as T import qualified Data.Text.IO as TIO import ScriptHs.Parser ( CabalMeta (..), + Line, ScriptFile (scriptLines, scriptMeta), ) import ScriptHs.Render (toGhciScript) +import System.Directory ( + createDirectoryIfMissing, + doesFileExist, + getCurrentDirectory, + getHomeDirectory, + makeAbsolute, + ) import System.Exit (ExitCode (..), exitWith) import System.FilePath (()) import System.IO (stderr) -import System.IO.Temp (withSystemTempDirectory) import System.Process ( - CreateProcess (delegate_ctlc), + CreateProcess (cwd, delegate_ctlc), createProcess, proc, - readProcessWithExitCode, + readCreateProcessWithExitCode, waitForProcess, ) -runScript :: ScriptFile -> IO () +runScript :: FilePath -> ScriptFile -> IO () runScript = runWithCont runGhc -runScriptCapture :: ScriptFile -> IO T.Text +runScriptCapture :: FilePath -> ScriptFile -> IO T.Text runScriptCapture = runWithCont captureGhc -runWithCont :: (FilePath -> CabalMeta -> FilePath -> IO a) -> ScriptFile -> IO a -runWithCont cont sf = withSystemTempDirectory "scripths" $ \tmpDir -> do - (ghciPath, envPath) <- createScriptAndEnvironment sf tmpDir - cont envPath (scriptMeta sf) ghciPath +runWithCont :: + (FilePath -> FilePath -> FilePath -> IO a) -> FilePath -> ScriptFile -> IO a +runWithCont cont scriptPath sf = do + scriptAbsPath <- makeAbsolute scriptPath + userCwd <- getCurrentDirectory + projectDir <- ensureProject scriptAbsPath (scriptMeta sf) (scriptLines sf) + cont userCwd projectDir (projectDir "script.ghci") -createScriptAndEnvironment :: ScriptFile -> FilePath -> IO (FilePath, FilePath) -createScriptAndEnvironment sf tmpDir = do - let ghciPath = tmpDir "script.ghci" - envPath = tmpDir ".ghc.environment" - sm = scriptMeta sf - TIO.writeFile ghciPath (toGhciScript (scriptLines sf)) - resolveDeps envPath (metaDeps sm <> ["base"]) - pure (ghciPath, envPath) +deriveProjectName :: FilePath -> String +deriveProjectName path = + let sanitized = map (\c -> if isAlphaNum c then c else '-') path + in dropWhile (== '-') sanitized -captureGhc :: FilePath -> CabalMeta -> FilePath -> IO T.Text -captureGhc env meta ghciPath = do - let args = ghcArgs env meta ghciPath - (code, out, err) <- readProcessWithExitCode "ghc" args "" +ensureProject :: FilePath -> CabalMeta -> [Line] -> IO FilePath +ensureProject scriptAbsPath meta scriptCode = do + home <- getHomeDirectory + let name = deriveProjectName scriptAbsPath + projectDir = home ".scripths" name + createDirectoryIfMissing True projectDir + let cabalProjectPath = projectDir "cabal.project" + cabalProjectExists <- doesFileExist cabalProjectPath + unless cabalProjectExists $ writeFile cabalProjectPath "packages: .\n" + let mainHsPath = projectDir "Main.hs" + mainHsExists <- doesFileExist mainHsPath + unless mainHsExists $ writeFile mainHsPath "main :: IO ()\nmain = pure ()\n" + writeFile (projectDir (name ++ ".cabal")) (renderCabalFile name meta) + TIO.writeFile (projectDir "script.ghci") (toGhciScript scriptCode) + pure projectDir + +renderCabalFile :: String -> CabalMeta -> String +renderCabalFile name CabalMeta{metaDeps, metaExts, metaGhcOptions} = + let deps = "base" : map T.unpack metaDeps + depsStr = intercalate ", " deps + extsStr = intercalate ", " (map T.unpack metaExts) + optsStr = unwords (map T.unpack metaGhcOptions) + in unlines + [ "cabal-version: 3.0" + , "name: " ++ name + , "version: 0.1.0.0" + , "" + , "executable main" + , " main-is: Main.hs" + , " hs-source-dirs: ." + , " default-language: Haskell2010" + , " build-depends: " ++ depsStr + , " default-extensions: " ++ extsStr + , " ghc-options: " ++ optsStr + ] + +cabalArgs :: FilePath -> FilePath -> [String] +cabalArgs projectDir ghciPath = + [ "repl" + , "exe:main" + , "--project-dir=" ++ projectDir + , "--repl-option=-ghci-script=" ++ ghciPath + , "--repl-option=-e" + , "--repl-option=return()" + ] + +captureGhc :: FilePath -> FilePath -> FilePath -> IO T.Text +captureGhc userCwd projectDir ghciPath = do + let args = "-v0" : cabalArgs projectDir ghciPath + cp = (proc "cabal" args){cwd = Just userCwd} + (code, out, err) <- readCreateProcessWithExitCode cp "" case code of ExitSuccess -> pure (T.pack $ out <> err) ExitFailure _ -> do TIO.hPutStrLn stderr (T.pack err) exitWith code -runGhc :: FilePath -> CabalMeta -> FilePath -> IO () -runGhc env meta ghciPath = do - let args = ghcArgs env meta ghciPath - cp = (proc "ghc" args){delegate_ctlc = True} +runGhc :: FilePath -> FilePath -> FilePath -> IO () +runGhc userCwd projectDir ghciPath = do + let args = "-v0" : cabalArgs projectDir ghciPath + cp = (proc "cabal" args){cwd = Just userCwd, delegate_ctlc = True} (_, _, _, ph) <- createProcess cp code <- waitForProcess ph case code of ExitSuccess -> pure () ExitFailure _ -> exitWith code - -ghcArgs :: FilePath -> CabalMeta -> FilePath -> [String] -ghcArgs env CabalMeta{metaExts, metaGhcOptions} ghciPath = - let envFlags = ["-package-env=" ++ env] - extFlags = map (\e -> "-X" ++ T.unpack e) metaExts - optFlags = map T.unpack metaGhcOptions - scriptArg = ":script " ++ ghciPath - in envFlags ++ extFlags ++ optFlags ++ ["-e", scriptArg] - -resolveDeps :: FilePath -> [T.Text] -> IO () -resolveDeps _ [] = pure () -resolveDeps envPath deps = do - let args = - ["-v0", "install", "--lib", "--package-env=" ++ envPath, "--force-reinstalls"] - ++ map T.unpack deps - cp = (proc "cabal" args){delegate_ctlc = True} - (_, _, _, ph) <- createProcess cp - code <- waitForProcess ph - case code of - ExitSuccess -> pure () - ExitFailure n -> do - TIO.hPutStrLn - stderr - (T.pack ("scripths: cabal install --lib failed (exit " ++ show n ++ ")")) - exitWith code diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -6,6 +6,7 @@ import Test.Notebook (notebookTests) import Test.Parser (parseTests) import Test.Render (renderTests) +import Test.Run (runTests) main :: IO () main = @@ -16,4 +17,5 @@ , renderTests , markdownTests , notebookTests + , runTests ] diff --git a/test/Test/Notebook.hs b/test/Test/Notebook.hs --- a/test/Test/Notebook.hs +++ b/test/Test/Notebook.hs @@ -191,7 +191,7 @@ "processNotebook" [ testCase "no code blocks => returns input unchanged" $ do let input = T.unlines ["# Title", "", "Just prose.", ""] - out <- processNotebook input + out <- processNotebook "" input out @?= input , testCase "non-haskell code blocks only => returns input unchanged" $ do let input = @@ -204,7 +204,7 @@ , "" , "more prose" ] - out <- processNotebook input + out <- processNotebook "" input out @?= input ] ] diff --git a/test/Test/Run.hs b/test/Test/Run.hs new file mode 100644 --- /dev/null +++ b/test/Test/Run.hs @@ -0,0 +1,28 @@ +module Test.Run (runTests) where + +import Data.List (isPrefixOf) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, testCase, (@?=)) + +import ScriptHs.Run (cabalArgs) + +runTests :: TestTree +runTests = + testGroup + "Run" + [ testGroup + "cabalArgs" + [ testCase "uses -ghci-script= and -e return() for batch mode" $ do + let args = cabalArgs "/proj" "/proj/script.ghci" + replyOpts = filter ("--repl-option=" `isPrefixOf`) args + replyOpts + @?= [ "--repl-option=-ghci-script=/proj/script.ghci" + , "--repl-option=-e" + , "--repl-option=return()" + ] + , testCase "includes --project-dir" $ do + let args = cabalArgs "/proj" "/proj/script.ghci" + assertBool "--project-dir present" $ + any ("--project-dir=" `isPrefixOf`) args + ] + ]