scripths 0.4.0.1 → 0.5.0.0

raw patch · 19 files changed

+1603/−146 lines, 19 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +21/−0
• README.md +15/−2
• app/Main.hs +37/−1
• scripths.cabal +12/−3
• src/ScriptHs/Compiled.hs +182/−0
• src/ScriptHs/Notebook.hs +77/−17
• src/ScriptHs/Parser.hs +67/−12
• src/ScriptHs/Render.hs +1/−0
• src/ScriptHs/Repl.hs +166/−0
• src/ScriptHs/Run.hs +101/−74
• src/ScriptHs/Version.hs +205/−0
• test/Main.hs +8/−0
• test/Test/Compiled.hs +186/−0
• test/Test/Integration.hs +47/−0
• test/Test/Notebook.hs +54/−20
• test/Test/Parser.hs +34/−0
• test/Test/Repl.hs +152/−0
• test/Test/Run.hs +30/−17
• test/Test/Version.hs +208/−0

@@ -1,6 +1,27 @@ # Revision history for scripths  +## 0.4.1.0 -- 2056-05-31+* **Custom-prelude support**: auto print (our hook to rout evething but strings to shw)+  now doesn't assume a prelude.+* **Cleaner error rendering** (notebooks): don't leak internals when printing errors.+* **UTF-8 output**: captured notebook output is decoded as UTF-8.+* **Friendlier errors**: a missing input file reports `No such file or directory`+  instead of a raw exception; a failing `.ghci` script's stderr is scrubbed too;+  cell-end markers carry a per-run nonce so cell output can't spoof a boundary.+* **Version tag**: files may carry a first-line tag recording the scripths that+  wrote them — `-- scripths: X` in `.ghci`/`.hs` scripts, `<!-- scripths: X -->`+  in `.md`/`.markdown` notebooks. Running a file that declares a *newer* scripths+  than the binary prints a warning and continues. scripths stamps/refreshes the+  tag when it writes a notebook (`-o`/`--in-place`); stdout output is left+  unstamped. The tag is recognised after a leading `#!` shebang (scripts) or YAML+  frontmatter block (notebooks), tolerating a BOM, CRLF, and indentation.+  Behaviour change: the first `--in-place` run on an existing notebook inserts the+  `<!-- scripths: X -->` line (and normalises leading blank lines), a one-time+  visible diff in tracked files; it is invisible when rendered and idempotent+  thereafter.+* **`scripths --version` / `-v`** prints the scripths version.+ ## 0.4.0.1 -- 2026-05-30 * Parse pandoc markdown code fences as haskel code fences. 

@@ -7,11 +7,13 @@ ## Features  - **Standalone `.ghci` execution** — Run GHCi scripts directly from the command line, with automatic dependency.+- **Compiled or intepreted** - you can either compile or interpret cells. Heavier functions can be compiled so they move fast and interactive parts can be kept interpreted. - **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.+- **Version tag** — Files record the scripths that wrote them on their first line; running a file authored by a newer scripths than your binary prints a warning rather than failing.  ## Installation @@ -22,12 +24,23 @@ ## CLI Usage  ```-scripths [-o FILE | --output=FILE] [-i | --in-place] [-p DIR | --package DIR]... [--no-local-project] [-h | --help] <script>+scripths [-o FILE | --output=FILE] [-i | --in-place] [-p DIR | --package DIR]... [--no-local-project] [-h | --help] [-v | --version] <script> ```  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.+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, or `scripths --version` to print the version.++## Version tag++Each file can carry a first-line tag recording the scripths version that authored it, so you can tell whether your binary is current enough to parse it. The spelling matches each file type's comment syntax:++```+-- scripths: 0.4.1.0          # .ghci / .hs scripts+<!-- scripths: 0.4.1.0 -->    # .md / .markdown notebooks (invisible when rendered)+```++When scripths writes a notebook (`-o` / `--in-place`) it stamps or refreshes this tag at the top of the document; output streamed to stdout is left untouched. When you run a file whose tag declares a **newer** scripths than your binary, scripths warns on stderr and proceeds anyway (the syntax may not fully parse). The tag is recognised after a leading `#!` shebang (scripts) or YAML frontmatter block (notebooks).  Requires GHC and cabal-install on your PATH. 

