diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/scripths.cabal b/scripths.cabal --- a/scripths.cabal +++ b/scripths.cabal @@ -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/ diff --git a/src/ScriptHs/Compiled.hs b/src/ScriptHs/Compiled.hs --- a/src/ScriptHs/Compiled.hs +++ b/src/ScriptHs/Compiled.hs @@ -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 <> " #-}" diff --git a/src/ScriptHs/Render.hs b/src/ScriptHs/Render.hs --- a/src/ScriptHs/Render.hs +++ b/src/ScriptHs/Render.hs @@ -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 diff --git a/src/ScriptHs/Run.hs b/src/ScriptHs/Run.hs --- a/src/ScriptHs/Run.hs +++ b/src/ScriptHs/Run.hs @@ -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) diff --git a/test/Test/Render.hs b/test/Test/Render.hs --- a/test/Test/Render.hs +++ b/test/Test/Render.hs @@ -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 = diff --git a/test/Test/Run.hs b/test/Test/Run.hs --- a/test/Test/Run.hs +++ b/test/Test/Run.hs @@ -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