Review fixes: let style, quasiquoted test fixtures, dev shell zlib

flake.nix

@@ -44,6 +44,7 @@
 
         devShellInputs = with pkgs; [
           haskell.compiler.ghc9124
+          zlib
         ];
 
       in

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

package.yaml

@@ -90,3 +90,4 @@ tests:
     dependencies:
     - lsp-export-server
     - sandwich
+    - string-interpolate

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

src/Render/Backend/Pandoc.hs

@@ -3,14 +3,15 @@ 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
 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"
 

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,17 +239,16 @@ 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
   buffered <- newTVarIO ([] :: [(LogStream, Text)])
   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
         }

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"]