@@ -3,9 +3,11 @@ import Control.Monad (unless, when) import Data.List (isPrefixOf) import Data.Maybe (isJust)+import qualified Data.Text as T import qualified Data.Text.IO as TIO import System.Directory (     doesDirectoryExist,+    doesFileExist,     listDirectory,     makeAbsolute,  )@@ -17,6 +19,12 @@ import ScriptHs.Notebook (runNotebook) import ScriptHs.Parser (parseScript) import ScriptHs.Run (RunOptions (..), defaultRunOptions, runScript)+import ScriptHs.Version (+    newerVersionWarning,+    scripthsVersionText,+    tagStyleFor,+    tagVersion,+ )  -- | Parsed command-line options. data Args = Args@@ -26,10 +34,11 @@     , argNoLocalProject :: Bool     , argInPlace :: Bool     , argHelp :: Bool+    , argVersion :: Bool     }  emptyArgs :: Args-emptyArgs = Args Nothing Nothing [] False False False+emptyArgs = Args Nothing Nothing [] False False False False  main :: IO () main = do@@ -37,10 +46,14 @@     case parseArgs raw of         Left err -> hPutStrLn stderr ("scripths: " ++ err) >> usage         Right a+            | argVersion a -> printVersion             | argHelp a -> help             | otherwise -> case argScript a of                 Nothing -> usage                 Just path -> do+                    exists <- doesFileExist path+                    unless exists $ die (path ++ ": No such file or directory")+                    warnIfNewer path                     outPath <- resolveOutput a path                     pkgs <- mapM resolvePackageDir (argPackages a)                     let opts =@@ -97,6 +110,7 @@         | 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+        | tok == "-v" || tok == "--version" = go a{argVersion = True} rest         | "-" `isPrefixOf` tok = Left ("unknown flag: " ++ tok)         | otherwise = case argScript a of             Nothing -> go a{argScript = Just tok} rest@@ -117,6 +131,23 @@ die :: String -> IO a die msg = hPutStrLn stderr ("scripths: " ++ msg) >> exitFailure +-- | Print @\<prog\> \<version\>@ to stdout, exit success.+printVersion :: IO ()+printVersion = do+    prog <- getProgName+    putStrLn (prog ++ " " ++ T.unpack scripthsVersionText)+    exitSuccess++{- | Warn (to stderr, then continue) if the file's first-line version tag+declares a scripths newer than this binary — its syntax may not fully parse.+-}+warnIfNewer :: FilePath -> IO ()+warnIfNewer path = do+    contents <- TIO.readFile path+    case tagVersion (tagStyleFor path) contents >>= newerVersionWarning of+        Just w -> hPutStrLn stderr ("scripths: warning: " ++ T.unpack w)+        Nothing -> pure ()+ -- | Full help, to stdout, exit success. help :: IO () help = getProgName >>= putStr . helpText >> exitSuccess@@ -139,6 +170,11 @@         , "  -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"+        , "  -v, --version             show the scripths version"+        , ""+        , "Files may carry a first-line version tag recording the scripths that wrote"+        , "them ('-- scripths: X' in scripts, '<!-- scripths: X -->' in notebooks); a"+        , "file declaring a newer scripths than this binary is run with a warning."         , ""         , "In-script directives (lines beginning '-- cabal:'):"         , "  -- cabal: build-depends: pkg1, pkg2"

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               scripths-version:            0.4.0.1+version:            0.5.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/@@ -24,10 +24,15 @@ library     import:           warnings     exposed-modules:  ScriptHs.Parser,+                      ScriptHs.Compiled,                       ScriptHs.Render,                       ScriptHs.Markdown,                       ScriptHs.Notebook,-                      ScriptHs.Run+                      ScriptHs.Repl,+                      ScriptHs.Run,+                      ScriptHs.Version+    other-modules:    Paths_scripths+    autogen-modules:  Paths_scripths     build-depends:    base >= 4 && < 5,                       directory >= 1.3 && < 1.4,                       filepath >= 1.4 && < 1.6,@@ -57,10 +62,14 @@     hs-source-dirs:   test     main-is:          Main.hs     other-modules:    Test.Parser,+                      Test.Compiled,                       Test.Render,                       Test.Markdown,                       Test.Notebook,-                      Test.Run+                      Test.Repl,+                      Test.Run,+                      Test.Version,+                      Test.Integration     build-depends:         base >= 4 && < 5,         scripths,

@@ -0,0 +1,182 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Rendering compiled notebook cells into a generated Haskell module.++A cell carrying a @-- compile@ directive contributes its declarations to a+module that the host loads with @:add@, so GHC compiles it to native object+code instead of interpreting it at the prompt. Every import and declaration+unit is preceded by a @{\-# LINE #-\}@ pragma whose \"file\" is a per-cell tag+('linePragmaTag'), so GHC diagnostics come back cell-relative.+-}+module ScriptHs.Compiled (+    CellChunk (..),+    CompileIssue (..),+    checkCompilable,+    renderCompiledModule,+    linePragmaTag,+    parseLinePragmaTag,+    isValidModuleName,+) where++import Data.Char (isAlphaNum, isAsciiUpper)+import Data.List (intercalate)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Read as TR++import ScriptHs.Parser (Line (..))+import ScriptHs.Render (Kind (..), Piece (..), lineText, toPieces, unRewriteSplice)++-- | One cell's contribution to a generated module.+data CellChunk = CellChunk+    { ccTag :: Text+    -- ^ LINE-pragma file tag for this cell (see 'linePragmaTag').+    , ccLines :: [(Int, Line)]+    -- ^ The cell's code lines with their 1-based cell-relative numbers.+    }+    deriving (Show, Eq)++-- | Why a cell cannot be compiled, pointing at the offending line.+data CompileIssue = CompileIssue+    { ciLine :: Int+    , ciReason :: Text+    }+    deriving (Show, Eq)++{- | Validate that a cell contains only module-top-level content: imports,+pragmas, declarations, TH splices, comments, and @:set -X@ directives.+Expressions, monadic binds, and other GHCi commands are rejected.+-}+checkCompilable :: [(Int, Line)] -> [CompileIssue]+checkCompilable nls =+    [ CompileIssue i reason+    | (i, p) <- numberedPieces nls+    , Just reason <- [pieceIssue p]+    ]++pieceIssue :: Piece -> Maybe Text+pieceIssue PBlank = Nothing+pieceIssue (PPragma _) = Nothing+pieceIssue (PImport _) = Nothing+pieceIssue (PGhciCommand t)+    | isSetExtension t = Nothing+    | otherwise =+        Just "GHCi commands are not allowed in compiled cells (only :set -XExtension)"+pieceIssue (PUnit k _) = case k of+    KComment -> Nothing+    KDeclaration -> Nothing+    KTHSplice -> Nothing+    KAction ->+        Just+            "compiled cells contain only declarations — move this expression to an interpreted cell below, or remove '-- compile'"+    KIOBind ->+        Just+            "monadic binds (x <- …) are not allowed in compiled cells — move this to an interpreted cell below, or remove '-- compile'"++{- | Pair each piece from 'toPieces' with the original line number of its+first line. Relies on 'toPieces' being line-count preserving: every piece+consumes exactly the lines it embeds.+-}+numberedPieces :: [(Int, Line)] -> [(Int, Piece)]+numberedPieces nls = go nls (toPieces (map snd nls))+  where+    go _ [] = []+    go rest (p : ps) = case rest of+        ((i, _) : _) -> (i, p) : go (drop (pieceLen p) rest) ps+        [] -> []+    pieceLen (PUnit _ ls) = length ls+    pieceLen _ = 1++-- | Extensions named by a @:set -X@\/@:seti -X@ line whose args are all @-X@.+setExtensions :: Text -> [Text]+setExtensions t = case T.words (T.strip t) of+    (cmd : rest)+        | cmd `elem` [":set", ":seti"]+        , exts <- [e | w <- rest, Just e <- [T.stripPrefix "-X" w]]+        , length exts == length rest ->+            exts+    _ -> []++isSetExtension :: Text -> Bool+isSetExtension = not . null . setExtensions++-- | The LINE-pragma \"file\" tag for a cell id, e.g. @sabela-cell-12@.+linePragmaTag :: Int -> Text+linePragmaTag cid = "sabela-cell-" <> T.pack (show cid)++-- | Inverse of 'linePragmaTag'; the error parser uses this to route diagnostics.+parseLinePragmaTag :: Text -> Maybe Int+parseLinePragmaTag t = do+    rest <- T.stripPrefix "sabela-cell-" t+    case TR.decimal rest of+        Right (n, leftover) | T.null leftover -> Just n+        _ -> Nothing++-- | Valid Haskell module name: dot-separated capitalized identifier segments.+isValidModuleName :: Text -> Bool+isValidModuleName name =+    not (T.null name) && all validSegment (T.splitOn "." name)+  where+    validSegment seg = case T.uncons seg of+        Just (c, rest) -> isAsciiUpper c && T.all segChar rest+        Nothing -> False+    segChar c = isAlphaNum c || c == '_' || c == '\''++{- | Assemble a generated module: deduped LANGUAGE pragmas (defaults, cell+pragmas, @:set -X@ contributions), the module header, synthetic imports (e.g.+cross-module dependencies the host inferred), cell imports and declarations —+each cell unit preceded by a LINE pragma pointing back at its source cell.+-}+renderCompiledModule ::+    -- | Module name+    Text ->+    -- | Default extensions (rendered as LANGUAGE pragmas)+    [Text] ->+    -- | Synthetic imports, verbatim (e.g. @import OtherModule@)+    [Text] ->+    [CellChunk] ->+    Text+renderCompiledModule modName defaultExts extraImports chunks =+    T.unlines . intercalate [""] . filter (not . null) $+        [ dedup (map languagePragma defaultExts ++ chunkPragmas)+            ++ ["{-# OPTIONS_GHC -Wno-unused-imports #-}"]+        , ["-- Generated by Sabela compile mode. Do not edit."]+        , ["module " <> modName <> " where"]+        , extraImports ++ concatMap chunkImports chunks+        , intercalate [""] (concatMap chunkDecls chunks)+        ]+  where+    chunkPragmas = concatMap pragmasOf chunks+    pragmasOf c =+        concat+            [ case p of+                PPragma t -> [t]+                PGhciCommand t -> map languagePragma (setExtensions t)+                _ -> []+            | (_, p) <- numberedPieces (ccLines c)+            ]+    chunkImports c =+        concat+            [ [linePragma i (ccTag c), t]+            | (i, PImport t) <- numberedPieces (ccLines c)+            ]+    chunkDecls c =+        [ linePragma i (ccTag c) : declLines u+        | (i, PUnit k u) <- numberedPieces (ccLines c)+        , k `elem` [KComment, KDeclaration, KTHSplice]+        ]+    declLines = T.lines . unRewriteSplice . T.intercalate "\n" . map lineText++linePragma :: Int -> Text -> Text+linePragma n tag = "{-# LINE " <> T.pack (show n) <> " \"" <> tag <> "\" #-}"++languagePragma :: Text -> Text+languagePragma ext = "{-# LANGUAGE " <> ext <> " #-}"++dedup :: [Text] -> [Text]+dedup = go []+  where+    go _ [] = []+    go seen (x : xs)+        | x `elem` seen = go seen xs+        | otherwise = x : go (x : seen) xs

@@ -1,9 +1,15 @@ module ScriptHs.Notebook where  import Data.Bifunctor (Bifunctor (second))+import Data.Bits (xor)+import Data.Char (ord)+import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as TIO+import Data.Word (Word32)+import Numeric (showHex)+import System.CPUTime (getCPUTime)  import ScriptHs.Markdown (     CodeOutput (..),@@ -19,19 +25,30 @@     mergeMetas,     parseScript,  )+import ScriptHs.Render (lineText)+import ScriptHs.Repl (scripthsIO, scrubInternalNames) import ScriptHs.Run (RunOptions, runScriptCapture)+import ScriptHs.Version (TagStyle (NotebookTag), stampVersion)  type IndexedSegments = [(Int, Segment)] type IndexedBlocks = [(Int, [Line])] +{- | Run a notebook. Output streamed to stdout is left as-is so pipelines stay+clean; output written to a file (@-o@ or @--in-place@) is stamped with the+current scripths version tag at the top.+-} runNotebook :: RunOptions -> FilePath -> Maybe FilePath -> IO () runNotebook opts path outputPath = do-    contents <- TIO.readFile path+    contents <- stripBom <$> TIO.readFile path     outputMd <- processNotebook opts path contents     case outputPath of         Nothing -> TIO.putStr outputMd-        Just output -> TIO.writeFile output outputMd+        Just output -> TIO.writeFile output (stampVersion NotebookTag outputMd) +-- | Drop a leading UTF-8 BOM so it never sits in front of the version tag.+stripBom :: Text -> Text+stripBom t = fromMaybe t (T.stripPrefix "\65279" t)+ processNotebook :: RunOptions -> FilePath -> Text -> IO Text processNotebook opts notebookPath contents = do     let indexedSegments = zip [0 ..] (parseMarkdown contents)@@ -48,13 +65,44 @@     IndexedBlocks ->     IO Text executeCodeCells opts notebookPath meta allSegments codeBlocks = do-    let ghciScript = generatedMarkedScript codeBlocks-        sf = ScriptFile{scriptMeta = meta, scriptLines = ghciScript}+    let ghciScript0 = generatedMarkedScript "" codeBlocks+    nonce <- makeNonce ghciScript0+    let ghciScript = generatedMarkedScript nonce codeBlocks+        sf = ScriptFile{scriptMeta = meta, scriptCompile = Nothing, scriptLines = ghciScript}     rawOutput <- runScriptCapture opts notebookPath sf-    let outputs = splitByMarkers rawOutput (map fst codeBlocks)+    let indices = map fst codeBlocks+        outputs =+            map+                (fmap (scrubCellOutput nonce indices))+                (splitByMarkers nonce rawOutput indices)         blocksWithOutput = addOutputToSegments outputs allSegments     pure $ reassemble blocksWithOutput +{- | A per-run hex nonce woven into every cell-end marker so a cell's own output+cannot spoof a marker and misattribute another cell's output. Mixes the process+CPU time with a hash of the cell text.+-}+makeNonce :: [Line] -> IO Text+makeNonce ls = do+    t <- getCPUTime+    -- TODO: mchavinda - if this is slow then drop the text hashing and just use time.+    let seed = T.pack (show t) <> T.concat (map lineText ls)+    pure (T.pack (showHex (fnv1a seed) ""))++fnv1a :: Text -> Word32+fnv1a = T.foldl' (\h c -> (h `xor` fromIntegral (ord c)) * 16777619) 2166136261++{- | Clean a cell's captured output before it is rendered into the document:+strip scripths' internal identifiers (so a diagnostic reads like vanilla GHCi)+and remove any cell-end block marker that survived 'splitByMarkers' (so it can+never appear interleaved with the cell's stdout/error).+-}+scrubCellOutput :: Text -> [Int] -> Text -> Text+scrubCellOutput nonce indices =+    scrubInternalNames . stripMarkers+  where+    stripMarkers t = foldr (\i acc -> T.replace (mkMarker nonce i) "" acc) t indices+ addOutputToSegments :: [(Int, Text)] -> IndexedSegments -> [Segment] addOutputToSegments outputs = map addOutput   where@@ -72,31 +120,43 @@         [(i, parseScript code) | (i, CodeBlock lang code _) <- blocks, isHaskell lang]     metas = mergeMetas (map (scriptMeta . snd) sfs) -generatedMarkedScript :: IndexedBlocks -> [Line]-generatedMarkedScript = concatMap renderWithMarker+generatedMarkedScript :: Text -> IndexedBlocks -> [Line]+generatedMarkedScript nonce = concatMap renderWithMarker   where     renderWithMarker :: (Int, [Line]) -> [Line]     renderWithMarker (idx, ls) =         ls             ++ [ Blank-               , HaskellLine ("putStrLn " <> T.pack (show (T.unpack (mkMarker idx))))+               , HaskellLine (markerStatement (mkMarker nonce idx))                , Blank                ] -splitByMarkers :: Text -> [Int] -> [(Int, Text)]-splitByMarkers _ [] = []-splitByMarkers remaining (idx : rest) =-    let marker = mkMarker idx+{- | A GHCi statement printing a cell-end marker. @putStrLn@ is qualified through+the synthetic @System.IO@ alias ('scripthsIO') so the marker still prints under a+notebook that enables @NoImplicitPrelude@ or imports a custom prelude.+-}+markerStatement :: Text -> Text+markerStatement marker =+    scripthsIO <> ".putStrLn " <> T.pack (show (T.unpack marker))++splitByMarkers :: Text -> Text -> [Int] -> [(Int, Text)]+splitByMarkers _ _ [] = []+splitByMarkers nonce remaining (idx : rest) =+    let marker = mkMarker nonce idx         (before, after) = T.breakOn marker remaining      in if T.null after             then [(idx, T.strip before)]             else-                (idx, T.strip before) : splitByMarkers (T.drop (T.length marker) after) rest+                (idx, T.strip before)+                    : splitByMarkers nonce (T.drop (T.length marker) after) rest --- A marker we'll print to GHCi output to--- denote the end of a cell execution block.-mkMarker :: Int -> Text-mkMarker n = "---SCRIPTHS_BLOCK_" <> T.pack (show n) <> "_END---"+{- | The marker printed to GHCi output to denote the end of a cell's execution.+Carries a per-run @nonce@ (see 'makeNonce') so a cell's own output cannot forge+a marker and steal the boundary between cells.+-}+mkMarker :: Text -> Int -> Text+mkMarker nonce n =+    "---SCRIPTHS_BLOCK_" <> nonce <> "_" <> T.pack (show n) <> "_END---"  isHaskell :: Text -> Bool isHaskell lang = fenceLanguage lang `elem` ["haskell", "hs"]

