scripths 0.5.2.0 → 0.5.3.0
raw patch · 7 files changed
+208/−60 lines, 7 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
+ ScriptHs.Render: linePragma :: Int -> Text -> Text
+ ScriptHs.Render: numberedPieces :: [(Int, Line)] -> [(Int, Piece)]
+ ScriptHs.Render: toGhciScriptTagged :: Text -> [(Int, Line)] -> Text
+ ScriptHs.Run: scriptGhciBody :: FilePath -> [(Int, Line)] -> Text
- ScriptHs.Run: runScript :: RunOptions -> FilePath -> ScriptFile -> IO ()
+ ScriptHs.Run: runScript :: RunOptions -> FilePath -> ScriptFile -> [(Int, Line)] -> IO ()
Files
- app/Main.hs +3/−3
- scripths.cabal +1/−1
- src/ScriptHs/Compiled.hs +2/−18
- src/ScriptHs/Render.hs +69/−28
- src/ScriptHs/Run.hs +42/−10
- test/Test/Render.hs +70/−0
- test/Test/Run.hs +21/−0
app/Main.hs view
@@ -18,7 +18,7 @@ import ScriptHs.CLI.Types import ScriptHs.Markdown import ScriptHs.Notebook (runNotebook)-import ScriptHs.Parser (parseScript)+import ScriptHs.Parser (parseScriptNumbered) import ScriptHs.Run (RunOptions (..), defaultRunOptions, runScript) import ScriptHs.Version ( newerVersionWarning,@@ -80,8 +80,8 @@ ".markdown" -> runNotebook renderOpts opts path outputPath _ -> do contents <- TIO.readFile path- let sf = parseScript contents- runScript opts path sf+ let (sf, numbered) = parseScriptNumbered contents+ runScript opts path sf numbered -- | Resolve a @--package@ dir to absolute, requiring a package root (a @.cabal@). resolvePackageDir :: FilePath -> IO FilePath
scripths.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: scripths-version: 0.5.2.0+version: 0.5.3.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/
src/ScriptHs/Compiled.hs view
@@ -28,8 +28,9 @@ import ScriptHs.Render ( Kind (..), Piece (..),+ linePragma, lineText,- toPieces,+ numberedPieces, unRewriteSplice, ) @@ -79,20 +80,6 @@ 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@@ -172,9 +159,6 @@ , 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 <> " #-}"
src/ScriptHs/Render.hs view
@@ -11,6 +11,9 @@ -} module ScriptHs.Render ( toGhciScript,+ toGhciScriptTagged,+ numberedPieces,+ linePragma, -- * Module rendering (notebook → standalone Haskell) ModuleParts (..),@@ -33,6 +36,7 @@ unRewriteSplice, ) where +import Data.Bifunctor (second) import Data.Char (isAsciiLower, isAsciiUpper, isDigit) import Data.List (intercalate) import Data.Maybe@@ -64,9 +68,16 @@ toGhciScript :: [Line] -> Text toGhciScript = T.unlines . concatMap renderBlock . piecesToBlocks . toPieces ------------------------------------------------------------------- Kind and Piece----------------------------------------------------------------+{- | Like 'toGhciScript', but prefixes every @:{ … :}@ block with a+@{\-# LINE n "tag" #-\}@ pragma carrying the unit's original source line, so GHC+diagnostics (especially @-fdiagnostics-as-json@) come back cell-relative and+filed under @tag@ — regardless of any preamble the caller prepends to the+session input. Directives, imports, pragmas and blank lines stay bare: a LINE+pragma cannot attach to them at the GHCi prompt.+-}+toGhciScriptTagged :: Text -> [(Int, Line)] -> Text+toGhciScriptTagged tag =+ T.unlines . concatMap (renderBlockTagged tag) . numberedBlocks data Kind = KComment@@ -84,10 +95,6 @@ | PUnit Kind [Line] deriving (Show) ------------------------------------------------------------------- Step 1: [Line] -> [Piece]----------------------------------------------------------------- toPieces :: [Line] -> [Piece] toPieces [] = [] toPieces (Blank : rest) = PBlank : toPieces rest@@ -141,10 +148,6 @@ isBlankLine Blank = True isBlankLine _ = False ------------------------------------------------------------------- Classification----------------------------------------------------------------- classify :: Text -> [Text] -> Kind classify leadText contTexts | isTHSplice leadText = KTHSplice@@ -260,10 +263,6 @@ isCommentText :: Text -> Bool isCommentText t = "--" `T.isPrefixOf` T.stripStart t ------------------------------------------------------------------- Step 2: [Piece] -> [Block]----------------------------------------------------------------- {- | Normalize a piece stream: attach each comment unit forward onto the following non-comment unit, and merge runs of adjacent declarations into a single unit. Shared by 'toGhciScript' (block wrapping) and 'toModule'@@ -279,18 +278,45 @@ piecesToBlocks :: [Piece] -> [Block] piecesToBlocks = map pieceToBlock . mergePieces++pieceToBlock :: Piece -> Block+pieceToBlock PBlank = SingleLine Blank+pieceToBlock (PGhciCommand t) = SingleLine (GhciCommand t)+pieceToBlock (PPragma t) = SingleLine (Pragma t)+pieceToBlock (PImport t) = SingleLine (Import t)+pieceToBlock (PUnit _ [l]) = SingleLine l+pieceToBlock (PUnit _ ls) = MultiLine ls++{- | 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. Shared by the tagged GHCi renderer and the+compiled-module renderer so both file diagnostics the same way.+-}+numberedPieces :: [(Int, Line)] -> [(Int, Piece)]+numberedPieces nls = go nls (toPieces (map snd nls)) where- pieceToBlock PBlank = SingleLine Blank- pieceToBlock (PGhciCommand t) = SingleLine (GhciCommand t)- pieceToBlock (PPragma t) = SingleLine (Pragma t)- pieceToBlock (PImport t) = SingleLine (Import t)- pieceToBlock (PUnit _ [l]) = SingleLine l- pieceToBlock (PUnit _ ls) = MultiLine ls+ go _ [] = []+ go rest (p : ps) = case rest of+ ((i, _) : _) -> (i, p) : go (drop (pieceLen p) rest) ps+ [] -> []+ pieceLen (PUnit _ ls) = length ls+ pieceLen _ = 1 ------------------------------------------------------------------- Rendering----------------------------------------------------------------+{- | 'mergePieces' carrying each piece's first source line; a merge keeps the+earliest line so a tagged block points at where the unit began.+-}+mergeNumberedPieces :: [(Int, Piece)] -> [(Int, Piece)]+mergeNumberedPieces ((i, PUnit KComment l1) : (_, PUnit k l2) : rest)+ | k /= KComment = mergeNumberedPieces ((i, PUnit k (l1 ++ l2)) : rest)+mergeNumberedPieces ((i, PUnit KDeclaration l1) : (_, PUnit KDeclaration l2) : rest) =+ mergeNumberedPieces ((i, PUnit KDeclaration (l1 ++ l2)) : rest)+mergeNumberedPieces (p : rest) = p : mergeNumberedPieces rest+mergeNumberedPieces [] = [] +numberedBlocks :: [(Int, Line)] -> [(Int, Block)]+numberedBlocks =+ map (second pieceToBlock) . mergeNumberedPieces . numberedPieces+ renderBlock :: Block -> [Text] renderBlock (SingleLine Blank) = [""] renderBlock (SingleLine (GhciCommand t)) = [t]@@ -302,16 +328,31 @@ wrapMulti :: [Text] -> [Text] wrapMulti ls = [":{"] ++ ls ++ [":}"] +{- | Render a block as 'renderBlock' does, but prefix the @:{ … :}@ body with a+@{\-# LINE i "tag" #-\}@ pragma. Bare blocks (directives, imports, pragmas,+blanks) carry no pragma — it could not attach to them at the prompt.+-}+renderBlockTagged :: Text -> (Int, Block) -> [Text]+renderBlockTagged _ (_, SingleLine Blank) = [""]+renderBlockTagged _ (_, SingleLine (GhciCommand t)) = [t]+renderBlockTagged _ (_, SingleLine (Pragma t)) = [t]+renderBlockTagged _ (_, SingleLine (Import t)) = [t]+renderBlockTagged tag (i, SingleLine (HaskellLine t)) = wrapTagged tag i [t]+renderBlockTagged tag (i, MultiLine ls) = wrapTagged tag i (map lineText ls)++wrapTagged :: Text -> Int -> [Text] -> [Text]+wrapTagged tag i ls = ":{" : linePragma i tag : ls ++ [":}"]++-- | A @{\-# LINE n "tag" #-\}@ pragma routing diagnostics back to source.+linePragma :: Int -> Text -> Text+linePragma n tag = "{-# LINE " <> T.pack (show n) <> " \"" <> tag <> "\" #-}"+ lineText :: Line -> Text lineText Blank = "" lineText (GhciCommand t) = t lineText (Pragma t) = t lineText (Import t) = t lineText (HaskellLine t) = t-------------------------------------------------------------------- Module rendering: notebook cells -> standalone Haskell---------------------------------------------------------------- {- | The four buckets a sequence of notebook 'Line's sorts into when assembling a compilable module: language pragmas and imports (hoisted to the
src/ScriptHs/Run.hs view
@@ -15,6 +15,7 @@ deriveProjectName, renderCabalFile, renderCabalProject,+ scriptGhciBody, usesTemplateHaskell, ) where @@ -33,7 +34,7 @@ ScriptFile (scriptLines, scriptMeta), SourceRepoPin (..), )-import ScriptHs.Render (toGhciScript)+import ScriptHs.Render (toGhciScript, toGhciScriptTagged) import ScriptHs.Repl ( autoPrintDirective, cdDirective,@@ -77,26 +78,51 @@ defaultRunOptions :: RunOptions defaultRunOptions = RunOptions{roPackages = [], roEnclosingProject = True} -runScript :: RunOptions -> FilePath -> ScriptFile -> IO ()-runScript = runWithCont runGhc+{- | Run a @.ghci@\/@.hs@ script. Cells are rendered with @{\-# LINE #-\}@ pragmas+tagged with the script path (numbering from 'parseScriptNumbered'), so a failing+cell's diagnostics report the original file and line — GHC even renders the+source caret from it — rather than a position in the synthetic repl input.+-}+runScript :: RunOptions -> FilePath -> ScriptFile -> [(Int, Line)] -> IO ()+runScript opts scriptPath sf numbered =+ runWithCont runGhc opts scriptPath sf (scriptGhciBody scriptPath numbered) +{- | Run a script for its captured output (notebooks). The generated cell stream+carries marker statements and no user-source line mapping, so it renders untagged.+-} runScriptCapture :: RunOptions -> FilePath -> ScriptFile -> IO T.Text-runScriptCapture = runWithCont captureGhc+runScriptCapture opts scriptPath sf =+ runWithCont captureGhc opts scriptPath sf (toGhciScript (scriptLines sf)) runWithCont :: (FilePath -> FilePath -> FilePath -> IO a) -> RunOptions -> FilePath -> ScriptFile ->+ T.Text -> IO a-runWithCont cont opts scriptPath sf = do+runWithCont cont opts scriptPath sf renderedBody = do scriptAbsPath <- makeAbsolute scriptPath userCwd <- getCurrentDirectory warnUnknownKeys (metaUnknownKeys (scriptMeta sf)) projectDir <-- ensureProject opts userCwd scriptAbsPath (scriptMeta sf) (scriptLines sf)+ ensureProject+ opts+ userCwd+ scriptAbsPath+ (scriptMeta sf)+ (scriptLines sf)+ renderedBody cont userCwd projectDir (projectDir </> "script.ghci") +{- | The GHCi body for a script: every cell wrapped with a @{\-# LINE n "path" #-\}@+pragma so GHC files diagnostics against the original source file and line. The+tag is the script path as given — relative to the directory the repl runs in —+so GHC can read it back to render the source caret.+-}+scriptGhciBody :: FilePath -> [(Int, Line)] -> T.Text+scriptGhciBody scriptPath = toGhciScriptTagged (T.pack scriptPath)+ {- | 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.@@ -159,8 +185,14 @@ step h c = (h `xor` fromIntegral (ord c)) * 16777619 ensureProject ::- RunOptions -> FilePath -> FilePath -> CabalMeta -> [Line] -> IO FilePath-ensureProject opts userCwd scriptAbsPath meta scriptCode = do+ RunOptions ->+ FilePath ->+ FilePath ->+ CabalMeta ->+ [Line] ->+ T.Text ->+ IO FilePath+ensureProject opts userCwd scriptAbsPath meta scriptCode renderedBody = do home <- getHomeDirectory let name = deriveProjectName scriptAbsPath projectDir = home </> ".scripths" </> name@@ -199,9 +231,9 @@ | th = compileCdSetup <> compileCdTo userCwd- <> toGhciScript scriptCode+ <> renderedBody <> compileCdTo projectDir- | otherwise = toGhciScript scriptCode+ | otherwise = renderedBody TIO.writeFile (projectDir </> "script.ghci") (autoPrintDirective <> cdDirective userCwd <> body)
test/Test/Render.hs view
@@ -15,6 +15,7 @@ renderLiterate, renderModuleText, toGhciScript,+ toGhciScriptTagged, toModule, ) @@ -342,8 +343,77 @@ ] length (splitBlocks result) @?= 1 ]+ , taggedTests , moduleTests ]++{- | 'toGhciScriptTagged' prefixes every @:{ … :}@ block with a+@{\-# LINE n "tag" #-\}@ pragma so GHC (esp. @-fdiagnostics-as-json@) reports+cell-relative lines and the cell's file tag, neutralizing any preamble GHCi+prepends. Directives, imports, pragmas and blanks stay bare (a LINE pragma+cannot attach to them at the prompt).+-}+taggedTests :: TestTree+taggedTests =+ testGroup+ "Tagged rendering (LINE pragmas)"+ [ testCase "single statement gets a LINE pragma with its source line + tag" $ do+ let result = toGhciScriptTagged "cell" [(3, HaskellLine "print 42")]+ linePragmasIn result @?= ["{-# LINE 3 \"cell\" #-}"]+ , testCase "the LINE pragma is the first line inside the :{ block" $ do+ let result = toGhciScriptTagged "cell" [(3, HaskellLine "print 42")]+ case splitBlocks result of+ (block : _) ->+ map T.strip block @?= ["{-# LINE 3 \"cell\" #-}", "print 42"]+ [] -> assertBool "expected a block" False+ , testCase "directives, imports, pragmas and blanks are not tagged" $ do+ let result =+ toGhciScriptTagged+ "cell"+ [ (1, Import "import Data.Text")+ , (2, Blank)+ , (3, Pragma "{-# LANGUAGE GADTs #-}")+ , (4, GhciCommand ":set -XOverloadedStrings")+ ]+ linePragmasIn result @?= []+ , testCase "merged type sig + binding share one pragma at the first line" $ do+ let result =+ toGhciScriptTagged+ "cell"+ [ (5, HaskellLine "f :: Int -> Int")+ , (6, HaskellLine "f x = x + 1")+ ]+ length (splitBlocks result) @?= 1+ linePragmasIn result @?= ["{-# LINE 5 \"cell\" #-}"]+ , testCase "comment attaching forward uses the comment's line number" $ do+ let result =+ toGhciScriptTagged+ "cell"+ [ (2, HaskellLine "-- doc comment")+ , (3, HaskellLine "g y = y * 2")+ ]+ length (splitBlocks result) @?= 1+ linePragmasIn result @?= ["{-# LINE 2 \"cell\" #-}"]+ , testCase "each statement block gets its own pragma at its own line" $ do+ let result =+ toGhciScriptTagged+ "cell"+ [ (1, HaskellLine "x = 1")+ , (2, HaskellLine "print x")+ ]+ length (splitBlocks result) @?= 2+ linePragmasIn result @?= ["{-# LINE 1 \"cell\" #-}", "{-# LINE 2 \"cell\" #-}"]+ , testCase "line numbers come from the source, not the rendered position" $ do+ let result =+ toGhciScriptTagged+ "sabela-cell-7"+ [(42, HaskellLine "boom")]+ linePragmasIn result @?= ["{-# LINE 42 \"sabela-cell-7\" #-}"]+ ]++linePragmasIn :: Text -> [Text]+linePragmasIn =+ filter (T.isPrefixOf "{-# LINE") . map T.strip . T.lines moduleTests :: TestTree moduleTests =
test/Test/Run.hs view
@@ -12,6 +12,7 @@ deriveProjectName, renderCabalFile, renderCabalProject,+ scriptGhciBody, usesTemplateHaskell, ) @@ -144,6 +145,26 @@ , testCase "false for a plain notebook" $ usesTemplateHaskell emptyMeta [HaskellLine "1 + 1", Import "import Data.List"] @?= False+ ]+ , testGroup+ "scriptGhciBody"+ [ testCase "wraps a cell with a LINE pragma naming the script path + source line" $ do+ let body = scriptGhciBody "./examples/analysis.ghci" [(11, HaskellLine "duble 5")]+ assertBool+ "tagged pragma"+ (T.isInfixOf "{-# LINE 11 \"./examples/analysis.ghci\" #-}" body)+ , testCase "uses the original source line, not the rendered position" $ do+ let body =+ scriptGhciBody+ "f.ghci"+ [(1, Import "import Data.Text"), (5, HaskellLine "x = 1")]+ assertBool "statement at line 5" (T.isInfixOf "{-# LINE 5 \"f.ghci\" #-}" body)+ , testCase "imports stay bare (a LINE pragma cannot attach at the prompt)" $ do+ let body =+ scriptGhciBody+ "f.ghci"+ [(1, Import "import Data.Text"), (5, HaskellLine "x = 1")]+ assertBool "import not pragma'd" (not (T.isInfixOf "{-# LINE 1 " body)) ] ] where