From 2f7500d852beec5815bc21246ac233d634864606 Mon Sep 17 00:00:00 2001 From: thomasjm Date: Tue, 10 Nov 2026 18:41:00 -0800 Subject: [PATCH 1/4] Backends: one binding per let --- src/Render/Backend/Latex.hs | 78 +++++++++++++++++++++--------------- src/Render/Backend/Pandoc.hs | 45 +++++++++++---------- 2 files changed, 69 insertions(+), 54 deletions(-) diff --git a/src/Render/Backend/Latex.hs b/src/Render/Backend/Latex.hs index dc4ea6a..9712215 100644 --- a/src/Render/Backend/Latex.hs +++ b/src/Render/Backend/Latex.hs @@ -3,6 +3,7 @@ module Render.Backend.Latex ( , prepareWorkDir , compileTex , depsFromFls + , logStream ) where import Control.Monad (forM_, unless, when) @@ -40,20 +41,17 @@ latexBackend = Backend { -- Returns the @src/@ directory. prepareWorkDir :: RenderRequest -> IO FilePath prepareWorkDir (RenderRequest {..}) = do - let entryDir = takeDirectory requestEntryPath - srcDir = requestWorkDir "src" - overlayDir = requestWorkDir "overlay" - outDir = requestWorkDir "out" - - forM_ [srcDir, outDir] (createDirectoryIfMissing True) + let srcDir = requestWorkDir "src" + forM_ [srcDir, requestWorkDir "out"] (createDirectoryIfMissing True) T.writeFile (srcDir takeFileName requestEntryPath) requestEntryText + let overlayDir = requestWorkDir "overlay" doesDirectoryExist overlayDir >>= \case True -> removeDirectoryRecursive overlayDir False -> return () createDirectoryIfMissing True overlayDir forM_ requestOverlays $ \(path, text) -> do - let rel = makeRelative entryDir path + let rel = makeRelative (takeDirectory requestEntryPath) path unless (isAbsolute rel || ".." `isPrefixOf` rel) $ do createDirectoryIfMissing True (takeDirectory (overlayDir rel)) T.writeFile (overlayDir rel) text @@ -64,26 +62,20 @@ prepareWorkDir (RenderRequest {..}) = do -- build when settling. The PDF, the recorded dependencies and the timing come back. compileTex :: RenderRequest -> FilePath -> IO RenderResult compileTex (RenderRequest {..}) texFile = do - let entryDir = takeDirectory requestEntryPath - job = dropExtension (takeFileName texFile) - srcDir = requestWorkDir "src" - overlayDir = requestWorkDir "overlay" - outDir = requestWorkDir "out" - + let job = dropExtension (takeFileName texFile) + let outDir = requestWorkDir "out" + let overlayDir = requestWorkDir "overlay" let engine = T.unpack (fromMaybe "pdflatex" (M.lookup "engine" requestOptions)) - baseEnv <- getEnvironment - let inherited = fromMaybe "" (lookup "TEXINPUTS" baseEnv) - texinputs = overlayDir <> "//:" <> (if null inherited then "" else inherited) - overrides = [("TEXINPUTS", texinputs), ("LC_ALL", "C"), ("SOURCE_DATE_EPOCH", show requestEpoch), ("FORCE_SOURCE_DATE", "1")] - env = overrides <> filter ((`notElem` map fst overrides) . fst) baseEnv - common = ["-interaction=nonstopmode", "-halt-on-error", "-file-line-error", "-recorder", "-jobname=" <> job] - (exe, args) = case requestSettle of + env <- texEnv overlayDir requestEpoch <$> getEnvironment + let common = ["-interaction=nonstopmode", "-halt-on-error", "-file-line-error", "-recorder", "-jobname=" <> job] + let (exe, args) = case requestSettle of True -> ("latexmk", [engineFlag engine, "-outdir=" <> outDir] <> common <> [texFile]) False -> (engine, ["-output-directory=" <> outDir] <> common <> [texFile]) requestLog LogStdout (T.pack (unwords (exe : args))) + let entryDir = takeDirectory requestEntryPath start <- getCurrentTime - code <- runCapturing entryDir env exe args $ \isOut line -> requestLog (if isOut then LogStdout else LogStderr) line + code <- runCapturing entryDir env exe args $ \isOut line -> requestLog (logStream isOut) line end <- getCurrentTime let ms = realToFrac (diffUTCTime end start) * 1000 :: Double @@ -97,14 +89,30 @@ compileTex (RenderRequest {..}) texFile = do fls <- doesFileExist (outDir job <.> "fls") >>= \case True -> T.readFile (outDir job <.> "fls") False -> return "" - let deps = depsFromFls entryDir requestEntryPath srcDir overlayDir requestWorkDir fls return RenderResult { resultFileName = T.pack (job <.> "pdf") , resultBytes = bytes - , resultDeps = deps + , resultDeps = depsFromFls entryDir requestEntryPath (requestWorkDir "src") overlayDir requestWorkDir fls , resultTimings = [Timing (T.pack exe) ms] } +logStream :: Bool -> LogStream +logStream = \case + True -> LogStdout + False -> LogStderr + +-- The overlay directory comes first on TEXINPUTS so open buffers shadow their disk copies; the +-- epoch pins the timestamps the engine writes into the PDF +texEnv :: FilePath -> Integer -> [(String, String)] -> [(String, String)] +texEnv overlayDir epoch baseEnv = overrides <> filter ((`notElem` map fst overrides) . fst) baseEnv + where + overrides = [ + ("TEXINPUTS", overlayDir <> "//:" <> fromMaybe "" (lookup "TEXINPUTS" baseEnv)) + , ("LC_ALL", "C") + , ("SOURCE_DATE_EPOCH", show epoch) + , ("FORCE_SOURCE_DATE", "1") + ] + engineFlag :: String -> String engineFlag = \case "xelatex" -> "-pdfxe" @@ -118,22 +126,26 @@ depsFromFls entryDir entryPath srcDir overlayDir workDir fls = nub (mapMaybe dep where dep line = case T.stripPrefix "INPUT " line of Nothing -> Nothing - Just (T.unpack . T.strip -> p) -> - let abs' = normalise (if isAbsolute p then p else entryDir p) - in if | "/nix/store" `isPrefixOf` abs' -> Nothing - | normalise srcDir `isPrefixOf` abs' -> Just entryPath - | normalise overlayDir `isPrefixOf` abs' -> Just (entryDir makeRelative (normalise overlayDir) abs') - | normalise workDir `isPrefixOf` abs' -> Nothing - | otherwise -> Just abs' + Just (T.unpack . T.strip -> p) -> classify (normalise (absolute p)) + + absolute p = case isAbsolute p of + True -> p + False -> entryDir p + + classify abs' + | "/nix/store" `isPrefixOf` abs' = Nothing + | normalise srcDir `isPrefixOf` abs' = Just entryPath + | normalise overlayDir `isPrefixOf` abs' = Just (entryDir makeRelative (normalise overlayDir) abs') + | normalise workDir `isPrefixOf` abs' = Nothing + | otherwise = Just abs' -- The engine's own account of what went wrong: the @!@ lines and the @file:line:@ errors logErrors :: FilePath -> (LogStream -> T.Text -> IO ()) -> IO () logErrors logFile logFn = doesFileExist logFile >>= \case False -> return () True -> do - contents <- T.readFile logFile - let ls = T.lines contents - interesting = [l | (l, next) <- zip ls (drop 1 ls <> [""]), isError l || isError next] + ls <- T.lines <$> T.readFile logFile + let interesting = [l | (l, next) <- zip ls (drop 1 ls <> [""]), isError l || isError next] when (not (null interesting)) $ logFn LogStderr (T.unlines interesting) where isError l = "!" `T.isPrefixOf` l || T.isInfixOf ":error:" l || hasLineError l diff --git a/src/Render/Backend/Pandoc.hs b/src/Render/Backend/Pandoc.hs index 4dc6403..dd325b8 100644 --- a/src/Render/Backend/Pandoc.hs +++ b/src/Render/Backend/Pandoc.hs @@ -3,6 +3,7 @@ module Render.Backend.Pandoc ( ) where import qualified Data.ByteString as B +import Data.Map (Map) import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.String.Interpolate @@ -10,7 +11,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Time import Render.Backend -import Render.Backend.Latex (compileTex, prepareWorkDir) +import Render.Backend.Latex (compileTex, logStream, prepareWorkDir) import Render.Process import Render.Protocol (LogStream(..), Timing(..)) import System.Environment (getEnvironment) @@ -32,32 +33,21 @@ render :: RenderRequest -> IO RenderResult render req@(RenderRequest {..}) = do srcDir <- prepareWorkDir req let entryFile = takeFileName requestEntryPath - job = dropExtension entryFile - outDir = requestWorkDir "out" - opt k = M.lookup k requestOptions - to = fromMaybe "html" (opt "to") - writer = case to of - "pdf" -> "latex" - other -> other - format = T.unpack (fromMaybe (defaultExtension writer) (opt "format")) - reader = case takeExtension entryFile of - ".md" -> ["-f", T.unpack (fromMaybe defaultMarkdown (opt "from"))] - _ -> [] - extra = maybe [] (map T.unpack . T.words) (opt "pandoc_args") - viaLatex = writer `elem` ["latex", "beamer"] - output = case viaLatex of + let job = dropExtension entryFile + let writer = writerFor requestOptions + let format = T.unpack (fromMaybe (defaultExtension writer) (M.lookup "format" requestOptions)) + let viaLatex = writer `elem` ["latex", "beamer"] + let output = case viaLatex of True -> srcDir job <.> "tex" - False -> outDir job <.> format - args = reader <> ["-t", T.unpack writer, "--standalone"] <> extra <> [srcDir entryFile, "-o", output] + False -> requestWorkDir "out" job <.> format + let args = readerArgs entryFile requestOptions <> ["-t", T.unpack writer, "--standalone"] <> extraArgs requestOptions <> [srcDir entryFile, "-o", output] env <- (("LC_ALL", "C") :) . filter ((/= "LC_ALL") . fst) <$> getEnvironment requestLog LogStdout (T.pack (unwords ("pandoc" : args))) start <- getCurrentTime - code <- runCapturing (takeDirectory requestEntryPath) env "pandoc" args $ \isOut line -> - requestLog (if isOut then LogStdout else LogStderr) line + code <- runCapturing (takeDirectory requestEntryPath) env "pandoc" args $ \isOut line -> requestLog (logStream isOut) line end <- getCurrentTime - let ms = realToFrac (diffUTCTime end start) * 1000 :: Double - pandocTiming = Timing "pandoc" ms + let pandocTiming = Timing "pandoc" (realToFrac (diffUTCTime end start) * 1000) case code of ExitFailure n -> throwIO (RenderFailure n [i|pandoc exited with code #{n}|]) @@ -76,6 +66,19 @@ render req@(RenderRequest {..}) = do , resultTimings = [pandocTiming] } +writerFor :: Map Text Text -> Text +writerFor options = case fromMaybe "html" (M.lookup "to" options) of + "pdf" -> "latex" + other -> other + +readerArgs :: FilePath -> Map Text Text -> [String] +readerArgs entryFile options = case takeExtension entryFile of + ".md" -> ["-f", T.unpack (fromMaybe defaultMarkdown (M.lookup "from" options))] + _ -> [] + +extraArgs :: Map Text Text -> [String] +extraArgs = maybe [] (map T.unpack . T.words) . M.lookup "pandoc_args" + defaultMarkdown :: Text defaultMarkdown = "markdown+tex_math_dollars+tex_math_single_backslash+raw_html+smart" From 0926d49bb4816c12c2fba9b611514a806fbf1d98 Mon Sep 17 00:00:00 2001 From: thomasjm Date: Tue, 10 Nov 2026 18:41:00 -0800 Subject: [PATCH 2/4] Server: one binding per let, drop the redundant Data.Int import --- src/Render/Server.hs | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/src/Render/Server.hs b/src/Render/Server.hs index faef418..19d2ccb 100644 --- a/src/Render/Server.hs +++ b/src/Render/Server.hs @@ -13,7 +13,6 @@ import Data.Aeson (Result(..), Value, fromJSON, toJSON) import qualified Data.Aeson as A import qualified Data.ByteString as B import qualified Data.ByteString.Base64 as B64 -import Data.Int (Int32) import Data.Map (Map) import qualified Data.Map as M import Data.Maybe (fromMaybe, isJust) @@ -114,9 +113,8 @@ handlers env = mconcat [ -- The lsp library always advertises semantic tokens; answer with nothing rather than an error , requestHandler SMethod_TextDocumentSemanticTokensFull $ \_ respond -> respond (Right (InR Null)) , requestHandler SMethod_WorkspaceExecuteCommand $ \req respond -> do - let cmd = req ^. L.params . L.command - args = fromMaybe [] (req ^. L.params . L.arguments) - result <- liftIO $ try (executeCommand env cmd args) + let args = fromMaybe [] (req ^. L.params . L.arguments) + result <- liftIO $ try (executeCommand env (req ^. L.params . L.command) args) respond $ case result of Left (e :: SomeException) -> Left (TResponseError (InR ErrorCodes_InvalidParams) (T.pack (show e)) Nothing) Right Nothing -> Right (InR Null) @@ -241,8 +239,7 @@ renderOnce env task phase = do let reason = case reasons of [] -> Nothing _ -> Just (T.intercalate ", " reasons) - settle = phase == PhaseSettle - label = case phase of + let label = case phase of PhaseQuick -> "quick render" :: Text PhaseSettle -> "settle pass" -- The settle pass stays out of the log unless it fails or changes the output @@ -250,8 +247,8 @@ renderOnce env task phase = do let logFn stream text = case phase of PhaseQuick -> sendLog env task stream text False PhaseSettle -> atomically (modifyTVar' buffered ((stream, text) :)) - marker text = logFn LogStdout ("── " <> text) - flush = do + let marker text = logFn LogStdout ("── " <> text) + let flush = do lines' <- reverse <$> atomically (swapTVar buffered []) forM_ lines' $ \(stream, text) -> sendLog env task stream text False case phase of @@ -267,7 +264,7 @@ renderOnce env task phase = do , requestOverlays = overlays , requestWorkDir = taskWorkDir task , requestOptions = taskOptions task - , requestSettle = settle + , requestSettle = phase == PhaseSettle , requestEpoch = taskEpoch task , requestLog = logFn } From 0dffd33f063cfac97546b799251ecbf95477eb1f Mon Sep 17 00:00:00 2001 From: thomasjm Date: Tue, 10 Nov 2026 18:41:00 -0800 Subject: [PATCH 3/4] Tests: write the JSON and fls fixtures as quasiquotes --- lsp-export-server.cabal | 1 + package.yaml | 1 + test/Main.hs | 19 +++++++++++++------ 3 files changed, 15 insertions(+), 6 deletions(-) diff --git a/lsp-export-server.cabal b/lsp-export-server.cabal index 4479c4b..b46e577 100644 --- a/lsp-export-server.cabal +++ b/lsp-export-server.cabal @@ -163,6 +163,7 @@ test-suite lsp-export-server-test , containers , lsp-export-server , sandwich + , string-interpolate , text , unliftio default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index 0ccbeaf..02951be 100644 --- a/package.yaml +++ b/package.yaml @@ -90,3 +90,4 @@ tests: dependencies: - lsp-export-server - sandwich + - string-interpolate diff --git a/test/Main.hs b/test/Main.hs index df121eb..81b37d9 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,9 +1,10 @@ module Main (main) where import Control.Monad.IO.Class (liftIO) -import Data.Aeson (decode, encode, object, (.=)) +import Data.Aeson (Value, decode, encode) import qualified Data.ByteString.Char8 as B8 import qualified Data.Map as M +import Data.String.Interpolate import Render.Backend.Latex (depsFromFls) import Render.Protocol import qualified Render.Xdelta as Xdelta @@ -15,7 +16,7 @@ spec = do describe "xdelta3" $ do it "round-trips a patch" $ do let old = B8.pack (concat (replicate 200 "the quick brown fox ")) - new = B8.pack (concat (replicate 100 "the quick brown fox ") <> "jumped" <> concat (replicate 100 "the quick brown fox ")) + let new = B8.pack (concat (replicate 100 "the quick brown fox ") <> "jumped" <> concat (replicate 100 "the quick brown fox ")) Right patch <- liftIO (Xdelta.encode new old) Right rebuilt <- liftIO (Xdelta.decode patch old) rebuilt `shouldBe` new @@ -28,15 +29,21 @@ spec = do describe "protocol" $ do it "writes camelCase fields and lower-case tags" $ do let params = StatusParams "t1" StatusErrored PhaseQuick (Just "edit to x.tex (v3)") (Just 12) Nothing [] - decode (encode params) `shouldBe` Just (object ["taskId" .= ("t1" :: String), "status" .= ("errored" :: String), "phase" .= ("quick" :: String), "reason" .= ("edit to x.tex (v3)" :: String), "exitCode" .= (12 :: Int), "timings" .= ([] :: [Int])]) + decode (encode params) `shouldBe` (decode [i|{"taskId":"t1","status":"errored","phase":"quick","reason":"edit to x.tex (v3)","exitCode":12,"timings":[]}|] :: Maybe Value) it "reads start params" $ do - let json = "{\"taskId\":\"a\",\"uri\":\"file:///home/x.tex\",\"format\":\"pdf\",\"options\":{\"engine\":\"xelatex\"},\"debounceMs\":50}" - decode json `shouldBe` Just (StartParams "a" "file:///home/x.tex" "pdf" (M.fromList [("engine", "xelatex")]) (Just 50)) + decode [i|{"taskId":"a","uri":"file:///home/x.tex","format":"pdf","options":{"engine":"xelatex"},"debounceMs":50}|] + `shouldBe` Just (StartParams "a" "file:///home/x.tex" "pdf" (M.fromList [("engine", "xelatex")]) (Just 50)) describe "latex deps" $ do it "maps the recorder's inputs back to the documents they stand for" $ do - let fls = "PWD /home/u/docs\nINPUT /nix/store/abc-texlive/article.cls\nINPUT /work/src/main.tex\nINPUT ./sub/inc.tex\nINPUT /work/overlay/sub/other.tex\nINPUT /work/out/main.aux\nINPUT /home/u/other/img.png\n" + let fls = [__i|PWD /home/u/docs + INPUT /nix/store/abc-texlive/article.cls + INPUT /work/src/main.tex + INPUT ./sub/inc.tex + INPUT /work/overlay/sub/other.tex + INPUT /work/out/main.aux + INPUT /home/u/other/img.png|] depsFromFls "/home/u/docs" "/home/u/docs/main.tex" "/work/src" "/work/overlay" "/work" fls `shouldBe` ["/home/u/docs/main.tex", "/home/u/docs/sub/inc.tex", "/home/u/docs/sub/other.tex", "/home/u/other/img.png"] From aa6bd1dbc95dcdff1f0bb97e43e100efdc06fe74 Mon Sep 17 00:00:00 2001 From: thomasjm Date: Tue, 10 Nov 2026 18:41:00 -0800 Subject: [PATCH 4/4] Dev shell: add zlib so stack can link --- flake.nix | 1 + 1 file changed, 1 insertion(+) diff --git a/flake.nix b/flake.nix index 85a94d1..3d8a667 100644 --- a/flake.nix +++ b/flake.nix @@ -44,6 +44,7 @@ devShellInputs = with pkgs; [ haskell.compiler.ghc9124 + zlib ]; in