@@ -18,9 +18,11 @@ module ScriptHs.Parser (     ScriptFile (..),     CabalMeta (..),+    CompileDirective (..),     SourceRepoPin (..),     Line (..),     parseScript,+    parseScriptNumbered,     mergeMetas, ) where @@ -28,17 +30,30 @@ import Data.Text (Text) import qualified Data.Text as T +import ScriptHs.Version (TagStyle (ScriptTag), parseTagLine)+ {- | A fully parsed script, consisting of aggregated cabal metadata and an ordered list of code lines. -} data ScriptFile = ScriptFile     { scriptMeta :: CabalMeta     -- ^ Aggregated metadata from all @-- cabal:@ directives in the script.+    , scriptCompile :: Maybe CompileDirective+    -- ^ The first @-- compile@ directive in the script, if any.     , scriptLines :: [Line]     -- ^ The code lines of the script, in order, with metadata lines removed.     }     deriving (Show, Eq) +{- | A @-- compile@ directive marking a script (notebook cell) as compiled:+its declarations are destined for a generated module rather than the GHCi+prompt. @-- compile: Some.Module@ names the target module explicitly.+-}+data CompileDirective+    = CompileDefault+    | CompileNamed Text+    deriving (Show, Eq)+ {- | Cabal metadata extracted from @-- cabal:@ directives.  Multiple directives of the same kind are merged:@@ -116,23 +131,49 @@ ScriptFile {scriptMeta = CabalMeta {metaDeps = [], metaExts = [], metaGhcOptions = [], metaPackages = [], metaSourceRepos = [], metaUnknownKeys = []}, scriptLines = []} -} parseScript :: Text -> ScriptFile-parseScript input =-    let textLines = T.lines input-        parsedLines = map parseLine textLines-        (metas, code) = partitionLines parsedLines-        meta = mergeMetas metas-     in ScriptFile{scriptMeta = meta, scriptLines = code}+parseScript = fst . parseScriptNumbered +{- | Like 'parseScript', but also returns the code lines paired with their+1-based line numbers in the original input (directive lines are removed from+the stream but the numbering of the survivors is preserved). Used to emit+@{\-# LINE #-\}@ pragmas that point back at the original source.+-}+parseScriptNumbered :: Text -> (ScriptFile, [(Int, Line)])+parseScriptNumbered input =+    let numberedRaw = zip [1 ..] (T.lines input)+        afterTag = dropLeadingVersionTag numberedRaw+        parsed = [(i, parseLine t) | (i, t) <- afterTag]+        metas = [m | (_, RawCabalMeta m) <- parsed]+        compileDir = case [d | (_, RawCompile d) <- parsed] of+            (d : _) -> Just d+            [] -> Nothing+        code = [(i, c) | (i, RawCode c) <- parsed]+        sf =+            ScriptFile+                { scriptMeta = mergeMetas metas+                , scriptCompile = compileDir+                , scriptLines = map snd code+                }+     in (sf, code)++{- | Drop a leading scripths version tag (the first non-blank line, when it is+one) so it is not emitted into the repl. Recognised via the single parser in+"ScriptHs.Version" — so an arbitrary @-- scripths:@ comment elsewhere in the body+is left untouched, and the recognizer cannot drift from the one used to read the+tag.+-}+dropLeadingVersionTag :: [(Int, Text)] -> [(Int, Text)]+dropLeadingVersionTag ls = case span (isBlank . snd) ls of+    (blanks, (_, tag) : rest) | isJust (parseTagLine ScriptTag tag) -> blanks ++ rest+    _ -> ls+  where+    isBlank = T.null . T.strip+ data RawLine     = RawCabalMeta CabalMeta+    | RawCompile CompileDirective     | RawCode Line -partitionLines :: [RawLine] -> ([CabalMeta], [Line])-partitionLines = foldr go ([], [])-  where-    go (RawCabalMeta m) (ms, cs) = (m : ms, cs)-    go (RawCode c) (ms, cs) = (ms, c : cs)- mergeMetas :: [CabalMeta] -> CabalMeta mergeMetas ms =     CabalMeta@@ -147,7 +188,21 @@ parseLine :: Text -> RawLine parseLine line     | Just meta <- parseCabalMeta line = RawCabalMeta meta+    | Just dir <- parseCompileDirective line = RawCompile dir     | otherwise = RawCode (parseCodeLine line)++{- | Recognize a @-- compile@ \/ @-- compile: Some.Module@ directive line.+A comment merely starting with the word (e.g. @-- compiled fast@) is not a+directive; the name is taken verbatim (validation happens downstream).+-}+parseCompileDirective :: Text -> Maybe CompileDirective+parseCompileDirective line = do+    rest <- T.stripPrefix "--" (T.stripStart line)+    after <- T.stripPrefix "compile" (T.stripStart rest)+    let a = T.strip after+    if T.null a+        then Just CompileDefault+        else CompileNamed . T.strip <$> T.stripPrefix ":" a  parseCabalMeta :: Text -> Maybe CabalMeta parseCabalMeta line = do

@@ -30,6 +30,7 @@     toPieces,     classify,     lineText,+    unRewriteSplice, ) where  import Data.Char (isAsciiLower, isAsciiUpper, isDigit)

@@ -0,0 +1,166 @@+{-# LANGUAGE OverloadedStrings #-}++{- | The GHCi code scripths injects into the throwaway repl session — the+auto-print preamble, the working-directory and Template Haskell @cd@ splices, and+the batch terminator — plus scrubbing of scripths' own identifiers out of+captured output.++Every injected name is qualified against a base module /other than/ @Prelude@.+Importing @Prelude@ — even @qualified@ — suppresses GHC's implicit @import+Prelude@ and would strip unqualified names from the user's own cells, whereas+importing any other base module does not. That is what lets a notebook run under+@NoImplicitPrelude@ or a custom prelude. The @ScripthsInternal*@ aliases are+listed once in 'scripthsInternalQualifiers' so the generators and+'scrubInternalNames' cannot drift apart.+-}+module ScriptHs.Repl (+    scripthsIO,+    scripthsInternalQualifiers,+    scrubInternalNames,+    autoPrintDirective,+    cdDirective,+    compileCdSetup,+    compileCdTo,+    replEvalExpr,+) where++import qualified Data.Text as T++{- | Qualified alias for base's @System.IO@ in scripths-injected GHCi statements+(autoprint and the notebook block markers). We qualify against @System.IO@ (not+@Prelude@) so the injected code resolves @print@\/@putStrLn@ under+@NoImplicitPrelude@ without suppressing the user's implicit @Prelude@.+-}+scripthsIO :: T.Text+scripthsIO = "ScripthsInternalIO"++{- | Each @ScripthsInternal*@ alias scripths injects, paired with the real base+module it stands for. Single source of truth shared by the generators above and+'scrubInternalNames' so they cannot drift.+-}+scripthsInternalAliases :: [(T.Text, T.Text)]+scripthsInternalAliases =+    [ (scripthsIO, "System.IO")+    , ("ScripthsInternalShow", "Text.Show")+    , ("ScripthsInternalStr", "Data.String")+    , ("ScripthsInternalMonad", "Control.Monad")+    , ("ScripthsInternalApplicative", "Control.Applicative")+    , ("ScripthsInternalTH", "Language.Haskell.TH.Syntax")+    , ("ScripthsInternalDir", "System.Directory")+    ]++-- | The qualified module aliases scripths injects into the GHCi session.+scripthsInternalQualifiers :: [T.Text]+scripthsInternalQualifiers = map fst scripthsInternalAliases++{- | Strip scripths' internal identifiers from captured GHCi output so a user's+diagnostic reads like a vanilla GHCi one rather than exposing the synthetic+preamble:++  * a /qualified/ use loses its qualifier (@ScripthsInternalStr.IsString@ -> @IsString@);+  * a /bare/ alias (e.g. @Could not load module \'ScripthsInternalDir\'@) becomes+    the real module it stands for (@System.Directory@);+  * the auto-print method @scripthsAutoPrint@ becomes @print@ and its class+    @ScripthsAutoPrint@ becomes @Show@ (what GHCi shows without scripths).++These tokens are deliberately exotic, so a blind 'T.replace' over user-visible+output is very unlikely to collide with real content (a cell that literally+prints one of them as data would be rewritten — an accepted trade-off).+-}+scrubInternalNames :: T.Text -> T.Text+scrubInternalNames t0 = foldl (\acc (n, r) -> T.replace n r acc) t0 replacements+  where+    -- Order matters: strip qualified @Alias.@ uses first, then the method and+    -- class names, then map any /remaining/ bare alias to its real module.+    replacements =+        [(a <> ".", "") | (a, _) <- scripthsInternalAliases]+            ++ [ ("scripthsAutoPrint", "print")+               , ("ScripthsAutoPrint", "Show")+               ]+            ++ [(a, m) | (a, m) <- scripthsInternalAliases]++{- | 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.++Every name is qualified against a base module other than @Prelude@ (so the+directive compiles under @NoImplicitPrelude@ / a custom prelude without+suppressing the user's implicit @Prelude@).+-}+autoPrintDirective :: T.Text+autoPrintDirective =+    T.unlines+        [ ":set -XFlexibleInstances -XUndecidableInstances"+        , "import qualified System.IO as " <> scripthsIO+        , "import qualified Text.Show as ScripthsInternalShow"+        , "import qualified Data.String as ScripthsInternalStr"+        , "class ScripthsAutoPrint a where scripthsAutoPrint :: a -> "+            <> scripthsIO+            <> ".IO ()"+        , "instance {-# OVERLAPPING #-} ScripthsAutoPrint ScripthsInternalStr.String where scripthsAutoPrint = "+            <> scripthsIO+            <> ".putStr"+        , "instance {-# OVERLAPPABLE #-} ScripthsInternalShow.Show a => ScripthsAutoPrint a where scripthsAutoPrint = "+            <> scripthsIO+            <> ".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+            ]++{- | Enable @TemplateHaskell@ and bring TH's @runIO@ (plus the @(>>)@\/@pure@ the+splice sequences with) into scope for the compile-time chdir splices, all+qualified so they resolve under @NoImplicitPrelude@. Emitted only when the+notebook uses Template Haskell.+-}+compileCdSetup :: T.Text+compileCdSetup =+    T.unlines+        [ ":set -XTemplateHaskell"+        , "import qualified Language.Haskell.TH.Syntax as ScripthsInternalTH"+        , "import qualified Control.Monad as ScripthsInternalMonad"+        , "import qualified Control.Applicative as ScripthsInternalApplicative"+        ]++{- | 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)+            <> ") ScripthsInternalMonad.>> ScripthsInternalApplicative.pure []"+        , ":}"+        ]++{- | The expression GHCi evaluates (via @-e@) after sourcing the script, to run+the session non-interactively and exit. A silent @hFlush stdout@ rather than+@return ()@, qualified through 'scripthsIO' (which @-e@ sees from the script's+imports) so it needs no Prelude under @NoImplicitPrelude@ / a custom prelude.+Written @hFlush(stdout)@ with no space: cabal splits a @--repl-option@ value on+whitespace, and Haskell's @f(x)@ juxtaposition keeps it a single application.+-}+replEvalExpr :: T.Text+replEvalExpr = scripthsIO <> ".hFlush(" <> scripthsIO <> ".stdout)"

@@ -1,13 +1,32 @@ {-# LANGUAGE NamedFieldPuns #-} -module ScriptHs.Run where+{- | Assembling and running the throwaway cabal project scripths drives for a+script or notebook. The GHCi code injected into that project's repl lives in+"ScriptHs.Repl".+-}+module ScriptHs.Run (+    RunOptions (..),+    defaultRunOptions,+    runScript,+    runScriptCapture, -import Control.Monad (filterM, unless, when)-import Data.Char (isAlphaNum)-import Data.List (intercalate, nub)+    -- * Internals exposed for testing+    cabalArgs,+    deriveProjectName,+    renderCabalFile,+    renderCabalProject,+    usesTemplateHaskell,+) where++import Control.Monad (filterM, when)+import Data.Bits (xor)+import Data.Char (isAlphaNum, isAscii, ord)+import Data.List (foldl', intercalate, nub) import Data.Maybe (listToMaybe) import qualified Data.Text as T import qualified Data.Text.IO as TIO+import Data.Word (Word32)+import Numeric (showHex) import ScriptHs.Parser (     CabalMeta (..),     Line (..),@@ -15,6 +34,14 @@     SourceRepoPin (..),  ) import ScriptHs.Render (toGhciScript)+import ScriptHs.Repl (+    autoPrintDirective,+    cdDirective,+    compileCdSetup,+    compileCdTo,+    replEvalExpr,+    scrubInternalNames,+ ) import System.Directory (     createDirectoryIfMissing,     doesFileExist,@@ -25,7 +52,7 @@  ) import System.Exit (ExitCode (..), exitWith) import System.FilePath (takeDirectory, takeExtension, (</>))-import System.IO (stderr)+import System.IO (hSetEncoding, stderr, utf8) import System.Process (     CreateProcess (cwd, delegate_ctlc, std_err, std_out),     StdStream (UseHandle),@@ -70,6 +97,30 @@         ensureProject opts userCwd scriptAbsPath (scriptMeta sf) (scriptLines sf)     cont userCwd projectDir (projectDir </> "script.ghci") +{- | Source for the throwaway executable's @Main.hs@. It only needs to typecheck+(the repl never runs it), and is written prelude-agnostically so it compiles even+when the notebook enables @NoImplicitPrelude@ for the executable.+-}+syntheticMainHs :: T.Text+syntheticMainHs =+    T.unlines+        [ "import qualified System.IO"+        , "import qualified Control.Applicative"+        , "main :: System.IO.IO ()"+        , "main = Control.Applicative.pure ()"+        ]++{- | Write @content@ to @path@ only when it differs from what's already there, so+a stable file (the synthetic @Main.hs@) is not rewritten — and so recompiled — on+every run, while a stale one from an older scripths is healed. Reads strictly+(via "Data.Text.IO") so the handle is closed before the rewrite.+-}+writeFileIfChanged :: FilePath -> T.Text -> IO ()+writeFileIfChanged path content = do+    exists <- doesFileExist path+    existing <- if exists then TIO.readFile path else pure ""+    when (existing /= content) (TIO.writeFile path content)+ -- | Warn (once each) about unrecognised @-- cabal:@ directive keys. warnUnknownKeys :: [T.Text] -> IO () warnUnknownKeys keys =@@ -77,19 +128,36 @@         (\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).+{- | Turn an /absolute/ script path into a valid, collision-free cabal package+name (also used as the @~\/.scripths@ subdir). Only ASCII alphanumerics survive —+other characters (incl. non-ASCII letters cabal would reject) become @-@, runs of+@-@ collapse, and leading\/trailing @-@ are stripped. A readable stem alone would+collide (@foo.md@ and @foo-md@ both sanitise to @foo-md@) and could be empty, so+a stable hash of the full path is appended after an @-h@ marker — distinct paths+never share a project dir, and the trailing component always begins with a letter+(a valid cabal name). -} deriveProjectName :: FilePath -> String-deriveProjectName =-    trimDash . collapseDashes . map (\c -> if isAlphaNum c then c else '-')+deriveProjectName path = stem ++ "-h" ++ pathHash path   where+    sanitised = trimDash (collapseDashes (map asciiAlnumOrDash path))+    stem = if null sanitised then "scripths-script" else sanitised+    asciiAlnumOrDash c = if isAscii c && isAlphaNum c then c else '-'     collapseDashes ('-' : xs) = '-' : collapseDashes (dropWhile (== '-') xs)     collapseDashes (x : xs) = x : collapseDashes xs     collapseDashes [] = []     trimDash = f . f where f = reverse . dropWhile (== '-') +{- | A short, stable hex hash of a string (FNV-1a over 'Word32'); used to keep+distinct script paths from colliding on the same @~\/.scripths@ project dir+without pulling in a hashing dependency.+-}+pathHash :: String -> String+pathHash s = showHex (foldl' step 2166136261 s) ""+  where+    step :: Word32 -> Char -> Word32+    step h c = (h `xor` fromIntegral (ord c)) * 16777619+ ensureProject ::     RunOptions -> FilePath -> FilePath -> CabalMeta -> [Line] -> IO FilePath ensureProject opts userCwd scriptAbsPath meta scriptCode = do@@ -118,8 +186,7 @@     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"+    writeFileIfChanged mainHsPath syntheticMainHs     writeFile         (projectDir </> (name ++ ".cabal"))         (renderCabalFile name extraDeps meta)@@ -135,41 +202,6 @@         (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').@@ -185,30 +217,6 @@     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. -}@@ -345,7 +353,7 @@     , "--project-dir=" ++ projectDir     , "--repl-option=-ghci-script=" ++ ghciPath     , "--repl-option=-e"-    , "--repl-option=return()"+    , "--repl-option=" ++ T.unpack replEvalExpr     ]  {- | Run the repl, capturing stdout and stderr as one /ordered/ stream so a@@ -356,6 +364,9 @@ captureGhc userCwd projectDir ghciPath = do     let args = "-v0" : cabalArgs projectDir ghciPath     (readEnd, writeEnd) <- createPipe+    -- GHC writes UTF-8 (cell output and the Unicode punctuation in its+    -- diagnostics); decode the pipe as UTF-8 so it is not mangled into mojibake.+    hSetEncoding readEnd utf8     (_, _, _, ph) <-         createProcess             (proc "cabal" args)@@ -368,15 +379,31 @@     case code of         ExitSuccess -> pure out         ExitFailure _ -> do-            TIO.hPutStr stderr out+            TIO.hPutStr stderr (scrubInternalNames out)             exitWith code +{- | Run the repl for @.ghci@\/@.hs@ scripts: stdout is inherited so it streams+live (and @Ctrl-C@ works via @delegate_ctlc@), while stderr is captured, decoded+as UTF-8, and passed through 'scrubInternalNames' before being forwarded — so a+failing script no longer leaks scripths-internal names in its diagnostics. (We+read stderr to EOF as we go, so the pipe never fills; the trade-off is that+stderr is flushed after the run rather than perfectly interleaved with stdout.)+-} 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}+    (errRead, errWrite) <- createPipe+    hSetEncoding errRead utf8+    let cp =+            (proc "cabal" args)+                { cwd = Just userCwd+                , delegate_ctlc = True+                , std_err = UseHandle errWrite+                }     (_, _, _, ph) <- createProcess cp+    errOut <- TIO.hGetContents errRead     code <- waitForProcess ph+    TIO.hPutStr stderr (scrubInternalNames errOut)     case code of         ExitSuccess -> pure ()         ExitFailure _ -> exitWith code

@@ -0,0 +1,205 @@+{-# LANGUAGE OverloadedStrings #-}++{- | The scripths version and the first-line /version tag/ that marks a script or+notebook with the scripths version it was written for.++The tag lets scripths warn when a file was authored by a newer release than the+binary running it (so a user knows parsing may be incomplete). It is spelled the+way each file type's comments are spelled:++@+-- scripths: 0.4.1.0          (.ghci \/ .hs)+\<!-- scripths: 0.4.1.0 --\>    (.md \/ .markdown)+@++The emitted version is always 'scripthsVersion', a PVP value (dot-separated+decimals), so the notebook tag's comment text can never contain @--@ or a+trailing @-@ — it is a well-formed HTML comment by construction.+-}+module ScriptHs.Version (+    scripthsVersion,+    scripthsVersionText,+    TagStyle (..),+    tagStyleFor,+    versionTag,+    parseTagLine,+    tagVersion,+    stampVersion,+    newerVersionWarning,+) where++import Data.Char (isAlphaNum, isDigit, isSpace)+import Data.Maybe (fromMaybe, isJust)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Version (Version, makeVersion, showVersion)+import System.FilePath (takeExtension)+import Text.Read (readMaybe)++import Paths_scripths (version)++-- | The running scripths version (single source of truth: the @.cabal@ @version@).+scripthsVersion :: Version+scripthsVersion = version++scripthsVersionText :: Text+scripthsVersionText = T.pack (showVersion scripthsVersion)++-- | How the version tag is spelled in a given file type.+data TagStyle+    = -- | @-- scripths: X@, for @.ghci@\/@.hs@ scripts.+      ScriptTag+    | -- | @\<!-- scripths: X --\>@, for @.md@\/@.markdown@ notebooks.+      NotebookTag+    deriving (Show, Eq)++-- | The tag style for a path, by extension (@.md@\/@.markdown@ are notebooks).+tagStyleFor :: FilePath -> TagStyle+tagStyleFor path+    | ext `elem` [".md", ".markdown"] = NotebookTag+    | otherwise = ScriptTag+  where+    ext = T.unpack (T.toLower (T.pack (takeExtension path)))++-- | The tag line for the current version, in the given style.+versionTag :: TagStyle -> Text+versionTag ScriptTag = "-- scripths: " <> scripthsVersionText+versionTag NotebookTag = "<!-- scripths: " <> scripthsVersionText <> " -->"++{- | The scripths version a single line declares, if it is a version tag of the+given style. Tolerant of a UTF-8 BOM, a trailing @\\r@ (CRLF), trailing+whitespace, and up to three leading spaces. The notebook output marker+@\<!-- scripths:mime … --\>@ is /not/ a version tag (its post-colon token is+@mime@, not a version), so it parses to 'Nothing'.+-}+parseTagLine :: TagStyle -> Text -> Maybe Version+parseTagLine style line = do+    let trimmed = normalizeLine line+    inner <- case style of+        ScriptTag -> T.stripPrefix "-- scripths:" trimmed+        NotebookTag ->+            T.stripPrefix "<!-- scripths:" trimmed+                >>= fmap T.stripEnd . T.stripSuffix "-->" . T.stripEnd+    -- Require whitespace after the colon, so @scripths:mime@ never matches.+    rest <- requireLeadingSpace inner+    parseVersionToken rest++-- | Strip a leading BOM, a trailing @\\r@\/whitespace, and up to three leading spaces.+normalizeLine :: Text -> Text+normalizeLine =+    dropLeadingSpaces (3 :: Int) . T.stripEnd . T.dropWhileEnd (== '\r') . dropBom+  where+    dropBom t = fromMaybe t (T.stripPrefix "\65279" t)+    dropLeadingSpaces 0 t = t+    dropLeadingSpaces n t = case T.uncons t of+        Just (' ', r) -> dropLeadingSpaces (n - 1) r+        _ -> t++requireLeadingSpace :: Text -> Maybe Text+requireLeadingSpace t = case T.uncons t of+    Just (c, _) | isSpace c -> Just (T.stripStart t)+    _ -> Nothing++{- | Parse a leading dotted-decimal version (e.g. @0.4.1.0@), ignoring trailing+text. Components are parsed as 'Integer' and clamped to 'maxBound' so an absurdly+long number cannot silently overflow 'Int' (which could otherwise wrap to a small+value and defeat the newer-than-binary check) — a too-big component stays "newer".+-}+parseVersionToken :: Text -> Maybe Version+parseVersionToken t =+    case T.splitOn "." token of+        parts@(_ : _)+            | not (any T.null parts) ->+                makeVersion . map clampToInt <$> traverse parseComponent parts+        _ -> Nothing+  where+    token = T.takeWhile (\c -> c == '.' || isDigit c) (T.stripStart t)+    parseComponent :: Text -> Maybe Integer+    parseComponent = readMaybe . T.unpack+    clampToInt :: Integer -> Int+    clampToInt = fromInteger . min (toInteger (maxBound :: Int))++{- | The scripths version a file declares, if any. Scans a small top-of-file+window: skip a leading @#!@ shebang (scripts) or a leading @---@ YAML+frontmatter block (notebooks), then read the first non-blank line.+-}+tagVersion :: TagStyle -> Text -> Maybe Version+tagVersion style contents =+    case dropWhile isBlank (snd (splitPreamble style (T.lines contents))) of+        (l : _) -> parseTagLine style l+        [] -> Nothing+  where+    isBlank = T.null . T.strip++{- | Split off a leading preamble that the tag sits /after/: a @#!@ shebang for+scripts, or a @---@…@---@ YAML frontmatter block for notebooks. Returns+@(preamble, rest)@.++A leading @---@ is treated as frontmatter only when the fenced block actually+looks like YAML (it closes with @---@ and contains at least one @key:@ line).+Otherwise the @---@ is an ordinary Markdown /thematic break/ and is left in the+body — so 'stampVersion' inserts the tag /above/ it rather than corrupting the+document by splicing into the middle (the @-i@ data-loss trap).+-}+splitPreamble :: TagStyle -> [Text] -> ([Text], [Text])+splitPreamble ScriptTag ls@(l : rest)+    | "#!" `T.isPrefixOf` T.stripStart l = ([l], rest)+    | otherwise = ([], ls)+splitPreamble NotebookTag ls@(l : rest)+    | T.strip l == "---"+    , (block, closing : afterClosing) <- break ((== "---") . T.strip) rest+    , any looksLikeYamlKey block =+        (l : block ++ [closing], afterClosing)+    | otherwise = ([], ls)+splitPreamble _ [] = ([], [])++{- | Does a line look like a YAML mapping entry (@key:@)? Used to tell a real+frontmatter block from a Markdown thematic break delimited by @---@.+-}+looksLikeYamlKey :: Text -> Bool+looksLikeYamlKey line =+    let (key, afterKey) = T.span (\c -> isAlphaNum c || c == '_' || c == '-') (T.stripStart line)+     in not (T.null key) && ":" `T.isPrefixOf` afterKey++{- | Ensure @contents@ carries the current version tag at the top of its body:+replace an existing tag line in place, or insert one after any shebang\/+frontmatter preamble. Exactly one blank line separates the tag from the body.+Idempotent.+-}+stampVersion :: TagStyle -> Text -> Text+stampVersion style contents =+    rejoin (preamble ++ tag : separator ++ body)+  where+    tag = versionTag style+    (preamble, rest) = splitPreamble style (T.lines contents)+    body = dropWhile isBlankLine (dropExistingTag rest)+    separator = ["" | not (null body)]+    dropExistingTag ls =+        let (_blanks, rest') = span isBlankLine ls+         in case rest' of+                (l : more) | isJustTag l -> more+                _ -> ls+    isJustTag l = isJust (parseTagLine style l)+    isBlankLine = T.null . T.strip++{- | Re-join lines, trimming leading\/trailing blank lines and re-adding a single+trailing newline iff there is content ('T.lines' drops the final newline).+-}+rejoin :: [Text] -> Text+rejoin ls =+    let trimmed = reverse (dropBlank (reverse (dropBlank ls)))+     in if null trimmed then "" else T.intercalate "\n" trimmed <> "\n"+  where+    dropBlank = dropWhile (T.null . T.strip)++-- | @Just@ a warning iff @declared@ is newer than the running scripths.+newerVersionWarning :: Version -> Maybe Text+newerVersionWarning declared+    | declared > scripthsVersion =+        Just $+            "file declares scripths "+                <> T.pack (showVersion declared)+                <> " but you are running "+                <> scripthsVersionText+                <> "; parsing may be incomplete \8212 consider upgrading scripths"+    | otherwise = Nothing

@@ -2,11 +2,15 @@  import Test.Tasty (defaultMain, testGroup) +import Test.Compiled (compiledTests)+import Test.Integration (integrationTests) import Test.Markdown (markdownTests) import Test.Notebook (notebookTests) import Test.Parser (parseTests) import Test.Render (renderTests)+import Test.Repl (replTests) import Test.Run (runTests)+import Test.Version (versionTests)  main :: IO () main =@@ -14,8 +18,12 @@         testGroup             "ScriptHs"             [ parseTests+            , compiledTests             , renderTests             , markdownTests             , notebookTests+            , replTests             , runTests+            , versionTests+            , integrationTests             ]

@@ -0,0 +1,186 @@+module Test.Compiled (compiledTests) where++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase, (@?=))++import Data.Text (Text)+import qualified Data.Text as T+import ScriptHs.Compiled (+    CellChunk (..),+    CompileIssue (..),+    checkCompilable,+    isValidModuleName,+    linePragmaTag,+    parseLinePragmaTag,+    renderCompiledModule,+ )+import ScriptHs.Parser (+    CompileDirective (..),+    ScriptFile (scriptCompile, scriptLines),+    Line (..),+    parseScript,+    parseScriptNumbered,+ )++numbered :: Text -> [(Int, Line)]+numbered = snd . parseScriptNumbered++compiledTests :: TestTree+compiledTests =+    testGroup+        "Compiled"+        [ directiveTests+        , numberedTests+        , checkTests+        , nameTests+        , tagTests+        , renderTests+        ]++directiveTests :: TestTree+directiveTests =+    testGroup+        "compile directive"+        [ testCase "absent by default" $+            scriptCompile (parseScript "x = 1\n") @?= Nothing+        , testCase "bare directive" $+            scriptCompile (parseScript "-- compile\nx = 1\n")+                @?= Just CompileDefault+        , testCase "named directive" $+            scriptCompile (parseScript "-- compile: Training\nx = 1\n")+                @?= Just (CompileNamed "Training")+        , testCase "dotted name" $+            scriptCompile (parseScript "-- compile: Training.Core\nx = 1\n")+                @?= Just (CompileNamed "Training.Core")+        , testCase "directive removed from script lines" $+            scriptLines (parseScript "-- compile\nx = 1\n")+                @?= [HaskellLine "x = 1"]+        , testCase "directive after cabal lines" $ do+            let sf = parseScript "-- cabal: build-depends: text\n-- compile\nx = 1\n"+            scriptCompile sf @?= Just CompileDefault+        , testCase "whitespace tolerated" $+            scriptCompile (parseScript "--  compile:  Training \nx = 1\n")+                @?= Just (CompileNamed "Training")+        , testCase "unrelated comment is not a directive" $+            scriptCompile (parseScript "-- compiled fast\nx = 1\n") @?= Nothing+        ]++numberedTests :: TestTree+numberedTests =+    testGroup+        "parseScriptNumbered"+        [ testCase "plain lines numbered from 1" $+            numbered "x = 1\ny = 2\n"+                @?= [(1, HaskellLine "x = 1"), (2, HaskellLine "y = 2")]+        , testCase "directive lines keep following numbering" $+            numbered "-- cabal: build-depends: text\n-- compile\nx = 1\n"+                @?= [(3, HaskellLine "x = 1")]+        , testCase "agrees with parseScript lines" $ do+            let src = "-- compile\nimport Data.List\n\nf :: Int -> Int\nf x = x\n"+            map snd (numbered src) @?= scriptLines (parseScript src)+        ]++checkTests :: TestTree+checkTests =+    testGroup+        "checkCompilable"+        [ testCase "declarations pass" $+            checkCompilable (numbered "f :: Int -> Int\nf x = x + 1\n") @?= []+        , testCase "imports and pragmas pass" $+            checkCompilable+                (numbered "{-# LANGUAGE LambdaCase #-}\nimport Data.List\n")+                @?= []+        , testCase "data declaration passes" $+            checkCompilable (numbered "data T = A | B\n") @?= []+        , testCase "bare expression rejected with its line" $ do+            let issues = checkCompilable (numbered "f x = x\n\nprint 3\n")+            map ciLine issues @?= [3]+        , testCase "monadic bind rejected" $ do+            let issues = checkCompilable (numbered "x <- readLn\n")+            map ciLine issues @?= [1]+        , testCase ":set -X allowed, other ghci commands rejected" $ do+            checkCompilable (numbered ":set -XLambdaCase\nf x = x\n") @?= []+            map ciLine (checkCompilable (numbered ":type f\nf x = x\n")) @?= [1]+        , testCase "TH splice allowed" $+            checkCompilable (numbered "$(pure [])\n") @?= []+        ]++nameTests :: TestTree+nameTests =+    testGroup+        "isValidModuleName"+        [ testCase "simple" $ isValidModuleName "Training" @?= True+        , testCase "dotted" $ isValidModuleName "Training.Core" @?= True+        , testCase "lowercase rejected" $ isValidModuleName "training" @?= False+        , testCase "empty segment rejected" $ isValidModuleName "A..B" @?= False+        , testCase "empty rejected" $ isValidModuleName "" @?= False+        , testCase "spaces rejected" $ isValidModuleName "A B" @?= False+        ]++tagTests :: TestTree+tagTests =+    testGroup+        "line pragma tags"+        [ testCase "round trip" $+            parseLinePragmaTag (linePragmaTag 42) @?= Just 42+        , testCase "non-tag rejected" $+            parseLinePragmaTag "Training" @?= Nothing+        ]++renderTests :: TestTree+renderTests =+    testGroup+        "renderCompiledModule"+        [ testCase "module header and decl with LINE pragma" $ do+            let src = renderCompiledModule "Training" [] [] [chunk 7 "f :: Int -> Int\nf x = x + 1\n"]+            assertContains src "module Training where"+            assertContains src ("{-# LINE 1 \"" <> linePragmaTag 7 <> "\" #-}")+            assertContains src "f x = x + 1"+        , testCase "default extensions become pragmas" $ do+            let src = renderCompiledModule "M" ["LambdaCase"] [] [chunk 1 "f x = x\n"]+            assertContains src "{-# LANGUAGE LambdaCase #-}"+        , testCase "imports hoisted with their own pragma and line" $ do+            let src =+                    renderCompiledModule+                        "M"+                        []+                        []+                        [chunk 3 "f x = x\nimport Data.List (sort)\ng y = sort y\n"]+            assertContains src ("{-# LINE 2 \"" <> linePragmaTag 3 <> "\" #-}")+            assertContains src "import Data.List (sort)"+            -- imports appear before declarations+            assertBool "import before decl" $+                textIndex "import Data.List" src < textIndex "f x = x" src+        , testCase "extra imports rendered before cell imports" $ do+            let src = renderCompiledModule "M" [] ["import Helpers"] [chunk 1 "f x = x\n"]+            assertContains src "import Helpers"+        , testCase ":set -X contributes a pragma" $ do+            let src = renderCompiledModule "M" [] [] [chunk 1 ":set -XGADTs\nf x = x\n"]+            assertContains src "{-# LANGUAGE GADTs #-}"+        , testCase "pragmas deduped" $ do+            let src =+                    renderCompiledModule+                        "M"+                        ["GADTs"]+                        []+                        [chunk 1 "{-# LANGUAGE GADTs #-}\nf x = x\n"]+            T.count "LANGUAGE GADTs" src @?= 1+        , testCase "unused-import warnings suppressed" $ do+            let src = renderCompiledModule "M" [] [] [chunk 1 "f x = x\n"]+            assertContains src "{-# OPTIONS_GHC -Wno-unused-imports #-}"+        , testCase "two chunks keep their own tags" $ do+            let src =+                    renderCompiledModule+                        "M"+                        []+                        []+                        [chunk 1 "f x = x\n", chunk 2 "g y = y\n"]+            assertContains src (linePragmaTag 1)+            assertContains src (linePragmaTag 2)+        ]+  where+    chunk cid src = CellChunk{ccTag = linePragmaTag cid, ccLines = numbered src}+    assertContains hay needle =+        assertBool (T.unpack ("missing: " <> needle <> "\nin:\n" <> hay)) $+            needle `T.isInfixOf` hay+    textIndex needle hay = T.length (fst (T.breakOn needle hay))

@@ -0,0 +1,47 @@+module Test.Integration (integrationTests) where++import qualified Data.Text as T+import System.Environment (lookupEnv)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase)++import ScriptHs.Notebook (processNotebook)+import ScriptHs.Run (defaultRunOptions)++{- | Out-of-band integration test: it actually drives @cabal repl@ (slow, needs a+toolchain), so it is gated behind @SCRIPTHS_INTEGRATION=1@ and is a no-op in the+default fast/pure suite. It is the only test that proves the injected preamble+genuinely /compiles and runs/ under @NoImplicitPrelude@ — what the string-level+"prelude-agnostic" checks in "Test.Repl" can only approximate — and that the+rendered notebook leaks none of scripths' internals end-to-end.+-}+integrationTests :: TestTree+integrationTests =+    testGroup+        "Integration (gated by SCRIPTHS_INTEGRATION=1)"+        [ testCase "a NoImplicitPrelude notebook runs and renders, no internals leaked" $ do+            gated <- lookupEnv "SCRIPTHS_INTEGRATION"+            case gated of+                Nothing -> pure () -- skipped in the default suite+                Just _ -> do+                    let nb =+                            T.unlines+                                [ "# Integration"+                                , ""+                                , "```haskell"+                                , "-- cabal: default-extensions: NoImplicitPrelude"+                                , "import Prelude (String)"+                                , "\"rendered-ok\" :: String"+                                , "```"+                                ]+                    out <- processNotebook defaultRunOptions "/tmp/scripths-integration.md" nb+                    assertBool "renders the cell value" ("rendered-ok" `T.isInfixOf` out)+                    assertBool+                        "no ScripthsInternal leak"+                        (not ("ScripthsInternal" `T.isInfixOf` out))+                    assertBool+                        "no scripthsAutoPrint leak"+                        (not ("scripthsAutoPrint" `T.isInfixOf` out))+                    assertBool "no block-marker leak" (not ("SCRIPTHS_BLOCK" `T.isInfixOf` out))+                    assertBool "no compile error" (not ("error:" `T.isInfixOf` out))+        ]

@@ -11,16 +11,22 @@     generatedMarkedScript,     isHaskell,     isPython,+    markerStatement,     mkIndexedCodeSegments,     mkMarker,     parseBlocks,     processNotebook,+    scrubCellOutput,     splitByMarkers,  )  import ScriptHs.Parser (CabalMeta (metaDeps), Line (..)) import ScriptHs.Run (defaultRunOptions) +-- | A fixed nonce for marker tests (the real one is per-run; see 'makeNonce').+tn :: T.Text+tn = "TESTNONCE"+ notebookTests :: TestTree notebookTests =     testGroup@@ -63,32 +69,34 @@             ]         , testGroup             "mkMarker"-            [ testCase "format includes index" $ do-                mkMarker 0 @?= "---SCRIPTHS_BLOCK_0_END---"-                mkMarker 12 @?= "---SCRIPTHS_BLOCK_12_END---"+            [ testCase "format includes nonce and index" $ do+                mkMarker tn 0 @?= "---SCRIPTHS_BLOCK_" <> tn <> "_0_END---"+                mkMarker tn 12 @?= "---SCRIPTHS_BLOCK_" <> tn <> "_12_END---"+            , testCase "different nonces give different markers (anti-spoofing)" $+                assertBool "differ" (mkMarker "aaaa" 0 /= mkMarker "bbbb" 0)             ]         , testGroup             "splitByMarkers"             [ testCase "empty marker list => []" $ do-                splitByMarkers "anything" [] @?= []+                splitByMarkers tn "anything" [] @?= []             , testCase "marker not found => strip remaining as output for that idx" $ do                 let out = "  hello world  \n"-                splitByMarkers out [0] @?= [(0, "hello world")]+                splitByMarkers tn out [0] @?= [(0, "hello world")]             , testCase "single marker splits before it" $ do-                let out = T.unlines ["42", mkMarker 0, "ignored trailing"]-                splitByMarkers out [0] @?= [(0, "42")]+                let out = T.unlines ["42", mkMarker tn 0, "ignored trailing"]+                splitByMarkers tn out [0] @?= [(0, "42")]             , testCase "multiple markers split sequentially" $ do                 let out =                         T.concat                             [ "cell0\n"-                            , mkMarker 0+                            , mkMarker tn 0                             , "\ncell1\n"-                            , mkMarker 1+                            , mkMarker tn 1                             , "\ncell2\n"-                            , mkMarker 2+                            , mkMarker tn 2                             , "\n"                             ]-                splitByMarkers out [0, 1, 2]+                splitByMarkers tn out [0, 1, 2]                     @?= [ (0, "cell0")                         , (1, "cell1")                         , (2, "cell2")@@ -97,13 +105,17 @@                 let out =                         T.concat                             [ "cell0\n"-                            , mkMarker 0+                            , mkMarker tn 0                             , "\ncell1-no-marker-at-end\n"                             ]-                splitByMarkers out [0, 1]+                splitByMarkers tn out [0, 1]                     @?= [ (0, "cell0")                         , (1, "cell1-no-marker-at-end")                         ]+            , testCase "output spoofing a DIFFERENT nonce's marker is not split on" $ do+                -- A cell printing a marker with the wrong nonce can't steal a boundary.+                let out = "real" <> mkMarker "OTHER" 0 <> "data\n" <> mkMarker tn 0+                splitByMarkers tn out [0] @?= [(0, "real" <> mkMarker "OTHER" 0 <> "data")]             ]         , testGroup             "mkIndexedCodeSegments"@@ -164,22 +176,26 @@                         [ (10, [HaskellLine "print 10"])                         , (11, [HaskellLine "print 11"])                         ]-                let ls = generatedMarkedScript blocks+                let ls = generatedMarkedScript tn blocks                  assertBool "has first line" (HaskellLine "print 10" `elem` ls)                 assertBool "has second line" (HaskellLine "print 11" `elem` ls) -                let m10 = mkMarker 10-                    m11 = mkMarker 11+                let m10 = mkMarker tn 10+                    m11 = mkMarker tn 11                  assertBool-                    "has putStrLn marker 10"-                    (HaskellLine ("putStrLn " <> T.pack (show (T.unpack m10))) `elem` ls)+                    "has marker statement 10"+                    (HaskellLine (markerStatement m10) `elem` ls)                  assertBool-                    "has putStrLn marker 11"-                    (HaskellLine ("putStrLn " <> T.pack (show (T.unpack m11))) `elem` ls)+                    "has marker statement 11"+                    (HaskellLine (markerStatement m11) `elem` ls) +                assertBool+                    "marker print is prelude-qualified"+                    (T.isInfixOf ".putStrLn" (markerStatement m10))+                 assertBool "has Blank separators" (Blank `elem` ls)             ]         , testGroup@@ -230,5 +246,23 @@                             ]                 out <- processNotebook defaultRunOptions "" input                 out @?= input+            ]+        , testGroup+            "scrubCellOutput"+            [ testCase "removes a block marker that survived splitting" $ do+                let out = "line one\n" <> mkMarker tn 1 <> "\nline two"+                    scrubbed = scrubCellOutput tn [0, 1, 2] out+                assertBool "no marker leaks" (not (T.isInfixOf "SCRIPTHS_BLOCK" scrubbed))+                assertBool "keeps the stdout" (T.isInfixOf "line one" scrubbed)+            , testCase "scrubs scripths internal identifiers from a cell error" $ do+                let scrubbed =+                        scrubCellOutput tn [0] "No instance for Show .. use of scripthsAutoPrint"+                assertBool "no autoprint name" (not (T.isInfixOf "scripthsAutoPrint" scrubbed))+            , testCase "strips markers for every listed index" $ do+                let out = "a" <> mkMarker tn 0 <> "b" <> mkMarker tn 2 <> "c"+                scrubCellOutput tn [0, 1, 2] out @?= "abc"+            , testCase "a marker whose index is NOT a real cell is left intact" $ do+                let out = "real data: " <> mkMarker tn 5+                scrubCellOutput tn [0] out @?= out             ]         ]

@@ -58,6 +58,31 @@                 case scriptLines sf of                     [Pragma t] -> assertBool "pragma" (T.isPrefixOf "{-#" t)                     other -> assertFailure $ "expected Pragma, got: " ++ show other+            , testCase "a leading -- scripths: version tag is dropped, not treated as code" $ do+                let sf = parseScript "-- scripths: 0.4.1.0\nimport Data.Text (Text)\n"+                case scriptLines sf of+                    [Import _] -> pure ()+                    other -> assertFailure $ "expected the tag dropped, got: " ++ show other+            , testCase "a -- scripths: comment in the body is kept, not silently dropped" $ do+                let sf = parseScript "x = 1\n-- scripths: just a note\ny = 2\n"+                    kept = any (lineHasText "-- scripths: just a note") (scriptLines sf)+                assertBool "mid-body comment retained" kept+            , testCase "a leading -- scripths:mime line is not a tag (kept)" $ do+                let sf = parseScript "-- scripths:mime text/plain\nimport Data.Text (Text)\n"+                    kept = any (lineHasText "-- scripths:mime text/plain") (scriptLines sf)+                assertBool "mime line retained" kept+            , testCase "leading tag then a -- cabal: line: tag dropped, dep still parsed" $ do+                let sf = parseScript "-- scripths: 1.2.3\n-- cabal: build-depends: text\nimport X\n"+                (metaDeps . scriptMeta) sf @?= ["text"]+                scriptLines sf @?= [Import "import X"]+            , testCase+                "a tag AFTER a shebang is not dropped (only the first non-blank is checked)"+                $ do+                    -- Pins current behaviour: dropLeadingVersionTag inspects the first+                    -- non-blank line (the shebang), so the tag survives as a comment line.+                    let sf = parseScript "#!/usr/bin/env scripths\n-- scripths: 1.2.3\nimport X\n"+                    assertBool "tag line retained" $+                        any (lineHasText "-- scripths: 1.2.3") (scriptLines sf)             , testCase "haskell line" $ do                 let sf = parseScript "print (5 + 5)\n"                 case scriptLines sf of@@ -225,3 +250,12 @@ notBlank :: Line -> Bool notBlank Blank = False notBlank _ = True++-- | Does a parsed line carry text containing the needle?+lineHasText :: T.Text -> Line -> Bool+lineHasText s ln = case ln of+    HaskellLine t -> s `T.isInfixOf` t+    GhciCommand t -> s `T.isInfixOf` t+    Pragma t -> s `T.isInfixOf` t+    Import t -> s `T.isInfixOf` t+    Blank -> False

@@ -0,0 +1,152 @@+module Test.Repl (replTests) where++import qualified Data.Text as T+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase, (@?=))++import ScriptHs.Repl (+    autoPrintDirective,+    cdDirective,+    compileCdSetup,+    compileCdTo,+    replEvalExpr,+    scripthsInternalQualifiers,+    scrubInternalNames,+ )++replTests :: TestTree+replTests =+    testGroup+        "Repl"+        [ compileCdToTests+        , cdDirectiveTests+        , preludeAgnosticTests+        , scrubTests+        ]++cdDirectiveTests :: TestTree+cdDirectiveTests =+    testGroup+        "cdDirective"+        [ testCase "runtime chdir via qualified System.Directory, show-escaped path" $ do+            let txt = cdDirective "/data/my project"+            assertBool "imports Directory qualified" $+                T.isInfixOf "import qualified System.Directory as ScripthsInternalDir" txt+            assertBool "calls setCurrentDirectory" $+                T.isInfixOf "ScripthsInternalDir.setCurrentDirectory" txt+            assertBool "path is show-escaped (quoted)" $+                T.isInfixOf "\"/data/my project\"" txt+            assertBool "no bare Prelude" (not (T.isInfixOf "Prelude" txt))+        ]++compileCdToTests :: TestTree+compileCdToTests =+    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)+        , testCase "sequences via qualified >>/pure, not bare Prelude" $ do+            let txt = compileCdTo "/some/dir"+            assertBool "qualified (>>)" (T.isInfixOf "ScripthsInternalMonad.>>" txt)+            assertBool "qualified pure" (T.isInfixOf "ScripthsInternalApplicative.pure" txt)+            assertBool "no bare Prelude" (not (T.isInfixOf "Prelude." txt))+        ]++preludeAgnosticTests :: TestTree+preludeAgnosticTests =+    testGroup+        "prelude-agnostic injection"+        -- Every name scripths injects into the repl is qualified against a base+        -- module other than Prelude, so a notebook under NoImplicitPrelude / a+        -- custom prelude still runs (and the implicit Prelude is not suppressed).+        [ testCase "autoPrintDirective qualifies through System.IO, not Prelude" $ do+            assertBool "imports System.IO qualified" $+                T.isInfixOf+                    "import qualified System.IO as ScripthsInternalIO"+                    autoPrintDirective+            assertBool "sets the auto-print" $+                T.isInfixOf "-interactive-print scripthsAutoPrint" autoPrintDirective+            assertBool "never mentions Prelude" $+                not (T.isInfixOf "Prelude" autoPrintDirective)+        , testCase "compileCdSetup imports the sequencing modules qualified" $ do+            assertBool "Control.Monad" $+                T.isInfixOf+                    "import qualified Control.Monad as ScripthsInternalMonad"+                    compileCdSetup+            assertBool "Control.Applicative" $+                T.isInfixOf+                    "import qualified Control.Applicative as ScripthsInternalApplicative"+                    compileCdSetup+        , testCase "the -e terminator is prelude-free and space-free" $ do+            assertBool+                "uses qualified hFlush"+                (T.isInfixOf "ScripthsInternalIO.hFlush" replEvalExpr)+            assertBool "no Prelude" (not (T.isInfixOf "Prelude" replEvalExpr))+            assertBool "no return" (not (T.isInfixOf "return" replEvalExpr))+            assertBool "no spaces" (not (T.isInfixOf " " replEvalExpr))+        , testCase "the full injected preamble names no Prelude dependency" $ do+            -- The whole script.ghci prefix, assembled, must not mention Prelude.+            let injected =+                    autoPrintDirective+                        <> cdDirective "/some/dir"+                        <> compileCdSetup+                        <> compileCdTo "/some/dir"+            assertBool "no Prelude anywhere" (not (T.isInfixOf "Prelude" injected))+        ]++scrubTests :: TestTree+scrubTests =+    testGroup+        "scrubInternalNames"+        -- Captured GHCi diagnostics must read like vanilla GHCi, never exposing+        -- the synthetic preamble's identifiers.+        [ testCase "rewrites scripthsAutoPrint to print" $ do+            let s =+                    scrubInternalNames+                        "arising from a use of scripthsAutoPrint\nscripthsAutoPrint it"+            assertBool "no scripthsAutoPrint" (not (T.isInfixOf "scripthsAutoPrint" s))+            assertBool "reads as print it" (T.isInfixOf "print it" s)+        , testCase "strips an internal qualifier (the IsString leak)" $+            scrubInternalNames "No instance for (ScripthsInternalStr.IsString Int)"+                @?= "No instance for (IsString Int)"+        , testCase "removes every internal qualifier" $ do+            let sample = T.unwords [q <> ".foo" | q <- scripthsInternalQualifiers]+            assertBool+                "no ScripthsInternal remains"+                (not (T.isInfixOf "ScripthsInternal" (scrubInternalNames sample)))+        , testCase "rewrites the ScripthsAutoPrint class to Show" $ do+            -- The common non-Showable-cell error is `No instance for (ScripthsAutoPrint …)`.+            let s =+                    scrubInternalNames+                        "No instance for (ScripthsAutoPrint Foo) arising from a use of scripthsAutoPrint"+            assertBool "class gone" (not (T.isInfixOf "ScripthsAutoPrint" s))+            assertBool "reads as Show" (T.isInfixOf "No instance for (Show Foo)" s)+        , testCase "a bare alias (no trailing dot) becomes its real module" $+            scrubInternalNames "Could not load module 'ScripthsInternalDir'"+                @?= "Could not load module 'System.Directory'"+        , testCase "leaves ordinary output untouched" $+            scrubInternalNames "Variable not in scope: frobnicate"+                @?= "Variable not in scope: frobnicate"+        , testCase "preserves multibyte Unicode while scrubbing (guards the UTF-8 path)" $ do+            -- GHC diagnostics carry Unicode (curly quotes, the • bullet); scrubbing an+            -- internal name beside them must not mangle the surrounding text.+            let s =+                    scrubInternalNames+                        "Variable not in scope: \8216caf\233\8217 \8226 ScripthsInternalDir.x"+            assertBool "keeps the curly-quoted café" (T.isInfixOf "\8216caf\233\8217" s)+            assertBool "keeps the bullet" (T.isInfixOf "\8226" s)+            assertBool "still scrubbed" (not (T.isInfixOf "ScripthsInternal" s))+        , testCase "scrubbing is idempotent (scrub . scrub == scrub)" $ do+            let sample =+                    T.unwords+                        [ "ScripthsInternalStr.IsString"+                        , "bare ScripthsInternalDir"+                        , "scripthsAutoPrint"+                        , "ScripthsAutoPrint"+                        ]+                once = scrubInternalNames sample+            scrubInternalNames once @?= once+        ]

@@ -1,6 +1,6 @@ module Test.Run (runTests) where -import Data.List (isPrefixOf)+import Data.List (isInfixOf, isPrefixOf) import qualified Data.Text as T import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertBool, testCase, (@?=))@@ -8,7 +8,6 @@ import ScriptHs.Parser (CabalMeta (..), Line (..), SourceRepoPin (..)) import ScriptHs.Run (     cabalArgs,-    compileCdTo,     deriveProjectName,     renderCabalFile,     renderCabalProject,@@ -24,14 +23,20 @@         "Run"         [ testGroup             "cabalArgs"-            [ testCase "uses -ghci-script= and -e return() for batch mode" $ do+            [ testCase "uses -ghci-script= and a prelude-free -e terminator 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()"+                        , "--repl-option=ScripthsInternalIO.hFlush(ScripthsInternalIO.stdout)"                         ]+            , testCase+                "the -e terminator has no spaces (cabal splits --repl-option on whitespace)"+                $ do+                    let args = cabalArgs "/proj" "/proj/script.ghci"+                        eTerm = last (filter ("--repl-option=" `isPrefixOf`) args)+                    assertBool "no space in terminator" (not (' ' `elem` eTerm))             , testCase "includes --project-dir" $ do                 let args = cabalArgs "/proj" "/proj/script.ghci"                 assertBool "--project-dir present" $@@ -57,13 +62,29 @@             ]         , testGroup             "deriveProjectName"-            [ testCase "sanitizes non-alphanumerics to dashes" $-                deriveProjectName "/a/b/probe.md" @?= "a-b-probe-md"+            [ testCase "sanitises to a readable stem, then a -h<hash> suffix" $ do+                let n = deriveProjectName "/a/b/probe.md"+                assertBool "readable stem" ("a-b-probe-md-h" `isPrefixOf` n)+                assertBool "no double dash" (not ("--" `isInfixOf` n))             , 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"+                assertBool "stem" ("x-probe-md-h" `isPrefixOf` deriveProjectName "/x/_probe.md")+            , testCase "distinct paths that sanitise alike do NOT collide" $+                -- foo.md and foo-md both sanitise to home-u-foo-md; the hash keeps+                -- them in separate ~/.scripths dirs.+                assertBool "differ" $+                    deriveProjectName "/home/u/foo.md" /= deriveProjectName "/home/u/foo-md"+            , testCase "is stable for the same path" $+                deriveProjectName "/home/u/x.md" @?= deriveProjectName "/home/u/x.md"+            , testCase "non-ASCII letters become dashes (cabal needs ASCII names)" $ do+                let n = deriveProjectName "/проект/данные.md"+                assertBool+                    "ASCII only"+                    (all (\c -> c == '-' || (c >= 'a' && c <= 'z') || (c >= '0' && c <= '9')) n)+            , testCase "an all-symbol path still yields a valid name" $+                assertBool+                    "fallback stem"+                    ("scripths-script-h" `isPrefixOf` deriveProjectName "/---")             ]         , testGroup             "renderCabalFile"@@ -102,14 +123,6 @@             , 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

@@ -0,0 +1,208 @@+module Test.Version (versionTests) where++import qualified Data.Text as T+import Data.Version (makeVersion)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase, (@?=))++import ScriptHs.Version (+    TagStyle (..),+    newerVersionWarning,+    parseTagLine,+    scripthsVersion,+    scripthsVersionText,+    stampVersion,+    tagStyleFor,+    tagVersion,+    versionTag,+ )++versionTests :: TestTree+versionTests =+    testGroup+        "Version"+        [ tagStyleForTests+        , versionTagTests+        , parseTagLineTests+        , tagVersionTests+        , stampVersionTests+        , newerVersionWarningTests+        ]++tagStyleForTests :: TestTree+tagStyleForTests =+    testGroup+        "tagStyleFor"+        [ testCase "md/markdown => NotebookTag (case-insensitive)" $ do+            tagStyleFor "x.md" @?= NotebookTag+            tagStyleFor "x.markdown" @?= NotebookTag+            tagStyleFor "X.MD" @?= NotebookTag+            tagStyleFor "x.MARKDOWN" @?= NotebookTag+            tagStyleFor "x.Md" @?= NotebookTag+        , testCase "ghci/hs/other => ScriptTag" $ do+            tagStyleFor "x.ghci" @?= ScriptTag+            tagStyleFor "x.hs" @?= ScriptTag+            tagStyleFor "noext" @?= ScriptTag+        ]++versionTagTests :: TestTree+versionTagTests =+    testGroup+        "versionTag"+        [ testCase "script form" $+            versionTag ScriptTag @?= "-- scripths: " <> scripthsVersionText+        , testCase "notebook form" $+            versionTag NotebookTag @?= "<!-- scripths: " <> scripthsVersionText <> " -->"+        ]++parseTagLineTests :: TestTree+parseTagLineTests =+    testGroup+        "parseTagLine"+        [ testCase "script tag" $+            parseTagLine ScriptTag "-- scripths: 1.2.3.4"+                @?= Just (makeVersion [1, 2, 3, 4])+        , testCase "notebook tag" $+            parseTagLine NotebookTag "<!-- scripths: 1.2.3.4 -->"+                @?= Just (makeVersion [1, 2, 3, 4])+        , testCase "tolerates trailing CRLF and whitespace" $ do+            parseTagLine NotebookTag "<!-- scripths: 1.2.3 -->\r"+                @?= Just (makeVersion [1, 2, 3])+            parseTagLine ScriptTag "-- scripths: 1.2.3   " @?= Just (makeVersion [1, 2, 3])+        , testCase "tolerates a leading BOM and up to 3 leading spaces" $ do+            parseTagLine NotebookTag "\65279<!-- scripths: 1.0 -->"+                @?= Just (makeVersion [1, 0])+            parseTagLine NotebookTag "   <!-- scripths: 1.0 -->"+                @?= Just (makeVersion [1, 0])+        , testCase "4+ leading spaces is an indented code block, not a tag" $+            parseTagLine NotebookTag "    <!-- scripths: 1.0 -->" @?= Nothing+        , testCase "scripths:mime output marker is not a version tag" $+            parseTagLine NotebookTag "<!-- scripths:mime text/plain -->" @?= Nothing+        , testCase "ordinary lines are not tags" $ do+            parseTagLine ScriptTag "import Data.Text" @?= Nothing+            parseTagLine NotebookTag "# Title" @?= Nothing+        , testCase "an over-long component clamps instead of silently overflowing Int" $ do+            let huge = parseTagLine NotebookTag "<!-- scripths: 99999999999999999999999999.0 -->"+            assertBool "still parses" (huge /= Nothing)+            assertBool "stays larger than a normal version (no wrap)" $+                maybe False (> makeVersion [1, 0]) huge+        , testCase "leading zeros in a component are tolerated" $+            parseTagLine ScriptTag "-- scripths: 01.2" @?= Just (makeVersion [1, 2])+        , testCase "trailing non-numeric junk after the version is ignored" $+            parseTagLine ScriptTag "-- scripths: 1.2.3-beta"+                @?= Just (makeVersion [1, 2, 3])+        , testCase "empty/edge components are rejected" $ do+            parseTagLine ScriptTag "-- scripths: 1..2" @?= Nothing+            parseTagLine ScriptTag "-- scripths: .1" @?= Nothing+            parseTagLine ScriptTag "-- scripths: 1." @?= Nothing+            parseTagLine ScriptTag "-- scripths: " @?= Nothing+        ]++tagVersionTests :: TestTree+tagVersionTests =+    testGroup+        "tagVersion"+        [ testCase "reads the first line" $+            tagVersion NotebookTag "<!-- scripths: 2.0 -->\n# Title\n"+                @?= Just (makeVersion [2, 0])+        , testCase "skips a leading shebang in a script" $+            tagVersion ScriptTag "#!/usr/bin/env scripths\n-- scripths: 2.0\nfoo\n"+                @?= Just (makeVersion [2, 0])+        , testCase "skips a leading YAML frontmatter block in a notebook" $+            tagVersion+                NotebookTag+                "---\ntitle: x\n---\n<!-- scripths: 2.0 -->\n# Title\n"+                @?= Just (makeVersion [2, 0])+        , testCase "no tag => Nothing" $+            tagVersion NotebookTag "# Title\n\nprose\n" @?= Nothing+        , testCase "unterminated '---' (no closing fence) is not frontmatter" $+            -- First non-blank line is '---' (a thematic break), so there is no tag.+            tagVersion NotebookTag "---\ntitle: x\n# Body\n" @?= Nothing+        ]++stampVersionTests :: TestTree+stampVersionTests =+    testGroup+        "stampVersion"+        [ testCase "prepends when missing (script)" $ do+            let out = stampVersion ScriptTag "import X\n"+            tagVersion ScriptTag out @?= Just scripthsVersion+            assertBool "keeps body" ("import X" `T.isInfixOf` out)+        , testCase "prepends when missing (notebook)" $ do+            let out = stampVersion NotebookTag "# Title\n"+            tagVersion NotebookTag out @?= Just scripthsVersion+            assertBool "keeps body" ("# Title" `T.isInfixOf` out)+        , testCase "idempotent: stamp . stamp == stamp" $ do+            let once = stampVersion NotebookTag "# Title\n\nprose\n"+                twice = stampVersion NotebookTag once+            twice @?= once+        , testCase "refreshes an old tag in place without stacking" $ do+            let out = stampVersion NotebookTag "<!-- scripths: 0.0.0.1 -->\n\n# Title\n"+            tagVersion NotebookTag out @?= Just scripthsVersion+            assertBool "old version gone" (not ("0.0.0.1" `T.isInfixOf` out))+            assertBool "keeps body" ("# Title" `T.isInfixOf` out)+            assertBool "single tag" (T.count "scripths:" out == 1)+        , testCase "inserts after a YAML frontmatter block" $ do+            let src = "---\ntitle: x\n---\n# Body\n"+                out = stampVersion NotebookTag src+            tagVersion NotebookTag out @?= Just scripthsVersion+            assertBool "frontmatter preserved" ("title: x" `T.isInfixOf` out)+            assertBool "tag sits after the closing ---" $+                T.isInfixOf "---\n" out+                    && maybe False (T.isInfixOf "<!-- scripths:") (lastFrontmatterTail out)+        , testCase "frontmatter stamping is idempotent" $ do+            let once = stampVersion NotebookTag "---\ntitle: x\n---\n# Body\n"+            stampVersion NotebookTag once @?= once+        , testCase "a leading Markdown thematic break is not treated as frontmatter" $ do+            -- Regression: a `---` rule is NOT YAML, so the tag must go ABOVE it,+            -- never spliced into the body (the in-place data-corruption trap).+            let src = "---\nIntro prose under a rule.\n\nSection.\n\n---\n\nMore.\n"+                out = stampVersion NotebookTag src+            tagVersion NotebookTag out @?= Just scripthsVersion+            assertBool "body intact" ("Intro prose under a rule." `T.isInfixOf` out)+            assertBool "single tag" (T.count "<!-- scripths:" out == 1)+            assertBool "tag is above the first rule" $+                maybe+                    False+                    (T.isInfixOf "---")+                    (T.stripPrefix (versionTag NotebookTag <> "\n") out)+        , testCase "thematic-break stamping is idempotent (no creeping corruption)" $ do+            let src = "---\nIntro prose under a rule.\n\n---\n\nMore.\n"+                once = stampVersion NotebookTag src+            stampVersion NotebookTag once @?= once+        , testCase "a file that is only '---' is a rule, not frontmatter: tag goes above" $ do+            let out = stampVersion NotebookTag "---\n"+            tagVersion NotebookTag out @?= Just scripthsVersion+            assertBool "rule kept" ("---" `T.isInfixOf` out)+            assertBool "tag above the rule" $+                maybe+                    False+                    (T.isInfixOf "---")+                    (T.stripPrefix (versionTag NotebookTag <> "\n") out)+        , testCase "unterminated frontmatter is not spliced into (tag goes to the top)" $ do+            let out = stampVersion NotebookTag "---\ntitle: x\n# Body\n"+            tagVersion NotebookTag out @?= Just scripthsVersion+            assertBool "body intact" ("# Body" `T.isInfixOf` out)+            assertBool "single tag" (T.count "<!-- scripths:" out == 1)+            assertBool "tag is the first line" $+                maybe False (const True) (T.stripPrefix (versionTag NotebookTag) out)+        ]+  where+    -- Text after the second "---" line, where the tag must live.+    lastFrontmatterTail t = case T.splitOn "---" t of+        (_ : _ : tl : _) -> Just tl+        _ -> Nothing++newerVersionWarningTests :: TestTree+newerVersionWarningTests =+    testGroup+        "newerVersionWarning"+        [ testCase "newer => warns" $+            assertBool+                "warns"+                (maybe False (const True) (newerVersionWarning (makeVersion [99, 0])))+        , testCase "current => silent" $+            newerVersionWarning scripthsVersion @?= Nothing+        , testCase "older => silent" $+            newerVersionWarning (makeVersion [0]) @?= Nothing+        ]