scripths (empty) → 0.1.0.0
raw patch · 15 files changed
+1510/−0 lines, 15 filesdep +basedep +filepathdep +process
Dependencies added: base, filepath, process, scripths, tasty, tasty-hunit, temporary, text
Files
- CHANGELOG.md +5/−0
- LICENSE +20/−0
- README.md +99/−0
- app/Main.hs +48/−0
- scripths.cabal +69/−0
- src/ScriptHs/Markdown.hs +58/−0
- src/ScriptHs/Notebook.hs +90/−0
- src/ScriptHs/Parser.hs +173/−0
- src/ScriptHs/Render.hs +130/−0
- src/ScriptHs/Run.hs +87/−0
- test/Main.hs +19/−0
- test/Test/Markdown.hs +195/−0
- test/Test/Notebook.hs +203/−0
- test/Test/Parser.hs +159/−0
- test/Test/Render.hs +155/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for scripths++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2026 DataHaskell++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,99 @@+# scripths++GHCi scripts for standalone execution and Markdown documentation.++**scripths** lets you write `.ghci` scripts with dependency management and run them as standalone programs — or embed executable Haskell code blocks in Markdown files and evaluate them notebook-style with captured output.++## Features++- **Standalone `.ghci` execution** — Run GHCi scripts directly from the command line, with automatic dependency.+- **Cabal metadata directives** — Declare `build-depends`, `default-extensions`, and `ghc-options` inline using `-- cabal:` comments.+- **Markdown notebooks** — Execute Haskell code blocks inside Markdown files and render the output back into the document as block quotes.+- **Smart GHCi rendering** — Multi-line definitions are automatically wrapped in `:{`/`:}` blocks, and IO binds / Template Haskell splices are handled correctly as individual statements.++## Installation++```bash+cabal install scripths+```++## CLI Usage++```+scripths [--output=<filename>] [-o <filename>] <script>+```++When `-o` / `--output` is provided for Markdown files, the result is written to that path. Otherwise it is printed to stdout. The file extension determines the mode. `.ghci` / `hs` files are parsed and executed as a standalone GHCi script. `.md` / `.markdown` files are processed as a notebook with captured output.++Requires GHC and cabal-install on your PATH.++## Quick Start++### Running a GHCi script++Create a file `example.ghci`:++```haskell+double :: Int -> Int+double = (*2)++-- cabal: build-depends: text+:set -XOverloadedStrings+import qualified Data.Text as T++T.take 10 "hello"++double 5+```++Run it:++```bash+scripths example.ghci+```++### Running a Markdown notebook++Create a file `notebook.md`:++````markdown+# My Analysis++Some introductory prose.++```haskell+print (5 + 5)+```++Define some values:++```haskell+x = 10+y = 20+```++We can then add the values in the next block and+the output is embeded below.++```haskell+x + y+```+````++Run it and write the results to a new file:++```bash+scripths -o output.md notebook.md+```++Each Haskell code block is evaluated in order, and its output is inserted into the Markdown as a block quote beneath the code fence.++## Cabal Metadata Directives++You can declare dependencies, language extensions, and GHC options directly inside your scripts using `-- cabal:` comments:++```+-- cabal: build-depends: text, containers+-- cabal: default-extensions: OverloadedStrings, TypeApplications+-- cabal: ghc-options: -Wall+```
+ app/Main.hs view
@@ -0,0 +1,48 @@+module Main where++import Data.List ( isPrefixOf )+import qualified Data.Text.IO as TIO+import System.Environment (getArgs, getProgName)+import System.Exit (exitFailure)+import System.FilePath (takeExtension)++import ScriptHs.Notebook (runNotebook)+import ScriptHs.Parser (parseScript)+import ScriptHs.Run (runScript)++main :: IO ()+main = do+ args <- getArgs+ case args of+ [path] -> dispatch path Nothing+ [] -> usage+ _ -> dispatch (last args) (outputFile (init args))++dispatch :: FilePath -> Maybe FilePath -> IO ()+dispatch path outputPath =+ case takeExtension path of+ ".md" -> runNotebook path outputPath+ ".markdown" -> runNotebook path outputPath+ _ -> do+ contents <- TIO.readFile path+ let sf = parseScript contents+ runScript sf++-- TODO: This is kinda brittle but I don't wanna+-- include the whole opt parser lib just to+-- get the output file. Maybe there's a cheaper+-- way to do this.+outputFile :: [String] -> Maybe FilePath+outputFile [] = Nothing+outputFile ("-o" : f : _) = Just f+outputFile (x : xs) =+ if "--output=" `isPrefixOf` x+ then Just (drop (length "--output=") x)+ else outputFile (tail xs)++usage :: IO ()+usage = do+ prog <- getProgName+ putStrLn $+ "Usage: " ++ prog ++ " [--output=<filename>] [-o <filename>] <script>"+ exitFailure
+ scripths.cabal view
@@ -0,0 +1,69 @@+cabal-version: 3.0+name: scripths+version: 0.1.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/+license: MIT+license-file: LICENSE+author: DataHaskell+maintainer: mschavinda@gmail.com+category: Data+build-type: Simple+extra-doc-files: CHANGELOG.md, README.md+tested-with: GHC ==9.6.7+bug-reports: https://github.com/DataHaskell/scripths/issues++source-repository head+ type: git+ location: https://github.com/DataHaskell/scripths++common warnings+ ghc-options: -Wall++library+ import: warnings+ exposed-modules: ScriptHs.Parser,+ ScriptHs.Render,+ ScriptHs.Markdown,+ ScriptHs.Notebook,+ ScriptHs.Run+ build-depends: base >= 4 && < 5,+ filepath >= 1.4 && < 1.6,+ process >= 1.6 && < 1.8,+ temporary >= 1.3 && < 1.4,+ text >= 2.0 && < 3+ hs-source-dirs: src+ default-language: Haskell2010+ default-extensions: OverloadedStrings++executable scripths+ import: warnings+ main-is: Main.hs+ build-depends:+ base >= 4 && < 5,+ scripths,+ filepath >= 1.4 && < 1.6,+ text >= 2.0 && < 3,++ hs-source-dirs: app+ default-language: Haskell2010++test-suite scripths-test+ import: warnings+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ other-modules: Test.Parser,+ Test.Render,+ Test.Markdown,+ Test.Notebook+ build-depends:+ base >= 4 && < 5,+ scripths,+ text >= 1.2 && < 2.2,+ tasty >= 1.4 && < 1.6,+ tasty-hunit >= 0.10 && < 0.11+ default-extensions: OverloadedStrings+ ghc-options: -Wall
+ src/ScriptHs/Markdown.hs view
@@ -0,0 +1,58 @@+module ScriptHs.Markdown (+ Segment (..),+ parseMarkdown,+ reassemble,+) where++import Data.Text (Text)+import qualified Data.Text as T++data Segment+ = Prose Text+ | CodeBlock Text Text (Maybe Text)+ deriving (Show, Eq)++parseMarkdown :: Text -> [Segment]+parseMarkdown = parseMarkdown' [] . T.lines++parseMarkdown' :: [Text] -> [Text] -> [Segment]+parseMarkdown' acc [] = [Prose prose | not (T.null prose)]+ where+ prose = T.unlines acc+parseMarkdown' acc (line : rest) = case T.strip <$> T.stripPrefix fence line of+ Nothing -> parseMarkdown' (acc ++ [line]) rest+ Just lang ->+ let+ prose = T.unlines acc+ (codeLines, rest') = fmap (drop 1) (break ((== fence) . T.strip) rest)+ segments =+ [Prose prose | not (T.null prose)]+ ++ [CodeBlock lang (T.unlines codeLines) Nothing]+ in+ segments ++ parseMarkdown' [] rest'++fence :: Text+fence = "```"++fenceCodeSegment :: Text -> Text -> Text+fenceCodeSegment lang output = "\n" <> fence <> lang <> "\n" <> output <> fence <> "\n"++reassemble :: [Segment] -> Text+reassemble = T.concat . map renderSegment++renderSegment :: Segment -> Text+renderSegment (Prose t) = t+renderSegment (CodeBlock lang code Nothing) = fenceCodeSegment lang code+renderSegment (CodeBlock lang code (Just output)) =+ if T.null (T.strip output)+ then fenceCodeSegment lang code+ else fenceCodeSegment lang code <> blockQuote output++blockQuote :: Text -> Text+blockQuote t =+ let+ ls = T.lines t+ trimmed = reverse $ dropWhile T.null $ reverse ls+ quoted = T.unlines $ map (\l -> if T.null l then ">" else "> " <> l) trimmed+ in+ quoted <> "\n"
+ src/ScriptHs/Notebook.hs view
@@ -0,0 +1,90 @@+module ScriptHs.Notebook where++import Data.Bifunctor (Bifunctor (second))+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as TIO++import ScriptHs.Markdown (Segment (..), parseMarkdown, reassemble)+import ScriptHs.Parser (+ CabalMeta (..),+ Line (..),+ ScriptFile (..),+ mergeMetas,+ parseScript,+ )+import ScriptHs.Run (runScriptCapture)++type IndexedSegments = [(Int, Segment)]+type IndexedBlocks = [(Int, [Line])]++runNotebook :: FilePath -> Maybe FilePath -> IO ()+runNotebook path outputPath = do+ contents <- TIO.readFile path+ outputMd <- processNotebook contents+ case outputPath of+ Nothing -> TIO.putStr outputMd+ Just output -> TIO.writeFile output outputMd++processNotebook :: Text -> IO Text+processNotebook contents = do+ let indexedSegments = zip [0 ..] (parseMarkdown contents)+ (metas, indexedCodeBlocks) = parseBlocks indexedSegments+ if null indexedCodeBlocks+ then pure contents+ else executeCodeCells metas indexedSegments indexedCodeBlocks++executeCodeCells :: CabalMeta -> IndexedSegments -> IndexedBlocks -> IO Text+executeCodeCells meta allSegments codeBlocks = do+ let ghciScript = generatedMarkedScript codeBlocks+ sf = ScriptFile{scriptMeta = meta, scriptLines = ghciScript}+ rawOutput <- runScriptCapture sf+ let outputs = splitByMarkers rawOutput (map fst codeBlocks)+ blocksWithOutput = addOutputToSegments outputs allSegments+ pure $ reassemble blocksWithOutput++addOutputToSegments :: [(Int, Text)] -> IndexedSegments -> [Segment]+addOutputToSegments outputs = map addOutput+ where+ addOutput :: (Int, Segment) -> Segment+ addOutput (i, CodeBlock lang code _) = CodeBlock lang code (lookup i outputs)+ addOutput (_, seg) = seg++mkIndexedCodeSegments :: IndexedSegments -> IndexedSegments+mkIndexedCodeSegments segments = [(i, c) | (i, c@(CodeBlock lang _ _)) <- segments, isHaskell lang]++parseBlocks :: IndexedSegments -> (CabalMeta, IndexedBlocks)+parseBlocks blocks = (metas, map (second scriptLines) sfs)+ where+ sfs =+ [(i, parseScript code) | (i, CodeBlock lang code _) <- blocks, isHaskell lang]+ metas = mergeMetas (map (scriptMeta . snd) sfs)++generatedMarkedScript :: IndexedBlocks -> [Line]+generatedMarkedScript = concatMap renderWithMarker+ where+ renderWithMarker :: (Int, [Line]) -> [Line]+ renderWithMarker (idx, ls) =+ ls+ ++ [ Blank+ , HaskellLine ("putStrLn " <> T.pack (show (T.unpack (mkMarker idx))))+ , Blank+ ]++splitByMarkers :: Text -> [Int] -> [(Int, Text)]+splitByMarkers _ [] = []+splitByMarkers remaining (idx : rest) =+ let marker = mkMarker 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++-- 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---"++isHaskell :: Text -> Bool+isHaskell lang = T.toLower (T.strip lang) `elem` ["haskell", "hs"]
+ src/ScriptHs/Parser.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Parsing for @.ghci@ scripts understood by ScriptHs.++A script is a sequence of lines, optionally preceded by cabal metadata+directives that declare dependencies, language extensions, and GHC options.++Example script:++@+-- cabal: build-depends: containers+-- cabal: default-extensions: OverloadedStrings+import qualified Data.Map as M++M.fromList (zip [1..10] [2,4..])+@+-}+module ScriptHs.Parser (+ ScriptFile (..),+ CabalMeta (..),+ Line (..),+ parseScript,+ mergeMetas,+) where++import Data.Text (Text)+import qualified Data.Text as T++{- | 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.+ , scriptLines :: [Line]+ -- ^ The code lines of the script, in order, with metadata lines removed.+ }+ deriving (Show, Eq)++{- | Cabal metadata extracted from @-- cabal:@ directives.++Multiple directives of the same kind are merged:++@+-- cabal: build-depends: text+-- cabal: build-depends: containers+@++produces @CabalMeta { metaDeps = [\"text\", \"containers\"], ... }@.+-}+data CabalMeta = CabalMeta+ { metaDeps :: [Text]+ -- ^ Packages from @build-depends@ directives.+ , metaExts :: [Text]+ -- ^ Extensions from @default-extensions@ directives.+ , metaGhcOptions :: [Text]+ -- ^ Flags from @ghc-options@ directives.+ }+ deriving (Show, Eq)++-- | A single logical line from the script body.+data Line+ = -- | An empty or whitespace-only line.+ Blank+ | -- | A GHCi directive, e.g. @:set -XOverloadedStrings@ or a @:{@ \/ @:}@ block.+ GhciCommand Text+ | -- | A GHC language pragma, e.g. @{\-# LANGUAGE OverloadedStrings #-\}@.+ Pragma Text+ | -- | A Haskell import declaration, e.g. @import Data.Text (Text)@.+ Import Text+ | -- | Any other Haskell source line.+ HaskellLine Text+ deriving (Show, Eq)++{- | Parse a ScriptHs script from 'Text'.++Returns a 'ScriptFile' on success, or a human-readable error message on+failure.++Example:++>>> parseScript "-- cabal: build-depends: text\nimport Data.Text (Text)\n"+Right (ScriptFile {scriptMeta = CabalMeta {metaDeps = ["text"], metaExts = [], metaGhcOptions = []}, scriptLines = [Import "import Data.Text (Text)"]})++>>> parseScript ""+Right (ScriptFile {scriptMeta = CabalMeta {metaDeps = [], metaExts = [], metaGhcOptions = []}, 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}++data RawLine+ = RawCabalMeta CabalMeta+ | 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+ { metaDeps = concatMap metaDeps ms+ , metaExts = concatMap metaExts ms+ , metaGhcOptions = concatMap metaGhcOptions ms+ }++parseLine :: Text -> RawLine+parseLine line+ | Just meta <- parseCabalMeta line = RawCabalMeta meta+ | otherwise = RawCode (parseCodeLine line)++parseCabalMeta :: Text -> Maybe CabalMeta+parseCabalMeta line = do+ rest <- T.stripPrefix "-- cabal:" line+ let rest' = T.stripStart rest+ case T.break (== ':') rest' of+ (key, colonAndValue) | not (T.null colonAndValue) -> do+ let value = T.stripStart (T.drop 1 colonAndValue)+ items = map T.strip (T.splitOn "," value)+ pure $ case T.strip key of+ "build-depends" -> emptyCabal{metaDeps = items}+ "default-extensions" -> emptyCabal{metaExts = items}+ "ghc-options" -> emptyCabal{metaGhcOptions = items}+ _ -> emptyCabal+ _ -> Nothing+ where+ emptyCabal = CabalMeta{metaDeps = [], metaExts = [], metaGhcOptions = []}++parseCodeLine :: Text -> Line+parseCodeLine line+ | isBlankLine line = Blank+ | Just cmd <- parseGhciCommand line = GhciCommand cmd+ | Just pragma <- parsePragma line = Pragma pragma+ | Just imp <- parseImport line = Import imp+ | otherwise = HaskellLine (rewriteSplice line)++isBlankLine :: Text -> Bool+isBlankLine = T.null . T.strip++parseGhciCommand :: Text -> Maybe Text+parseGhciCommand line =+ let stripped = T.stripStart line+ in case T.uncons stripped of+ Just (':', rest) -> Just (":" <> rest)+ _ -> Nothing++parsePragma :: Text -> Maybe Text+parsePragma line =+ if "{-#" `T.isPrefixOf` line+ then Just line+ else Nothing++parseImport :: Text -> Maybe Text+parseImport line =+ case T.stripPrefix "import" line of+ Just rest+ | not (T.null rest) && (T.head rest == ' ' || T.head rest == '\t') ->+ Just line+ _ -> Nothing++-- https://discourse.haskell.org/t/injecting-variables-into-a-ghci-session/12558/2?u=mchav+rewriteSplice :: Text -> Text+rewriteSplice line =+ case T.stripPrefix "$(" line >>= T.stripSuffix ")" of+ Just inner -> "_ = (); " <> T.strip inner+ Nothing -> line
+ src/ScriptHs/Render.hs view
@@ -0,0 +1,130 @@+{- | Rendering 'ScriptHs.Parser.Line' sequences into GHCi-compatible scripts.++GHCi imposes constraints that raw Haskell source does not: multi-line+definitions must be wrapped in @:{@ \/ @:}@ blocks, and monadic binds+(@<-@) or Template Haskell splices (@$(@) must be issued as individual+statements rather than grouped with pure definitions. 'toGhciScript'+handles all of this automatically+-}+module ScriptHs.Render (+ toGhciScript,+) where++import Data.Text (Text)+import qualified Data.Text as T+import ScriptHs.Parser (Line (..))++data Block+ = SingleLine Line+ | MultiLine [Line]+ deriving (Show, Eq)++{- | Render a list of 'Line's as a GHCi script.++Lines are grouped into blocks and wrapped in @:{@ \/ @:}@ where necessary.+Monadic bind expressions (@<-@) and Template Haskell splices (@$(@) are+always emitted as individual GHCi statements, since GHCi does not allow+them inside multi-line blocks.++Example — a multi-line definition is wrapped in a single block:++@+toGhciScript+ [ HaskellLine "double :: Int -> Int"+ , HaskellLine "double = (*2)"+ ]+-- :{+-- double :: Int -> Int+-- double = (*2)+-- :}+@++Example — an IO bind is kept as a standalone statement:++@+toGhciScript+ [ HaskellLine "x <- getLine"+ , HaskellLine "putStrLn x"+ ]+-- x <- getLine+-- putStrLn x+@+-}+toGhciScript :: [Line] -> Text+toGhciScript = T.unlines . concatMap renderBlock . groupBlocks++groupBlocks :: [Line] -> [Block]+groupBlocks = concatMap splitIOBinds . groupRaw++groupRaw :: [Line] -> [Block]+groupRaw [] = []+groupRaw (Blank : rest) = SingleLine Blank : groupRaw rest+groupRaw (GhciCommand t : rest) = SingleLine (GhciCommand t) : groupRaw rest+groupRaw ls =+ let (block, rest) = span isBlockLine ls+ (block', rest') = takeIfIndented block rest+ in classifyBlock block' : groupRaw rest'++takeIfIndented :: [Line] -> [Line] -> ([Line], [Line])+takeIfIndented block rest = (block ++ takeWhile isIndented rest, dropWhile isIndented rest)++isIndented :: Line -> Bool+isIndented Blank = True+isIndented (HaskellLine t) = T.isPrefixOf " " t || T.isPrefixOf "\t" t+isIndented _ = False++splitIOBinds :: Block -> [Block]+splitIOBinds (MultiLine ls) = map classifyBlock (splitOn isIOLine ls)+ where+ isIOLine l = isIOorTH (lineText l)+splitIOBinds b = [b]++splitOn :: (a -> Bool) -> [a] -> [[a]]+splitOn _ [] = []+splitOn p (x : xs)+ | p x = [x] : splitOn p xs+ | otherwise =+ let (run, rest) = break p xs+ in (x : run) : splitOn p rest++isBlockLine :: Line -> Bool+isBlockLine Blank = False+isBlockLine (GhciCommand _) = False+isBlockLine _ = True++classifyBlock :: [Line] -> Block+classifyBlock [l] = SingleLine l+classifyBlock ls = MultiLine ls++renderBlock :: Block -> [Text]+renderBlock (SingleLine Blank) = [""]+renderBlock (SingleLine (GhciCommand t)) = [t]+renderBlock (SingleLine (Pragma t)) = [t]+renderBlock (SingleLine (Import t)) = [t]+renderBlock (SingleLine (HaskellLine t))+ | isIOorTH t = wrapMulti [t]+ | otherwise = [t]+renderBlock (MultiLine ls)+ | allIOorTH ls = concatMap (\l -> wrapMulti [lineText l]) ls+ | otherwise = wrapMulti (map lineText ls)++wrapMulti :: [Text] -> [Text]+wrapMulti ls = [":{"] ++ ls ++ [":}"]++lineText :: Line -> Text+lineText Blank = ""+lineText (GhciCommand t) = t+lineText (Pragma t) = t+lineText (Import t) = t+lineText (HaskellLine t) = t++isIOorTH :: Text -> Bool+isIOorTH t =+ not (T.isPrefixOf " " t)+ && ( T.isInfixOf "<-" t+ || T.isInfixOf "$(" t+ || T.isPrefixOf "_ = ();" (T.stripStart t)+ )++allIOorTH :: [Line] -> Bool+allIOorTH = all (isIOorTH . lineText)
+ src/ScriptHs/Run.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE NamedFieldPuns #-}++module ScriptHs.Run where++import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import ScriptHs.Parser (+ CabalMeta (..),+ ScriptFile (scriptLines, scriptMeta),+ )+import ScriptHs.Render (toGhciScript)+import System.Exit (ExitCode (..), exitWith)+import System.FilePath ((</>))+import System.IO (stderr)+import System.IO.Temp (withSystemTempDirectory)+import System.Process (+ CreateProcess (delegate_ctlc),+ createProcess,+ proc,+ readProcessWithExitCode,+ waitForProcess,+ )++runScript :: ScriptFile -> IO ()+runScript = runWithCont runGhc++runScriptCapture :: ScriptFile -> IO T.Text+runScriptCapture = runWithCont captureGhc++runWithCont :: (FilePath -> CabalMeta -> FilePath -> IO a) -> ScriptFile -> IO a+runWithCont cont sf = withSystemTempDirectory "scripths" $ \tmpDir -> do+ (ghciPath, envPath) <- createScriptAndEnvironment sf tmpDir+ cont envPath (scriptMeta sf) ghciPath++createScriptAndEnvironment :: ScriptFile -> FilePath -> IO (FilePath, FilePath)+createScriptAndEnvironment sf tmpDir = do+ let ghciPath = tmpDir </> "script.ghci"+ envPath = tmpDir </> ".ghc.environment"+ sm = scriptMeta sf+ TIO.writeFile ghciPath (toGhciScript (scriptLines sf))+ resolveDeps envPath (metaDeps sm <> ["base"])+ pure (ghciPath, envPath)++captureGhc :: FilePath -> CabalMeta -> FilePath -> IO T.Text+captureGhc env meta ghciPath = do+ let args = ghcArgs env meta ghciPath+ (code, out, err) <- readProcessWithExitCode "ghc" args ""+ case code of+ ExitSuccess -> pure (T.pack $ out <> err)+ ExitFailure _ -> do+ TIO.hPutStrLn stderr (T.pack err)+ exitWith code++runGhc :: FilePath -> CabalMeta -> FilePath -> IO ()+runGhc env meta ghciPath = do+ let args = ghcArgs env meta ghciPath+ cp = (proc "ghc" args){delegate_ctlc = True}+ (_, _, _, ph) <- createProcess cp+ code <- waitForProcess ph+ case code of+ ExitSuccess -> pure ()+ ExitFailure _ -> exitWith code++ghcArgs :: FilePath -> CabalMeta -> FilePath -> [String]+ghcArgs env CabalMeta{metaExts, metaGhcOptions} ghciPath =+ let envFlags = ["-package-env=" ++ env]+ extFlags = map (\e -> "-X" ++ T.unpack e) metaExts+ optFlags = map T.unpack metaGhcOptions+ scriptArg = ":script " ++ ghciPath+ in envFlags ++ extFlags ++ optFlags ++ ["-e", scriptArg]++resolveDeps :: FilePath -> [T.Text] -> IO ()+resolveDeps _ [] = pure ()+resolveDeps envPath deps = do+ let args =+ ["-v0", "install", "--lib", "--package-env=" ++ envPath, "--force-reinstalls"]+ ++ map T.unpack deps+ cp = (proc "cabal" args){delegate_ctlc = True}+ (_, _, _, ph) <- createProcess cp+ code <- waitForProcess ph+ case code of+ ExitSuccess -> pure ()+ ExitFailure n -> do+ TIO.hPutStrLn+ stderr+ (T.pack ("scripths: cabal install --lib failed (exit " ++ show n ++ ")"))+ exitWith code
+ test/Main.hs view
@@ -0,0 +1,19 @@+module Main (main) where++import Test.Tasty (defaultMain, testGroup)++import Test.Markdown (markdownTests)+import Test.Notebook (notebookTests)+import Test.Parser (parseTests)+import Test.Render (renderTests)++main :: IO ()+main =+ defaultMain $+ testGroup+ "ScriptHs"+ [ parseTests+ , renderTests+ , markdownTests+ , notebookTests+ ]
+ test/Test/Markdown.hs view
@@ -0,0 +1,195 @@+module Test.Markdown (markdownTests) where++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (+ assertBool,+ assertFailure,+ testCase,+ (@?=),+ )++import Data.Text (Text)+import qualified Data.Text as T+import ScriptHs.Markdown (+ Segment (CodeBlock, Prose),+ parseMarkdown,+ reassemble,+ )++markdownTests :: TestTree+markdownTests =+ testGroup+ "Markdown"+ [ testGroup+ "parseMarkdown"+ [ testCase "prose only" $ do+ let segs = parseMarkdown "Hello world\nSecond line\n"+ length segs @?= 1+ case segs of+ [Prose _] -> pure ()+ other -> assertFailure $ "expected [Prose], got: " ++ show other+ , testCase "single code block" $ do+ let input =+ T.unlines+ [ "```haskell"+ , "print 42"+ , "```"+ ]+ let segs = parseMarkdown input+ length segs @?= 1+ case segs of+ [CodeBlock lang code Nothing] -> do+ lang @?= "haskell"+ assertBool "has print 42" (T.isInfixOf "print 42" code)+ other -> assertFailure $ "expected [CodeBlock], got: " ++ show other+ , testCase "prose then code" $ do+ let input =+ T.unlines+ [ "# Title"+ , ""+ , "Some text."+ , ""+ , "```haskell"+ , "print 42"+ , "```"+ ]+ let segs = parseMarkdown input+ length segs @?= 2+ case segs of+ [Prose _, CodeBlock "haskell" _ _] -> pure ()+ other -> assertFailure $ "expected [Prose, CodeBlock], got: " ++ show other+ , testCase "code then prose" $ do+ let input =+ T.unlines+ [ "```haskell"+ , "print 42"+ , "```"+ , ""+ , "Some text after."+ ]+ let segs = parseMarkdown input+ length segs @?= 2+ case segs of+ [CodeBlock{}, Prose _] -> pure ()+ other -> assertFailure $ "expected [CodeBlock, Prose], got: " ++ show other+ , testCase "multiple code blocks" $ do+ let input =+ T.unlines+ [ "# Title"+ , ""+ , "```haskell"+ , "print 1"+ , "```"+ , ""+ , "Middle text."+ , ""+ , "```haskell"+ , "print 2"+ , "```"+ ]+ let segs = parseMarkdown input+ let codeBlocks = [c | c@(CodeBlock{}) <- segs]+ length codeBlocks @?= 2+ , testCase "non-haskell code block preserved" $ do+ let input =+ T.unlines+ [ "```python"+ , "print('hello')"+ , "```"+ ]+ let segs = parseMarkdown input+ case segs of+ [CodeBlock "python" code Nothing] ->+ assertBool "has python code" (T.isInfixOf "print('hello')" code)+ other -> assertFailure $ "expected [CodeBlock python], got: " ++ show other+ , testCase "empty code block" $ do+ let input =+ T.unlines+ [ "```haskell"+ , "```"+ ]+ let segs = parseMarkdown input+ case segs of+ [CodeBlock "haskell" code _] ->+ assertBool "empty or whitespace" (T.null (T.strip code))+ other -> assertFailure $ "expected [CodeBlock], got: " ++ show other+ , testCase "multi-line code block" $ do+ let input =+ T.unlines+ [ "```haskell"+ , "import Data.Text"+ , ""+ , "x <- getLine"+ , "print x"+ , "```"+ ]+ let segs = parseMarkdown input+ case segs of+ [CodeBlock "haskell" code _] -> do+ assertBool "has import" (T.isInfixOf "import Data.Text" code)+ assertBool "has x <- getLine" (T.isInfixOf "x <- getLine" code)+ assertBool "has print x" (T.isInfixOf "print x" code)+ other -> assertFailure $ "expected [CodeBlock], got: " ++ show other+ ]+ , testGroup+ "reassemble"+ [ testCase "prose without output" $ do+ let result = reassemble [Prose "Hello\n"]+ result @?= "Hello\n"+ , testCase "code block without output" $ do+ let result = reassemble [CodeBlock "haskell" "print 42\n" Nothing]+ assertBool "has fence" (T.isInfixOf "```haskell" result)+ assertBool "has code" (T.isInfixOf "print 42" result)+ assertBool "no blockquote" (not $ T.isInfixOf "> " result)+ , testCase "code block with output" $ do+ let result = reassemble [CodeBlock "haskell" "print 42\n" (Just "42")]+ assertBool "has fence" (T.isInfixOf "```haskell" result)+ assertBool "has code" (T.isInfixOf "print 42" result)+ assertBool "has blockquote" (T.isInfixOf "> 42" result)+ , testCase "code block with multi-line output" $ do+ let result = reassemble [CodeBlock "hs" "print [1,2]\n" (Just "1\n2")]+ assertBool "has > 1" (T.isInfixOf "> 1" result)+ assertBool "has > 2" (T.isInfixOf "> 2" result)+ , testCase "empty output is omitted" $ do+ let result = reassemble [CodeBlock "haskell" "import X\n" (Just "")]+ assertBool "no blockquote" (not $ T.isInfixOf "> " result)+ , testCase "whitespace-only output is omitted" $ do+ let result = reassemble [CodeBlock "haskell" "import X\n" (Just " \n \n")]+ assertBool "no blockquote" (not $ T.isInfixOf "> " result)+ , testCase "full document roundtrip" $ do+ let segs =+ [ Prose "# Title\n\n"+ , CodeBlock "haskell" "print 42\n" (Just "42")+ , Prose "\nSome text.\n"+ , CodeBlock "haskell" "print 99\n" (Just "99")+ ]+ let result = reassemble segs++ assertBool "has title" (T.isInfixOf "# Title" result)+ assertBool "has first output" (T.isInfixOf "> 42" result)+ assertBool "has middle text" (T.isInfixOf "Some text." result)+ assertBool "has second output" (T.isInfixOf "> 99" result)++ let titleIdx = indexOf "# Title" result+ code1Idx = indexOf "print 42" result+ middleIdx = indexOf "Some text." result+ code2Idx = indexOf "print 99" result+ assertBool "title before code1" (titleIdx < code1Idx)+ assertBool "code1 before middle" (code1Idx < middleIdx)+ assertBool "middle before code2" (middleIdx < code2Idx)+ ]+ , testGroup+ "blockquote"+ [ testCase "single line" $ do+ let result = reassemble [CodeBlock "hs" "x\n" (Just "hello")]+ assertBool "blockquoted" (T.isInfixOf "> hello" result)+ , testCase "empty lines in output get bare >" $ do+ let result = reassemble [CodeBlock "hs" "x\n" (Just "a\n\nb")]+ assertBool "has bare >" (T.isInfixOf "\n>\n" result)+ ]+ ]++indexOf :: Text -> Text -> Int+indexOf needle haystack =+ let (before, _) = T.breakOn needle haystack+ in T.length before
+ test/Test/Notebook.hs view
@@ -0,0 +1,203 @@+module Test.Notebook (notebookTests) where++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++import qualified Data.Text as T++import ScriptHs.Markdown (Segment (..))+import ScriptHs.Notebook (+ addOutputToSegments,+ generatedMarkedScript,+ isHaskell,+ mkIndexedCodeSegments,+ mkMarker,+ parseBlocks,+ processNotebook,+ splitByMarkers,+ )++import ScriptHs.Parser (CabalMeta (metaDeps), Line (..))++notebookTests :: TestTree+notebookTests =+ testGroup+ "Notebook"+ [ testGroup+ "isHaskell"+ [ testCase "accepts haskell" $ do+ isHaskell "haskell" @?= True+ , testCase "accepts hs" $ do+ isHaskell "hs" @?= True+ , testCase "case-insensitive + trims" $ do+ isHaskell " HaSkElL " @?= True+ isHaskell "\tHS\n" @?= True+ , testCase "rejects other languages" $ do+ isHaskell "python" @?= False+ isHaskell "" @?= False+ isHaskell "hask" @?= False+ ]+ , testGroup+ "mkMarker"+ [ testCase "format includes index" $ do+ mkMarker 0 @?= "---SCRIPTHS_BLOCK_0_END---"+ mkMarker 12 @?= "---SCRIPTHS_BLOCK_12_END---"+ ]+ , testGroup+ "splitByMarkers"+ [ testCase "empty marker list => []" $ do+ splitByMarkers "anything" [] @?= []+ , testCase "marker not found => strip remaining as output for that idx" $ do+ let out = " hello world \n"+ splitByMarkers 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")]+ , testCase "multiple markers split sequentially" $ do+ let out =+ T.concat+ [ "cell0\n"+ , mkMarker 0+ , "\ncell1\n"+ , mkMarker 1+ , "\ncell2\n"+ , mkMarker 2+ , "\n"+ ]+ splitByMarkers out [0, 1, 2]+ @?= [ (0, "cell0")+ , (1, "cell1")+ , (2, "cell2")+ ]+ , testCase "later marker missing => remainder becomes that cell output" $ do+ let out =+ T.concat+ [ "cell0\n"+ , mkMarker 0+ , "\ncell1-no-marker-at-end\n"+ ]+ splitByMarkers out [0, 1]+ @?= [ (0, "cell0")+ , (1, "cell1-no-marker-at-end")+ ]+ ]+ , testGroup+ "mkIndexedCodeSegments"+ [ testCase "filters only haskell/hs code blocks" $ do+ let segs =+ [ (0, Prose "intro\n")+ , (1, CodeBlock "haskell" "print 1\n" Nothing)+ , (2, CodeBlock "python" "print('x')\n" Nothing)+ , (3, CodeBlock "HS" "print 2\n" Nothing)+ , (4, Prose "outro\n")+ ]+ let hsSegs = mkIndexedCodeSegments segs+ map fst hsSegs @?= [1, 3]+ case map snd hsSegs of+ [CodeBlock "haskell" _ _, CodeBlock "HS" _ _] -> pure ()+ other -> assertFailure $ "unexpected segments: " ++ show other+ ]+ , testGroup+ "addOutputToSegments"+ [ testCase "adds outputs to matching code blocks and leaves others alone" $ do+ let outputs =+ [ (1, "out-1")+ , (3, "out-3")+ , (999, "unused")+ ]++ let indexedSegs =+ [ (0, Prose "intro\n")+ , (1, CodeBlock "haskell" "print 1\n" Nothing)+ , (2, CodeBlock "python" "print('x')\n" Nothing)+ , (3, CodeBlock "hs" "print 3\n" (Just "old-should-be-replaced"))+ , (4, Prose "outro\n")+ ]++ let result = addOutputToSegments outputs indexedSegs++ length result @?= length indexedSegs++ head result @?= Prose "intro\n"+ result !! 4 @?= Prose "outro\n"++ result !! 1 @?= CodeBlock "haskell" "print 1\n" (Just "out-1")+ result !! 3 @?= CodeBlock "hs" "print 3\n" (Just "out-3")++ result !! 2 @?= CodeBlock "python" "print('x')\n" Nothing+ ]+ , testGroup+ "generatedMarkedScript"+ [ testCase "inserts marker print after each block" $ do+ let blocks =+ [ (10, [HaskellLine "print 10"])+ , (11, [HaskellLine "print 11"])+ ]+ let ls = generatedMarkedScript 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++ assertBool+ "has putStrLn marker 10"+ (HaskellLine ("putStrLn " <> T.pack (show (T.unpack m10))) `elem` ls)++ assertBool+ "has putStrLn marker 11"+ (HaskellLine ("putStrLn " <> T.pack (show (T.unpack m11))) `elem` ls)++ assertBool "has Blank separators" (Blank `elem` ls)+ ]+ , testGroup+ "parseBlocks"+ [ testCase "extracts only haskell blocks and preserves indices" $ do+ let segs =+ [ (0, Prose "intro\n")+ , (1, CodeBlock "python" "print('x')\n" Nothing)+ , (2, CodeBlock "haskell" "print 42\n" Nothing)+ , (3, CodeBlock "hs" "print 99\n" Nothing)+ , (4, Prose "outro\n")+ ]++ let (_meta, indexedBlocks) = parseBlocks segs+ map fst indexedBlocks @?= [2, 3]++ case indexedBlocks of+ [(2, ls2), (3, ls3)] -> do+ assertBool "block 2 non-empty lines" (not (null ls2))+ assertBool "block 3 non-empty lines" (not (null ls3))+ other -> assertFailure $ "unexpected indexedBlocks: " ++ show other+ , testCase "no haskell blocks => empty indexedBlocks and empty-ish meta" $ do+ let segs =+ [ (0, Prose "intro\n")+ , (1, CodeBlock "python" "print('x')\n" Nothing)+ , (2, Prose "outro\n")+ ]+ let (meta, indexedBlocks) = parseBlocks segs+ indexedBlocks @?= []+ metaDeps meta @?= []+ ]+ , testGroup+ "processNotebook"+ [ testCase "no code blocks => returns input unchanged" $ do+ let input = T.unlines ["# Title", "", "Just prose.", ""]+ out <- processNotebook input+ out @?= input+ , testCase "non-haskell code blocks only => returns input unchanged" $ do+ let input =+ T.unlines+ [ "# Title"+ , ""+ , "```python"+ , "print('hello')"+ , "```"+ , ""+ , "more prose"+ ]+ out <- processNotebook input+ out @?= input+ ]+ ]
+ test/Test/Parser.hs view
@@ -0,0 +1,159 @@+module Test.Parser (parseTests) where++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (+ assertBool,+ assertFailure,+ testCase,+ (@?=),+ )++import qualified Data.Text as T+import ScriptHs.Parser (+ CabalMeta (metaDeps, metaExts, metaGhcOptions),+ Line (..),+ ScriptFile (scriptLines, scriptMeta),+ parseScript,+ )++parseTests :: TestTree+parseTests =+ testGroup+ "Parse"+ [ testGroup+ "Line classification"+ [ testCase "blank line" $ do+ let sf = parseScript "\n"+ scriptLines sf @?= [Blank]+ , testCase "import" $ do+ let sf = parseScript "import Data.Text (Text)\n"+ case scriptLines sf of+ [Import t] -> assertBool "import text" (T.isPrefixOf "import " t)+ other -> assertFailure $ "expected Import, got: " ++ show other+ , testCase "qualified import" $ do+ let sf = parseScript "import qualified Data.Map as Map\n"+ case scriptLines sf of+ [Import t] -> assertBool "qualified" (T.isInfixOf "qualified" t)+ other -> assertFailure $ "expected Import, got: " ++ show other+ , testCase "ghci command :set" $ do+ let sf = parseScript ":set -XOverloadedStrings\n"+ case scriptLines sf of+ [GhciCommand t] -> t @?= ":set -XOverloadedStrings"+ other -> assertFailure $ "expected GhciCommand, got: " ++ show other+ , testCase "ghci command :def!" $ do+ let sf = parseScript ":def! declareColumns \\s -> return s\n"+ case scriptLines sf of+ [GhciCommand t] -> assertBool ":def!" (T.isPrefixOf ":def!" t)+ other -> assertFailure $ "expected GhciCommand, got: " ++ show other+ , testCase "pragma" $ do+ let sf = parseScript "{-# LANGUAGE TemplateHaskell #-}\n"+ case scriptLines sf of+ [Pragma t] -> assertBool "pragma" (T.isPrefixOf "{-#" t)+ other -> assertFailure $ "expected Pragma, got: " ++ show other+ , testCase "haskell line" $ do+ let sf = parseScript "print (5 + 5)\n"+ case scriptLines sf of+ [HaskellLine t] -> t @?= "print (5 + 5)"+ other -> assertFailure $ "expected HaskellLine, got: " ++ show other+ , testCase "IO bind line" $ do+ let sf = parseScript "x <- getLine\n"+ case scriptLines sf of+ [HaskellLine t] -> assertBool "has <-" (T.isInfixOf "<-" t)+ other -> assertFailure $ "expected HaskellLine, got: " ++ show other+ , testCase "TH splice line" $ do+ let sf = parseScript "$(declareColumns iris)\n"+ case scriptLines sf of+ [HaskellLine t] -> assertBool "has $(" (T.isPrefixOf "_ = ();" t)+ other -> assertFailure $ "expected HaskellLine, got: " ++ show other+ ]+ , testGroup+ "Cabal metadata"+ [ testCase "build-depends" $ do+ let sf = parseScript "-- cabal: build-depends: base, text, containers\n"+ (metaDeps . scriptMeta) sf @?= ["base", "text", "containers"]+ , testCase "default-extensions" $ do+ let sf =+ parseScript "-- cabal: default-extensions: TemplateHaskell, TypeApplications\n"+ (metaExts . scriptMeta) sf @?= ["TemplateHaskell", "TypeApplications"]+ , testCase "ghc-options" $ do+ let sf = parseScript "-- cabal: ghc-options: -threaded, -O2\n"+ (metaGhcOptions . scriptMeta) sf @?= ["-threaded", "-O2"]+ , testCase "metadata stripped from lines" $ do+ let input =+ T.unlines+ [ "-- cabal: build-depends: base"+ , "import Data.Text"+ ]+ let sf = parseScript input+ (length . scriptLines) sf @?= 1+ case scriptLines sf of+ [Import _] -> pure ()+ other -> assertFailure $ "expected [Import], got: " ++ show other+ , testCase "multiple metadata lines merge" $ do+ let input =+ T.unlines+ [ "-- cabal: build-depends: base, text"+ , "-- cabal: build-depends: containers"+ , "-- cabal: default-extensions: GADTs"+ ]+ let sf = parseScript input+ (metaDeps . scriptMeta) sf @?= ["base", "text", "containers"]+ (metaExts . scriptMeta) sf @?= ["GADTs"]+ , testCase "unknown cabal key is ignored" $ do+ let sf = parseScript "-- cabal: foo: bar, baz\n"+ (metaDeps . scriptMeta) sf @?= []+ (metaExts . scriptMeta) sf @?= []+ ]+ , testGroup+ "Multi-line scripts"+ [ testCase "interleaved imports and expressions" $ do+ let input =+ T.unlines+ [ "import Data.Text (Text)"+ , ""+ , "x <- getLine"+ , ""+ , "import Data.Map (Map)"+ , ""+ , "print x"+ ]+ let sf = parseScript input+ let ls = scriptLines sf+ length ls @?= 7 -- 3 code + 4 blanks (trailing newline)+ case filter notBlank ls of+ [Import _, HaskellLine _, Import _, HaskellLine _] -> pure ()+ other -> assertFailure $ "unexpected structure: " ++ show other+ , testCase "empty input" $ do+ let sf = parseScript ""+ scriptLines sf @?= []+ metaDeps (scriptMeta sf) @?= []+ , testCase "no trailing newline" $ do+ let sf = parseScript "print 42"+ case scriptLines sf of+ [HaskellLine t] -> t @?= "print 42"+ other -> assertFailure $ "expected HaskellLine, got: " ++ show other+ ]+ , testGroup+ "Edge cases"+ [ testCase "comment that looks like cabal but isn't" $ do+ let sf = parseScript "-- cabal is great\n"++ case scriptLines sf of+ [HaskellLine _] -> pure ()+ other -> assertFailure $ "expected HaskellLine, got: " ++ show other+ , testCase "regular comment" $ do+ let sf = parseScript "-- this is a comment\n"+ case scriptLines sf of+ [HaskellLine t] -> assertBool "comment" (T.isPrefixOf "--" t)+ other -> assertFailure $ "expected HaskellLine, got: " ++ show other+ , testCase "indented import is haskell line" $ do+ let sf = parseScript " import Data.Text\n"+ case scriptLines sf of+ [HaskellLine _] -> pure ()+ other -> assertFailure $ "expected HaskellLine, got: " ++ show other+ ]+ ]++notBlank :: Line -> Bool+notBlank Blank = False+notBlank _ = True
+ test/Test/Render.hs view
@@ -0,0 +1,155 @@+module Test.Render (renderTests) where++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, assertBool, testCase, (@?=))++import Data.Text (Text)+import qualified Data.Text as T+import ScriptHs.Parser (Line (..))+import ScriptHs.Render (toGhciScript)++renderTests :: TestTree+renderTests =+ testGroup+ "Render"+ [ testGroup+ "Single lines"+ [ testCase "plain expression stays unwrapped" $ do+ let result = toGhciScript [HaskellLine "print 42"]+ assertNotWrapped result+ , testCase "import stays unwrapped" $ do+ let result = toGhciScript [Import "import Data.Text"]+ assertNotWrapped result+ , testCase "pragma stays unwrapped" $ do+ let result = toGhciScript [Import "{-# LANGUAGE GADTs #-}"]+ assertNotWrapped result+ , testCase "ghci command stays unwrapped" $ do+ let result = toGhciScript [GhciCommand ":set -XOverloadedStrings"]+ let ls = nonEmpty result+ ls @?= [":set -XOverloadedStrings"]+ , testCase "IO bind gets wrapped" $ do+ let result = toGhciScript [HaskellLine "x <- getLine"]+ assertWrapped result ["x <- getLine"]+ , testCase "blank line preserved" $ do+ let result = toGhciScript [Blank]+ assertBool "has blank" (T.isInfixOf "\n\n" result || result == "\n")+ ]+ , testGroup+ "IO line isolation"+ [ testCase "consecutive IO binds each get own block" $ do+ let result =+ toGhciScript+ [ HaskellLine "x <- getLine"+ , HaskellLine "y <- getLine"+ ]+ let blocks = splitBlocks result+ assertBool+ ("expected 2 blocks, got " ++ show (length blocks))+ (length blocks == 2)+ , testCase "IO bind between pure code splits correctly" $ do+ let result =+ toGhciScript+ [ HaskellLine "let x = 5"+ , HaskellLine "y <- getLine"+ , HaskellLine "print y"+ ]+ let blocks = splitBlocks result+ assertBool+ ("expected 1 block, got " ++ show (length blocks) ++ ": " ++ show blocks)+ (length blocks == 1)+ ]+ , testGroup+ "Multi-line blocks"+ [ testCase "consecutive pure lines grouped" $ do+ let result =+ toGhciScript+ [ HaskellLine "let"+ , HaskellLine " x = 5"+ , HaskellLine " y = 10"+ ]+ let blocks = splitBlocks result+ length blocks @?= 1+ , testCase "consecutive do-notation lines grouped" $ do+ let result =+ toGhciScript+ [ HaskellLine "do"+ , HaskellLine " x <- pure 5"+ , HaskellLine " y <- pure 10"+ , HaskellLine " pure $ x + y"+ ]+ let blocks = splitBlocks result+ length blocks @?= 1+ , testCase "consecutive do-notation lines with space are grouped" $ do+ let result =+ toGhciScript+ [ HaskellLine "do"+ , HaskellLine " x <- pure 5"+ , -- indentation should ignore these blank lines.+ Blank+ , Blank+ , HaskellLine " y <- pure 10"+ , HaskellLine " pure $ x + y"+ ]+ let blocks = splitBlocks result+ length blocks @?= 1+ , testCase "blank separates blocks" $ do+ let result =+ toGhciScript+ [ HaskellLine "print 1"+ , Blank+ , HaskellLine "print 2"+ ]+ let ls = nonEmpty result+ assertBool "has print 1" (any (T.isInfixOf "print 1") ls)+ assertBool "has print 2" (any (T.isInfixOf "print 2") ls)+ ]+ , testGroup+ "Full script transform"+ [ testCase "typical script" $ do+ let result =+ toGhciScript+ [ Import "import qualified DataFrame as D"+ , Blank+ , HaskellLine "iris <- D.readParquet \"data/iris.parquet\""+ , Blank+ , Import "import Data.Text (Text)"+ , Blank+ , HaskellLine "print iris"+ ]+ assertBool "has import D" (T.isInfixOf "import qualified DataFrame as D" result)+ assertBool "has :{" (T.isInfixOf ":{" result)+ assertBool "has print" (T.isInfixOf "print iris" result)+ ]+ ]++splitBlocks :: Text -> [[Text]]+splitBlocks = go . T.lines+ where+ go [] = []+ go (l : ls)+ | T.strip l == ":{" =+ let (block, rest) = span (\x -> T.strip x /= ":}") ls+ rest' = drop 1 rest+ in block : go rest'+ | otherwise = go ls++nonEmpty :: Text -> [Text]+nonEmpty = filter (not . T.null . T.strip) . T.lines++assertNotWrapped :: Text -> Assertion+assertNotWrapped t =+ assertBool+ ("expected no wrapping, got: " ++ T.unpack t)+ (not (T.isInfixOf ":{" t))++assertWrapped :: Text -> [Text] -> Assertion+assertWrapped t expectedInner = do+ let blocks = splitBlocks t+ assertBool+ ("expected at least one block, got: " ++ show blocks)+ (not (null blocks))+ let innerLines = map T.strip (concat blocks)+ let expected = map T.strip expectedInner+ assertBool+ ("expected " ++ show expected ++ " in blocks, got: " ++ show innerLines)+ (all (`elem` innerLines) expected)