scripths 0.3.3.0 → 0.4.0.0

raw patch · 11 files changed

+546/−68 lines, 11 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +23/−0
• README.md +42/−5
• app/Main.hs +73/−23
• scripths.cabal +1/−1
• src/ScriptHs/Markdown.hs +43/−5
• src/ScriptHs/Parser.hs +10/−2
• src/ScriptHs/Run.hs +172/−24
• test/Test/Markdown.hs +99/−4
• test/Test/Parser.hs +11/−1
• test/Test/Render.hs +1/−1
• test/Test/Run.hs +71/−2

@@ -1,5 +1,28 @@ # Revision history for scripths +## 0.4.0.0 -- 2026-05-29++* **`OverloadedStrings` on by default** in every scripths repl, so string literals+  work directly as `Text` / `ByteString`.+* **Compile-time Template Haskell now sees your working directory**: notebooks+  using TH (e.g. `$(declareTable "./data/x.db" …)`) have their body bracketed with+  a compile-time `setCurrentDirectory`, so splices that read files at compile time+  resolve `./relative` paths against your tree instead of the throwaway project+  dir. Only added when the notebook actually uses TH.+* **In-place notebooks**: `-i` / `--in-place` rewrites a notebook over itself,+  stripping and replacing previously rendered output. `reassemble` is now+  idempotent — re-running no longer accumulates blank lines around code fences.+* **Inline block errors**: a code block that fails to compile now renders its GHC+  diagnostic beneath the block (stdout and stderr are captured as one ordered+  stream) instead of producing silent empty output.+* **Second local package**: new `-- cabal: packages: <dir>, …` directive for+  depending on non-enclosing local packages (relative to the script). Local+  package names — from `packages:`, `--package`, or the enclosing project — are+  now added to the synthetic `build-depends` automatically, so their modules+  import without a separate `build-depends` line.+* **Output marker renamed** from `sabela:mime` to `scripths:mime`. The legacy+  marker is still recognised when re-parsing older notebooks.+ ## 0.3.3.0 -- 2026-05-24  * Build against **local packages**: auto-include the enclosing cabal project when a

@@ -7,9 +7,11 @@ ## Features  - **Standalone `.ghci` execution** — Run GHCi scripts directly from the command line, with automatic dependency.-- **Cabal metadata directives** — Declare `build-depends`, `default-extensions`, and `ghc-options` inline using `-- cabal:` comments.-- **Markdown notebooks** — Execute Haskell code blocks inside Markdown files and render the output back into the document as block quotes.+- **Cabal metadata directives** — Declare `build-depends`, `default-extensions`, `ghc-options`, and local `packages` inline using `-- cabal:` comments.+- **Markdown notebooks** — Execute Haskell code blocks inside Markdown files and render the output back into the document as block quotes. Re-run in place with `-i` — output is replaced cleanly, with no accumulating blank lines.+- **Inline errors** — A block that fails to compile renders its GHC error beneath the block instead of producing silent empty output. - **Smart GHCi rendering** — Multi-line definitions are automatically wrapped in `:{`/`:}` blocks, and IO binds / Template Haskell splices are handled correctly as individual statements.+- **Compile-time TH reads your tree** — A splice that reads a file at compile time (e.g. `$(declareTable "./data/x.db" …)`) resolves `./relative` paths against the directory you ran `scripths` from, not the internal build directory.  ## Installation @@ -20,11 +22,13 @@ ## CLI Usage  ```-scripths [-o FILE | --output=FILE] [-p DIR | --package DIR]... [--no-local-project] <script>+scripths [-o FILE | --output=FILE] [-i | --in-place] [-p DIR | --package DIR]... [--no-local-project] [-h | --help] <script> ``` -When `-o` / `--output` is provided for Markdown files, the result is written to that path. Otherwise it is printed to stdout. The file extension determines the mode. `.ghci` / `hs` files are parsed and executed as a standalone GHCi script. `.md` / `.markdown` files are processed as a notebook with captured output.+When `-o` / `--output` is provided for Markdown files, the result is written to that path. Otherwise it is printed to stdout. With `-i` / `--in-place` the notebook is rewritten in place: any previously rendered output is stripped and replaced, and re-running is idempotent (it does not accumulate blank lines). `-i` is only valid for `.md` / `.markdown` notebooks and cannot be combined with `-o`. +The file extension determines the mode. `.ghci` / `hs` files are parsed and executed as a standalone GHCi script. `.md` / `.markdown` files are processed as a notebook with captured output. Run `scripths --help` for the full option and directive list.+ Requires GHC and cabal-install on your PATH.  ## Quick Start@@ -86,8 +90,17 @@ scripths -o output.md notebook.md ``` -Each Haskell code block is evaluated in order, and its output is inserted into the Markdown as a block quote beneath the code fence.+Each Haskell code block is evaluated in order, and its output is inserted into the Markdown as a block quote beneath the code fence (tagged with a `<!-- scripths:mime … -->` marker so a later run can find and replace it). If a block fails to compile, its GHC error is rendered inline beneath that block rather than vanishing. +> **Tip:** each code block should end in a single bare expression so it is auto-printed. A block that ends in a `<-` bind (or several `;`-joined statements) prints nothing — repeat the bound name on a final line to print it:+>+> ````markdown+> ```haskell+> x <- pure 42+> x+> ```+> ````+ ## Cabal Metadata Directives  You can declare dependencies, language extensions, and GHC options directly inside your scripts using `-- cabal:` comments:@@ -96,8 +109,14 @@ -- cabal: build-depends: text, containers -- cabal: default-extensions: OverloadedStrings, TypeApplications -- cabal: ghc-options: -Wall+-- cabal: packages: ../sibling-pkg+-- cabal: source-repository-package: https://github.com/owner/repo v1.2.3 ``` +The recognised keys are `build-depends`, `default-extensions`, `ghc-options`, `packages` (extra local package directories, relative to the script), and `source-repository-package`. An unrecognised key is reported as a warning.++`OverloadedStrings` is enabled in every scripths repl by default, so string literals work directly as `Text` / `ByteString`; add any further extensions with `default-extensions`.+ ## Local packages  By default `build-depends` resolve from Hackage. To build a script or notebook@@ -130,6 +149,24 @@ ```bash scripths --package ../granite -o out.md in.md ```++The package's name is read from its `.cabal` and added to the script's+`build-depends` automatically, so its modules are importable without also listing+it in a `-- cabal: build-depends:` line.++### `packages:` directive (committed into the document)++To depend on one or more local packages *from inside the document itself* — for+example a second, non-enclosing package in the same repo — list their directories+(relative to the script) with a `packages` directive:++```+-- cabal: packages: ../sibling-pkg, ../another-local+```++Like `--package`, each named package's name is added to `build-depends`+automatically. Unlike `--package`, the dependency travels with the document. Paths+are resolved relative to the script file.  ### Pinned git packages (`source-repository-package`) 

