scripths 0.2.0.2 → 0.3.0.0

raw patch · 7 files changed

+126/−63 lines, 7 filesdep +directorydep −temporaryPVP ok

version bump matches the API change (PVP)

Dependencies added: directory

Dependencies removed: temporary

API changes (from Hackage documentation)

Files

• app/Main.hs +1/−1
• scripths.cabal +4/−3
• src/ScriptHs/Notebook.hs +8/−7
• src/ScriptHs/Run.hs +81/−50
• test/Main.hs +2/−0
• test/Test/Notebook.hs +2/−2
• test/Test/Run.hs +28/−0

@@ -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

@@ -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,

@@ -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

@@ -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

@@ -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             ]

@@ -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             ]         ]

@@ -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+            ]+        ]