@@ -2,6 +2,7 @@  import Control.Monad (unless, when) import Data.List (isPrefixOf)+import Data.Maybe (isJust) import qualified Data.Text.IO as TIO import System.Directory (     doesDirectoryExist,@@ -9,7 +10,7 @@     makeAbsolute,  ) import System.Environment (getArgs, getProgName)-import System.Exit (exitFailure)+import System.Exit (exitFailure, exitSuccess) import System.FilePath (takeExtension) import System.IO (hPutStrLn, stderr) @@ -23,27 +24,49 @@     , argOutput :: Maybe FilePath     , argPackages :: [FilePath]     , argNoLocalProject :: Bool+    , argInPlace :: Bool+    , argHelp :: Bool     }  emptyArgs :: Args-emptyArgs = Args Nothing Nothing [] False+emptyArgs = Args Nothing Nothing [] False False False  main :: IO () main = do     raw <- getArgs     case parseArgs raw of         Left err -> hPutStrLn stderr ("scripths: " ++ err) >> usage-        Right a -> case argScript a of-            Nothing -> usage-            Just path -> do-                pkgs <- mapM resolvePackageDir (argPackages a)-                let opts =-                        defaultRunOptions-                            { roPackages = pkgs-                            , roEnclosingProject = not (argNoLocalProject a)-                            }-                dispatch opts path (argOutput a)+        Right a+            | argHelp a -> help+            | otherwise -> case argScript a of+                Nothing -> usage+                Just path -> do+                    outPath <- resolveOutput a path+                    pkgs <- mapM resolvePackageDir (argPackages a)+                    let opts =+                            defaultRunOptions+                                { roPackages = pkgs+                                , roEnclosingProject = not (argNoLocalProject a)+                                }+                    dispatch opts path outPath +{- | Resolve the output destination, honouring @--in-place@: write back over the+notebook itself. In-place is only meaningful for notebooks (the @.ghci@\/@.hs@+path streams to stdout) and conflicts with an explicit @-o@.+-}+resolveOutput :: Args -> FilePath -> IO (Maybe FilePath)+resolveOutput a path+    | argInPlace a && isJust (argOutput a) =+        die "--in-place cannot be combined with -o/--output"+    | argInPlace a =+        if isNotebook path+            then pure (Just path)+            else die "--in-place only applies to .md/.markdown notebooks"+    | otherwise = pure (argOutput a)++isNotebook :: FilePath -> Bool+isNotebook path = takeExtension path `elem` [".md", ".markdown"]+ dispatch :: RunOptions -> FilePath -> Maybe FilePath -> IO () dispatch opts path outputPath =     case takeExtension path of@@ -54,9 +77,9 @@             let sf = parseScript contents             runScript opts path sf -{- | Parse args: @[-o FILE | --output=FILE] [--package DIR | -p DIR |---package=DIR]... [--no-local-project] <script>@. The script is the sole-non-flag argument.+{- | Parse args: @[-o FILE | --output=FILE] [-i | --in-place] [--package DIR |+-p DIR | --package=DIR]... [--no-local-project] [-h | --help] <script>@. The+script is the sole non-flag argument. -} parseArgs :: [String] -> Either String Args parseArgs = go emptyArgs@@ -72,6 +95,8 @@         | Just d <- stripFlag "--package=" tok =             go a{argPackages = argPackages a ++ [d]} rest         | tok == "--no-local-project" = go a{argNoLocalProject = True} rest+        | tok == "-i" || tok == "--in-place" = go a{argInPlace = True} rest+        | tok == "-h" || tok == "--help" = go a{argHelp = True} rest         | "-" `isPrefixOf` tok = Left ("unknown flag: " ++ tok)         | otherwise = case argScript a of             Nothing -> go a{argScript = Just tok} rest@@ -92,12 +117,37 @@ die :: String -> IO a die msg = hPutStrLn stderr ("scripths: " ++ msg) >> exitFailure +-- | Full help, to stdout, exit success.+help :: IO ()+help = getProgName >>= putStr . helpText >> exitSuccess++-- | Synopsis + a parse-error hint, to stderr, exit failure. usage :: IO ()-usage = do-    prog <- getProgName-    putStrLn $-        "Usage: "-            ++ prog-            ++ " [-o FILE | --output=FILE] [-p DIR | --package DIR]..."-            ++ " [--no-local-project] <script>"-    exitFailure+usage = getProgName >>= hPutStrLn stderr . helpText >> exitFailure++helpText :: String -> String+helpText prog =+    unlines+        [ "Usage: " ++ prog ++ " [OPTIONS] <script>"+        , ""+        , "Run a .ghci/.hs script, or a .md/.markdown notebook (rendering each"+        , "code block's output inline)."+        , ""+        , "Options:"+        , "  -o FILE, --output=FILE   write notebook output to FILE"+        , "  -i, --in-place           rewrite the notebook in place (overwrite <script>)"+        , "  -p DIR, --package DIR     add a local package dir (also --package=DIR)"+        , "  --no-local-project        do not auto-include the enclosing cabal project"+        , "  -h, --help                show this help"+        , ""+        , "In-script directives (lines beginning '-- cabal:'):"+        , "  -- cabal: build-depends: pkg1, pkg2"+        , "  -- cabal: default-extensions: OverloadedStrings, LambdaCase"+        , "  -- cabal: ghc-options: -Wall"+        , "  -- cabal: packages: ../sibling-pkg        (extra local package dirs)"+        , "  -- cabal: source-repository-package: <git-url> <ref> [subdir]"+        , ""+        , "Each code block should end in a single bare expression to be auto-printed;"+        , "a block ending in a '<-' bind prints nothing — repeat the bound name on a"+        , "final line to print it."+        ]

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               scripths-version:            0.3.3.0+version:            0.4.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/

@@ -33,7 +33,7 @@ parseMarkdown' acc [] = [Prose prose | not (T.null prose)]   where     prose = T.unlines acc-parseMarkdown' acc (line : rest) = case T.strip <$> T.stripPrefix fence line of+parseMarkdown' acc (line : rest) = case fenceLang line of     Nothing -> parseMarkdown' (acc ++ [line]) rest     Just lang ->         let@@ -41,7 +41,7 @@             (codeLines, rest') = fmap (drop 1) (break ((== fence) . T.strip) rest)             (output, rest'') = case dropWhile ((== "") . T.strip) rest' of                 (x : xs) ->-                    if not (T.isPrefixOf "> <!-- sabela:mime" x)+                    if not (isMimeMarkerLine x)                         then (Nothing, rest')                         else                             let@@ -61,13 +61,50 @@ fence :: Text fence = "```" +{- | The language tag of a code-fence /opener/, or 'Nothing' if the line is not+one. A fence is /exactly/ three backticks (optionally followed by a language+tag) — a line of four or more backticks is not a fence and stays prose.+-}+fenceLang :: Text -> Maybe Text+fenceLang line = do+    rest <- T.stripPrefix fence line+    if "`" `T.isPrefixOf` rest then Nothing else Just (T.strip rest)++{- | The HTML-comment marker that tags a code block's rendered output with its+MIME type. We render the @scripths:mime@ form; for backward compatibility we+still recognise the legacy @sabela:mime@ marker when re-parsing older notebooks.+-}+mimeMarker :: Text+mimeMarker = "<!-- scripths:mime "++-- | Does this line open a rendered-output block (either marker spelling)?+isMimeMarkerLine :: Text -> Bool+isMimeMarkerLine x =+    T.isPrefixOf "> <!-- scripths:mime" x || T.isPrefixOf "> <!-- sabela:mime" x+ fenceCodeSegment :: Text -> Text -> Text fenceCodeSegment lang output     | T.null (T.strip output) = ""     | otherwise = T.unlines ["", fence <> lang, T.stripEnd output, fence, ""] +{- | Render segments back to markdown idempotently: the blank-line run at each+seam between segments collapses to one blank line and the document's leading/+trailing blanks are trimmed, so re-running (e.g. @--in-place@) adds no new lines.+-} reassemble :: [Segment] -> Text-reassemble = T.concat . map renderSegment+reassemble = finalize . foldr (joinSeam . renderSegment) ""+  where+    joinSeam "" acc = acc+    joinSeam piece "" = piece+    joinSeam piece acc =+        T.dropWhileEnd (== '\n') piece+            <> T.replicate (min 2 (trailingNL piece + leadingNL acc)) "\n"+            <> T.dropWhile (== '\n') acc+    trailingNL = T.length . T.takeWhileEnd (== '\n')+    leadingNL = T.length . T.takeWhile (== '\n')+    finalize t =+        let stripped = T.dropWhileEnd (== '\n') (T.dropWhile (== '\n') t)+         in if T.null stripped then "" else stripped <> "\n"  renderSegment :: Segment -> Text renderSegment (Prose t) = t@@ -77,7 +114,7 @@ blockQuote :: CodeOutput -> Text blockQuote (CodeOutput mimeType t) =     let-        ls = ("<!-- sabela:mime " <> mimeIndicator mimeType <> " -->") : T.lines t+        ls = (mimeMarker <> mimeIndicator mimeType <> " -->") : T.lines t         trimmed = reverse $ dropWhile T.null $ reverse ls         quoted = T.unlines $ map (\l -> if T.null l then "> " else "> " <> l) trimmed      in@@ -101,5 +138,6 @@     | T.isInfixOf "text/latex" t = MimeLatex     | T.isInfixOf "application/json" t = MimeJson     | T.isInfixOf "base64" t =-        MimeImage (T.takeWhile (/= ';') (T.drop (T.length "<!-- sabela:mime ") t))+        -- The part after "mime " up to the ";base64", regardless of marker name.+        MimeImage (T.strip (T.takeWhile (/= ';') (snd (T.breakOnEnd "mime " t))))     | otherwise = MimePlain

@@ -57,6 +57,11 @@     -- ^ Extensions from @default-extensions@ directives.     , metaGhcOptions :: [Text]     -- ^ Flags from @ghc-options@ directives.+    , metaPackages :: [Text]+    {- ^ Extra local package dirs from @packages@ directives, resolved relative+    to the script file (lets a notebook depend on a second, non-enclosing local+    package, e.g. @-- cabal: packages: ../sibling@).+    -}     , metaSourceRepos :: [SourceRepoPin]     -- ^ Pinned git packages from @source-repository-package@ directives.     , metaUnknownKeys :: [Text]@@ -105,10 +110,10 @@ Example:  >>> parseScript "-- cabal: build-depends: text\nimport Data.Text (Text)\n"-ScriptFile {scriptMeta = CabalMeta {metaDeps = ["text"], metaExts = [], metaGhcOptions = [], metaSourceRepos = [], metaUnknownKeys = []}, scriptLines = [Import "import Data.Text (Text)"]}+ScriptFile {scriptMeta = CabalMeta {metaDeps = ["text"], metaExts = [], metaGhcOptions = [], metaPackages = [], metaSourceRepos = [], metaUnknownKeys = []}, scriptLines = [Import "import Data.Text (Text)"]}  >>> parseScript ""-ScriptFile {scriptMeta = CabalMeta {metaDeps = [], metaExts = [], metaGhcOptions = [], metaSourceRepos = [], metaUnknownKeys = []}, scriptLines = []}+ScriptFile {scriptMeta = CabalMeta {metaDeps = [], metaExts = [], metaGhcOptions = [], metaPackages = [], metaSourceRepos = [], metaUnknownKeys = []}, scriptLines = []} -} parseScript :: Text -> ScriptFile parseScript input =@@ -134,6 +139,7 @@         { metaDeps = concatMap metaDeps ms         , metaExts = concatMap metaExts ms         , metaGhcOptions = concatMap metaGhcOptions ms+        , metaPackages = concatMap metaPackages ms         , metaSourceRepos = concatMap metaSourceRepos ms         , metaUnknownKeys = concatMap metaUnknownKeys ms         }@@ -155,6 +161,7 @@                 "build-depends" -> emptyCabal{metaDeps = items}                 "default-extensions" -> emptyCabal{metaExts = items}                 "ghc-options" -> emptyCabal{metaGhcOptions = items}+                "packages" -> emptyCabal{metaPackages = items}                 "source-repository-package" ->                     emptyCabal{metaSourceRepos = maybeToList (parseSourceRepo value)}                 other -> emptyCabal{metaUnknownKeys = [other]}@@ -165,6 +172,7 @@             { metaDeps = []             , metaExts = []             , metaGhcOptions = []+            , metaPackages = []             , metaSourceRepos = []             , metaUnknownKeys = []             }

@@ -10,7 +10,7 @@ import qualified Data.Text.IO as TIO import ScriptHs.Parser (     CabalMeta (..),-    Line,+    Line (..),     ScriptFile (scriptLines, scriptMeta),     SourceRepoPin (..),  )@@ -27,10 +27,11 @@ import System.FilePath (takeDirectory, takeExtension, (</>)) import System.IO (stderr) import System.Process (-    CreateProcess (cwd, delegate_ctlc),+    CreateProcess (cwd, delegate_ctlc, std_err, std_out),+    StdStream (UseHandle),+    createPipe,     createProcess,     proc,-    readCreateProcessWithExitCode,     waitForProcess,  ) @@ -65,7 +66,8 @@     scriptAbsPath <- makeAbsolute scriptPath     userCwd <- getCurrentDirectory     warnUnknownKeys (metaUnknownKeys (scriptMeta sf))-    projectDir <- ensureProject opts scriptAbsPath (scriptMeta sf) (scriptLines sf)+    projectDir <-+        ensureProject opts userCwd scriptAbsPath (scriptMeta sf) (scriptLines sf)     cont userCwd projectDir (projectDir </> "script.ghci")  -- | Warn (once each) about unrecognised @-- cabal:@ directive keys.@@ -75,13 +77,22 @@         (\k -> TIO.hPutStrLn stderr ("scripths: warning: unknown '-- cabal:' key: " <> k))         (nub keys) +{- | Turn a script path into a valid cabal package name: non-alphanumerics become+@-@, runs of @-@ collapse to one, and leading/trailing @-@ are stripped (so a name+like @_probe.md@ does not yield an internal @--@, which cabal rejects).+-} deriveProjectName :: FilePath -> String-deriveProjectName path =-    let sanitized = map (\c -> if isAlphaNum c then c else '-') path-     in dropWhile (== '-') sanitized+deriveProjectName =+    trimDash . collapseDashes . map (\c -> if isAlphaNum c then c else '-')+  where+    collapseDashes ('-' : xs) = '-' : collapseDashes (dropWhile (== '-') xs)+    collapseDashes (x : xs) = x : collapseDashes xs+    collapseDashes [] = []+    trimDash = f . f where f = reverse . dropWhile (== '-') -ensureProject :: RunOptions -> FilePath -> CabalMeta -> [Line] -> IO FilePath-ensureProject opts scriptAbsPath meta scriptCode = do+ensureProject ::+    RunOptions -> FilePath -> FilePath -> CabalMeta -> [Line] -> IO FilePath+ensureProject opts userCwd scriptAbsPath meta scriptCode = do     home <- getHomeDirectory     let name = deriveProjectName scriptAbsPath         projectDir = home </> ".scripths" </> name@@ -90,17 +101,114 @@         if roEnclosingProject opts             then enclosingProjectFor scriptAbsPath (metaDeps meta)             else pure []-    let localPkgs = nub (roPackages opts ++ enclosing)+    -- @-- cabal: packages:@ dirs are relative to the script file, not the cwd.+    let scriptDir = takeDirectory scriptAbsPath+    metaPkgDirs <-+        mapM (makeAbsolute . (scriptDir </>) . T.unpack) (metaPackages meta)+    let localPkgs = nub (roPackages opts ++ metaPkgDirs ++ enclosing)     writeManagedCabalProject         (projectDir </> "cabal.project")         (renderCabalProject localPkgs (metaSourceRepos meta))+    -- A local package only imports if its name is also a build-depend; collect+    -- the names so renderCabalFile can add them (and warn on dirs without one).+    localNames <- localPackageNames localPkgs+    -- When the notebook uses Template Haskell, its splices read files at compile+    -- time; bracket the body with compile-time chdirs so those resolve against+    -- the user's tree (see 'compileCdTo'). This needs @template-haskell@.+    let th = usesTemplateHaskell meta scriptCode+        extraDeps = localNames ++ ["template-haskell" | th]     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)+    writeFile+        (projectDir </> (name ++ ".cabal"))+        (renderCabalFile name extraDeps meta)+    let body+            | th =+                compileCdSetup+                    <> compileCdTo userCwd+                    <> toGhciScript scriptCode+                    <> compileCdTo projectDir+            | otherwise = toGhciScript scriptCode+    TIO.writeFile+        (projectDir </> "script.ghci")+        (autoPrintDirective <> cdDirective userCwd <> body)     pure projectDir +{- | Make GHCi auto-print a trailing 'String' result /raw/ (via 'putStr')+instead of @show@-escaping it into a quoted one-line literal. This lets a+notebook cell end in @df |> toMarkdown'@ and have the markdown actually render,+with no explicit 'putStrLn'. Every non-'String' result still prints via @show@,+so tuples, @Either@, dataframes, etc. are unaffected.+-}+autoPrintDirective :: T.Text+autoPrintDirective =+    T.unlines+        [ ":set -XFlexibleInstances -XUndecidableInstances"+        , "class ScripthsAutoPrint a where scripthsAutoPrint :: a -> IO ()"+        , "instance {-# OVERLAPPING #-} ScripthsAutoPrint String where scripthsAutoPrint = putStr"+        , "instance {-# OVERLAPPABLE #-} Show a => ScripthsAutoPrint a where scripthsAutoPrint = print"+        , ":set -interactive-print scripthsAutoPrint"+        ]++{- | A GHCi preamble that changes the /process/ working directory to the dir+@scripths@ was invoked from, so a script can read @./data/foo.csv@ relative to+the user's working tree (the throwaway project lives under @~\/.scripths@).++We use @System.Directory.setCurrentDirectory@ rather than GHCi's @:cd@: @:cd@+unloads every loaded module (which breaks the @cabal repl@ session), whereas a+plain IO action does not. @show@ renders a correctly escaped Haskell string+literal, so paths containing spaces or quotes are safe. @directory@ is added to+the synthetic package's dependencies (see 'renderCabalFile') so the import+always resolves.+-}+cdDirective :: FilePath -> T.Text+cdDirective dir =+    T.pack $+        unlines+            [ "import qualified System.Directory as ScripthsInternalDir"+            , "ScripthsInternalDir.setCurrentDirectory " <> show dir+            ]++{- | Does this notebook use Template Haskell (a @TemplateHaskell@ ext/pragma, a+@template-haskell@ dep, or a @$(…)@ splice line)? If so its splices read files at+compile time, so we bracket the body with compile-time chdirs ('compileCdTo').+-}+usesTemplateHaskell :: CabalMeta -> [Line] -> Bool+usesTemplateHaskell meta ls =+    any (T.isInfixOf "TemplateHaskell") (metaExts meta)+        || any ((== "template-haskell") . depPkgName) (metaDeps meta)+        || any isSpliceLine ls+  where+    isSpliceLine (HaskellLine t) =+        let s = T.stripStart t in "$(" `T.isPrefixOf` s || "_ = ();" `T.isPrefixOf` s+    isSpliceLine (Pragma t) = "TemplateHaskell" `T.isInfixOf` t+    isSpliceLine _ = False++{- | Enable @TemplateHaskell@ and bring TH's @runIO@ into scope for the+compile-time chdir splices. Emitted only when 'usesTemplateHaskell'.+-}+compileCdSetup :: T.Text+compileCdSetup =+    T.unlines+        [ ":set -XTemplateHaskell"+        , "import qualified Language.Haskell.TH.Syntax as ScripthsInternalTH"+        ]++{- | A GHCi top-level auto-splice (type @Q [Dec]@) running @setCurrentDirectory@+at compile time, moving the process the /later/ splices compile in. Used pointed+at the user's cwd before the blocks and back at the project dir after them.+-}+compileCdTo :: FilePath -> T.Text+compileCdTo dir =+    T.unlines+        [ ":{"+        , "_ = (); ScripthsInternalTH.runIO (ScripthsInternalDir.setCurrentDirectory "+            <> T.pack (show dir)+            <> ") Prelude.>> Prelude.pure []"+        , ":}"+        ]+ {- | First line of a scripths-generated @cabal.project@. We regenerate only files that carry it (or the legacy @packages: .@ default), never hand-edited ones. -}@@ -149,10 +257,7 @@   where     names = map depPkgName deps     go dir = do-        cabals <- findCabalFiles dir-        mName <- case cabals of-            (cf : _) -> readCabalPackageName (dir </> cf)-            [] -> pure Nothing+        mName <- packageNameInDir dir         case mName of             Just nm | nm `elem` names -> pure [dir]             _ ->@@ -163,6 +268,31 @@ depPkgName :: T.Text -> T.Text depPkgName = T.takeWhile (\c -> isAlphaNum c || c == '-' || c == '_') . T.stripStart +-- | The cabal package name declared in @dir@ (from its first @.cabal@ file).+packageNameInDir :: FilePath -> IO (Maybe T.Text)+packageNameInDir dir = do+    cabals <- findCabalFiles dir+    case cabals of+        (cf : _) -> readCabalPackageName (dir </> cf)+        [] -> pure Nothing++{- | Names of the local packages, for adding to the script's @build-depends@ so+their modules are actually in scope. A dir without a @.cabal@ (it'll also be a+bad @packages:@ entry) is warned about and skipped.+-}+localPackageNames :: [FilePath] -> IO [T.Text]+localPackageNames = fmap concat . mapM nameOrWarn+  where+    nameOrWarn dir = do+        mName <- packageNameInDir dir+        case mName of+            Just nm -> pure [nm]+            Nothing -> do+                TIO.hPutStrLn+                    stderr+                    ("scripths: warning: no .cabal package found in " <> T.pack dir)+                pure []+ findCabalFiles :: FilePath -> IO [FilePath] findCabalFiles dir = do     entries <- listDirectory dir@@ -182,11 +312,17 @@             , "name:" `T.isPrefixOf` T.toLower (T.stripStart ln)             ] -renderCabalFile :: String -> CabalMeta -> String-renderCabalFile name CabalMeta{metaDeps, metaExts, metaGhcOptions} =-    let deps = "base" : map T.unpack metaDeps+{- | Render the synthetic package's @.cabal@. @extraLocalDeps@ are the names of+local packages (from @--package@, @-- cabal: packages:@, or the enclosing+project) added to @build-depends@ so their modules import.+-}+renderCabalFile :: String -> [T.Text] -> CabalMeta -> String+renderCabalFile name extraLocalDeps CabalMeta{metaDeps, metaExts, metaGhcOptions} =+    let deps = nub ("base" : "directory" : map T.unpack (metaDeps ++ extraLocalDeps))         depsStr = intercalate ", " deps-        extsStr = intercalate ", " (map T.unpack metaExts)+        -- OverloadedStrings is on by default in every scripths repl.+        exts = nub ("OverloadedStrings" : map T.unpack metaExts)+        extsStr = intercalate ", " exts         optsStr = unwords (map T.unpack metaGhcOptions)      in unlines             [ "cabal-version: 3.0"@@ -212,15 +348,27 @@     , "--repl-option=return()"     ] +{- | Run the repl, capturing stdout and stderr as one /ordered/ stream so a+failing block's diagnostics (GHCi writes them to stderr) stay interleaved with+the block markers and render inline. Read to EOF before 'waitForProcess'.+-} 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 ""+    (readEnd, writeEnd) <- createPipe+    (_, _, _, ph) <-+        createProcess+            (proc "cabal" args)+                { cwd = Just userCwd+                , std_out = UseHandle writeEnd+                , std_err = UseHandle writeEnd+                }+    out <- TIO.hGetContents readEnd+    code <- waitForProcess ph     case code of-        ExitSuccess -> pure (T.pack $ out <> err)+        ExitSuccess -> pure out         ExitFailure _ -> do-            TIO.hPutStrLn stderr (T.pack err)+            TIO.hPutStr stderr out             exitWith code  runGhc :: FilePath -> FilePath -> FilePath -> IO ()

@@ -44,6 +44,22 @@                         lang @?= "haskell"                         assertBool "has print 42" (T.isInfixOf "print 42" code)                     other -> assertFailure $ "expected [CodeBlock], got: " ++ show other+            , testCase "four backticks is not a code fence" $ do+                let input =+                        T.unlines+                            [ "````haskell"+                            , "print 42"+                            , "````"+                            ]+                let segs = parseMarkdown input+                case segs of+                    [Prose _] -> pure ()+                    other -> assertFailure $ "expected [Prose], got: " ++ show other+            , testCase "exactly three backticks with a tag is a fence" $ do+                let segs = parseMarkdown (T.unlines ["```haskell", "print 42", "```"])+                case segs of+                    [CodeBlock "haskell" _ _] -> pure ()+                    other -> assertFailure $ "expected [CodeBlock haskell], got: " ++ show other             , testCase "prose then code" $ do                 let input =                         T.unlines@@ -89,7 +105,7 @@                 let segs = parseMarkdown input                 length segs @?= 2                 case segs of-                    [(CodeBlock _ _ (Just (CodeOutput m _))), Prose _] -> assertBool "mime is latex" (m == MimeLatex)+                    [CodeBlock _ _ (Just (CodeOutput m _)), Prose _] -> assertBool "mime is latex" (m == MimeLatex)                     other -> assertFailure $ "expected [CodeBlock, Prose], got: " ++ show other             , testCase "svg mimetype" $ do                 let input =@@ -106,7 +122,7 @@                 let segs = parseMarkdown input                 length segs @?= 2                 case segs of-                    [(CodeBlock _ _ (Just (CodeOutput m _))), Prose _] -> assertBool "mime is svg" (m == MimeSvg)+                    [CodeBlock _ _ (Just (CodeOutput m _)), Prose _] -> assertBool "mime is svg" (m == MimeSvg)                     other -> assertFailure $ "expected [CodeBlock, Prose], got: " ++ show other             , testCase "multiple code blocks" $ do                 let input =@@ -117,7 +133,7 @@                             , "print 1"                             , "```"                             , ""-                            , "> <!-- sabela:mime text/plain -->"+                            , "> <!-- scripths:mime text/plain -->"                             , "> 1"                             , ""                             , "Middle text."@@ -126,7 +142,7 @@                             , "print 2"                             , "```"                             , ""-                            , "> <!-- sabela:mime text/plain -->"+                            , "> <!-- scripths:mime text/plain -->"                             , "> 2"                             ]                 let segs = parseMarkdown input@@ -229,7 +245,86 @@             , testCase "empty lines in output get bare >" $ do                 let result = reassemble [CodeBlock "hs" "x\n" (Just $ CodeOutput MimePlain "a\n\nb")]                 assertBool "has bare >" (T.isInfixOf "\n> \n" result)+            , testCase "renders the scripths:mime marker (not the legacy sabela)" $ do+                let result = reassemble [CodeBlock "hs" "x\n" (Just $ CodeOutput MimePlain "y")]+                assertBool "uses scripths:mime" (T.isInfixOf "scripths:mime" result)+                assertBool "no sabela:mime" (not (T.isInfixOf "sabela:mime" result))             ]+        , testGroup+            "idempotency (no extra blank lines on re-run)"+            [ testCase "round-trip is a fixed point" $ do+                let once = roundTrip docWithOutput+                    twice = roundTrip once+                twice @?= once+            , testCase "newline count does not grow across re-runs" $ do+                let once = roundTrip docWithOutput+                    twice = roundTrip once+                nlCount twice @?= nlCount once+            , testCase "prose->code seam is exactly one blank line" $ do+                let r = roundTrip "a\n\n```haskell\nx\n```\n"+                assertBool "one blank before fence" (T.isInfixOf "a\n\n```haskell" r)+                assertBool "not two blanks" (not (T.isInfixOf "a\n\n\n```" r))+            , testCase "multiple authored blanks around a fence collapse to one" $ do+                let r = roundTrip "a\n\n\n\n```haskell\nx\n```\n"+                assertBool "collapsed to one blank" (T.isInfixOf "a\n\n```haskell" r)+                assertBool "no triple newline" (not (T.isInfixOf "a\n\n\n" r))+            , testCase "doc starting with a code block has no leading blank line" $ do+                let r = roundTrip "```haskell\nx\n```\n"+                assertBool "no leading newline" (not (T.isPrefixOf "\n" r))+            , testCase "trailing blank lines collapse to a single newline" $ do+                let r = roundTrip "# Title\n\n```haskell\nx\n```\n"+                assertBool "ends with single newline" (T.isSuffixOf "```\n" r)+                assertBool "not a trailing blank line" (not (T.isSuffixOf "```\n\n" r))+            , testCase "prose-only document is untouched" $ do+                roundTrip "# Title\n\nJust prose.\n" @?= "# Title\n\nJust prose.\n"+            , testCase "legacy sabela:mime output is recognised and re-rendered as scripths" $ do+                let legacy =+                        T.unlines+                            [ "```haskell"+                            , "1 + 1"+                            , "```"+                            , ""+                            , "> <!-- sabela:mime text/plain -->"+                            , "> 2"+                            ]+                    r = roundTrip legacy+                assertBool "output preserved" (T.isInfixOf "> 2" r)+                assertBool "upgraded to scripths:mime" (T.isInfixOf "scripths:mime" r)+                assertBool "old output not duplicated" (not (T.isInfixOf "sabela:mime" r))+                -- and the upgraded form is itself stable+                roundTrip r @?= r+            ]+        ]++roundTrip :: Text -> Text+roundTrip = reassemble . parseMarkdown++nlCount :: Text -> Int+nlCount = T.length . T.filter (== '\n')++-- A notebook that already carries rendered output, as an in-place re-run sees it.+docWithOutput :: Text+docWithOutput =+    T.unlines+        [ "# Title"+        , ""+        , "Intro prose."+        , ""+        , "```haskell"+        , "1 + 1"+        , "```"+        , ""+        , "> <!-- scripths:mime text/plain -->"+        , "> 2"+        , ""+        , "More prose."+        , ""+        , "```haskell"+        , "2 + 2"+        , "```"+        , ""+        , "> <!-- scripths:mime text/plain -->"+        , "> 4"         ]  indexOf :: Text -> Text -> Int

@@ -10,7 +10,14 @@  import qualified Data.Text as T import ScriptHs.Parser (-    CabalMeta (metaDeps, metaExts, metaGhcOptions, metaSourceRepos, metaUnknownKeys),+    CabalMeta (+        metaDeps,+        metaExts,+        metaGhcOptions,+        metaPackages,+        metaSourceRepos,+        metaUnknownKeys+    ),     Line (..),     ScriptFile (scriptLines, scriptMeta),     SourceRepoPin (..),@@ -79,6 +86,9 @@             , testCase "ghc-options" $ do                 let sf = parseScript "-- cabal: ghc-options: -threaded, -O2\n"                 (metaGhcOptions . scriptMeta) sf @?= ["-threaded", "-O2"]+            , testCase "packages directive lists extra local package dirs" $ do+                let sf = parseScript "-- cabal: packages: ../th, ../persistent\n"+                (metaPackages . scriptMeta) sf @?= ["../th", "../persistent"]             , testCase "metadata stripped from lines" $ do                 let input =                         T.unlines

@@ -407,7 +407,7 @@             assertBool "has main = do" (T.isInfixOf "main = do" txt)             assertBool "indents print 1" (T.isInfixOf "    print 1" txt)         , testCase "cabal-script header includes base + Wno-unused-imports" $ do-            let hdr = renderCabalScriptHeader (CabalMeta ["dataframe", "text"] [] [] [] [])+            let hdr = renderCabalScriptHeader (CabalMeta ["dataframe", "text"] [] [] [] [] [])             assertBool "opens block" (T.isInfixOf "{- cabal:" hdr)             assertBool                 "base + deps"

@@ -5,9 +5,19 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertBool, testCase, (@?=)) -import ScriptHs.Parser (SourceRepoPin (..))-import ScriptHs.Run (cabalArgs, renderCabalProject)+import ScriptHs.Parser (CabalMeta (..), Line (..), SourceRepoPin (..))+import ScriptHs.Run (+    cabalArgs,+    compileCdTo,+    deriveProjectName,+    renderCabalFile,+    renderCabalProject,+    usesTemplateHaskell,+ ) +emptyMeta :: CabalMeta+emptyMeta = CabalMeta [] [] [] [] [] []+ runTests :: TestTree runTests =     testGroup@@ -45,4 +55,63 @@                 assertBool "tag" (T.isInfixOf "tag: abc123" txt)                 assertBool "subdir" (T.isInfixOf "subdir: sub" txt)             ]+        , testGroup+            "deriveProjectName"+            [ testCase "sanitizes non-alphanumerics to dashes" $+                deriveProjectName "/a/b/probe.md" @?= "a-b-probe-md"+            , testCase "collapses runs and trims so a leading _ is valid" $+                -- '/' then '_' would yield '--' (an empty cabal name component).+                deriveProjectName "/x/_probe.md" @?= "x-probe-md"+            , testCase "strips trailing separators" $+                deriveProjectName "/x/note." @?= "x-note"+            ]+        , testGroup+            "renderCabalFile"+            [ testCase "always includes base and directory" $ do+                let txt = T.pack (renderCabalFile "p" [] emptyMeta)+                assertBool "base" (T.isInfixOf "base" txt)+                assertBool "directory" (T.isInfixOf "directory" txt)+            , testCase "enables OverloadedStrings by default" $ do+                let txt = T.pack (renderCabalFile "p" [] emptyMeta)+                assertBool "OverloadedStrings" (T.isInfixOf "OverloadedStrings" txt)+            , testCase "does not duplicate OverloadedStrings if also user-supplied" $ do+                let meta = emptyMeta{metaExts = ["OverloadedStrings"]}+                    n =+                        length (filter (== "OverloadedStrings") (words' (renderCabalFile "p" [] meta)))+                n @?= 1+            , testCase "adds local package names to build-depends" $ do+                let txt = T.pack (renderCabalFile "p" ["granite", "th-helpers"] emptyMeta)+                assertBool "granite dep" (T.isInfixOf "granite" txt)+                assertBool "th-helpers dep" (T.isInfixOf "th-helpers" txt)+            , testCase "dedups names already present in build-depends" $ do+                let meta = emptyMeta{metaDeps = ["granite"]}+                    txt = renderCabalFile "p" ["granite"] meta+                    occurrences = length (filter (== "granite") (words' txt))+                occurrences @?= 1+            ]+        , testGroup+            "usesTemplateHaskell"+            [ testCase "detects the TemplateHaskell extension" $+                usesTemplateHaskell emptyMeta{metaExts = ["TemplateHaskell"]} [] @?= True+            , testCase "detects a template-haskell dependency" $+                usesTemplateHaskell emptyMeta{metaDeps = ["template-haskell"]} [] @?= True+            , testCase "detects a $(...) splice line" $+                usesTemplateHaskell emptyMeta [HaskellLine "$(declareTable db t)"] @?= True+            , testCase "detects the rewritten _ = (); splice form" $+                usesTemplateHaskell emptyMeta [HaskellLine "_ = (); declareTable db t"] @?= True+            , testCase "false for a plain notebook" $+                usesTemplateHaskell emptyMeta [HaskellLine "1 + 1", Import "import Data.List"]+                    @?= False+            ]+        , testGroup+            "compileCdTo"+            [ testCase "renders a compile-time setCurrentDirectory splice" $ do+                let txt = compileCdTo "/some/dir"+                assertBool "splice block" (T.isInfixOf ":{" txt)+                assertBool "chdir call" (T.isInfixOf "setCurrentDirectory" txt)+                assertBool "the target dir" (T.isInfixOf "/some/dir" txt)+            ]         ]+  where+    -- crude tokenizer: split build-depends on commas/spaces for the dedup check+    words' = words . map (\c -> if c == ',' then ' ' else c)