Fix damlc build error messages if LOCALE_ARCHIVE is not set (#3041)

* Fix damlc build error messages if LOCALE_ARCHIVE is not set

* Fix tests

* fix more tests

compiler/damlc/daml-doc/BUILD.bazel

@@ -27,6 +27,7 @@ da_haskell_library(
         "ghc-lib",
         "ghcide",
         "hashable",
+        "haskell-lsp",
         "mtl",
         "network-uri",
         "prettyprinter",
@@ -52,10 +53,12 @@ da_haskell_library(
         "extra",
         "filepath",
         "ghcide",
+        "haskell-lsp",
         "mtl",
         "tasty-hunit",
         "tasty-golden",
         "text",
+        "transformers",
     ],
     src_strip_prefix = "test",
     visibility = ["//visibility:public"],

compiler/damlc/daml-doc/src/DA/Daml/Doc/Driver.hs

@@ -17,11 +17,11 @@ import DA.Daml.Doc.Extract
 import DA.Daml.Doc.Transform
 
 import Development.IDE.Types.Location
-import Development.IDE.Types.Diagnostics
 import Development.IDE.Types.Options
+import qualified Language.Haskell.LSP.Messages as LSP
 
 import Control.Monad.Extra
-import Control.Monad.Except
+import Control.Monad.Trans.Maybe
 import Data.Maybe
 import System.IO
 import System.Exit
@@ -38,6 +38,7 @@ import qualified Data.Text.Encoding as T
 data DamldocOptions = DamldocOptions
     { do_inputFormat :: InputFormat
     , do_ideOptions :: IdeOptions
+    , do_diagsLogger :: LSP.FromServerMessage -> IO ()
     , do_outputPath :: FilePath
     , do_outputFormat :: OutputFormat
     , do_docTemplate :: Maybe FilePath
@@ -73,8 +74,7 @@ inputDocData DamldocOptions{..} = do
                 ]
             exitFailure
 
-        renderDiags = T.unpack . showDiagnosticsColored
-        onErrorExit act = act >>= either (printAndExit . renderDiags) pure
+        onErrorExit act = act >>= maybe (printAndExit "") pure
 
     case do_inputFormat of
         InputJson -> do
@@ -82,8 +82,8 @@ inputDocData DamldocOptions{..} = do
             let mbData = map (AE.eitherDecode . LBS.fromStrict) input
             concatMapM (either printAndExit pure) mbData
 
-        InputDaml -> onErrorExit . runExceptT $
-            extractDocs do_extractOptions do_ideOptions do_inputFiles
+        InputDaml -> onErrorExit . runMaybeT $
+            extractDocs do_extractOptions do_diagsLogger do_ideOptions do_inputFiles
 
 -- | Output doc data.
 renderDocData :: DamldocOptions -> [ModuleDoc] -> IO ()

compiler/damlc/daml-doc/src/DA/Daml/Doc/Extract.hs

@@ -22,9 +22,9 @@ import qualified Development.IDE.Core.Service     as Service
 import qualified Development.IDE.Core.Rules     as Service
 import qualified Development.IDE.Core.RuleTypes as Service
 import qualified Development.IDE.Core.OfInterest as Service
-import           Development.IDE.Types.Diagnostics
 import Development.IDE.Types.Logger
 import Development.IDE.Types.Location
+import qualified Language.Haskell.LSP.Messages as LSP
 
 import           "ghc-lib" GHC
 import           "ghc-lib-parser" Module
@@ -44,7 +44,7 @@ import qualified "ghc-lib-parser" Outputable                      as Out
 import qualified "ghc-lib-parser" DynFlags                        as DF
 import           "ghc-lib-parser" Bag (bagToList)
 
-import           Control.Monad.Except             as Ex
+import Control.Monad
 import Control.Monad.Trans.Maybe
 import           Data.Char (isSpace)
 import           Data.List.Extra
@@ -79,11 +79,12 @@ defaultExtractOptions = ExtractOptions
 -- | Extract documentation in a dependency graph of modules.
 extractDocs ::
     ExtractOptions
+    -> (LSP.FromServerMessage -> IO ())
     -> IdeOptions
     -> [NormalizedFilePath]
-    -> Ex.ExceptT [FileDiagnostic] IO [ModuleDoc]
-extractDocs extractOpts ideOpts fp = do
-    modules <- haddockParse ideOpts fp
+    -> MaybeT IO [ModuleDoc]
+extractDocs extractOpts diagsLogger ideOpts fp = do
+    modules <- haddockParse diagsLogger ideOpts fp
     pure $ map mkModuleDocs modules
 
   where
@@ -220,20 +221,19 @@ buildDocCtx dc_extractOptions dc_tcmod  =
 --
 --   Not using the cached file store, as it is expected to run stand-alone
 --   invoked by a CLI tool.
-haddockParse :: IdeOptions ->
+haddockParse :: (LSP.FromServerMessage -> IO ()) ->
+                IdeOptions ->
                 [NormalizedFilePath] ->
-                Ex.ExceptT [FileDiagnostic] IO [Service.TcModuleResult]
-haddockParse opts f = ExceptT $ do
+                MaybeT IO [Service.TcModuleResult]
+haddockParse diagsLogger opts f = MaybeT $ do
   vfs <- makeVFSHandle
-  service <- Service.initialise Service.mainRule (const $ pure ()) noLogging opts vfs
+  service <- Service.initialise Service.mainRule diagsLogger noLogging opts vfs
   Service.setFilesOfInterest service (Set.fromList f)
-  parsed  <- Service.runAction service $
+  Service.runAction service $
              runMaybeT $
              do deps <- Service.usesE Service.GetDependencies f
                 Service.usesE Service.TypeCheck $ nubOrd $ f ++ concatMap Service.transitiveModuleDeps deps
                 -- The DAML compiler always parses with Opt_Haddock on
-  diags <- Service.getDiagnostics service
-  pure (maybe (Left diags) Right parsed)
 
 ------------------------------------------------------------
 

compiler/damlc/daml-doc/test/DA/Daml/GHC/Damldoc/Tests.hs

@@ -15,13 +15,17 @@ import DA.Daml.Doc.Types
 import DA.Daml.Doc.Transform
 import DA.Daml.Doc.Anchor
 
+import Development.IDE.Types.Diagnostics
 import Development.IDE.Types.Location
 import Development.IDE.Types.Options (IdeReportProgress(..))
+import Development.IDE.LSP.Protocol
 
-import           Control.Monad.Except
+import Control.Monad
+import           Control.Monad.Trans.Maybe
 import qualified Data.Aeson.Encode.Pretty as AP
 import           Data.List.Extra
 import qualified Data.Text          as T
+import qualified Data.Text.IO as T
 import qualified Data.Text.Extended as T
 import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Lazy.Encoding as TL
@@ -257,17 +261,22 @@ runDamldoc testfile importPathM = do
                   optImportPath opts
           }
 
+    let diagLogger = \case
+            EventFileDiagnostics fp diags -> T.hPutStrLn stderr $ showDiagnostics $ map (toNormalizedFilePath fp,) diags
+            _ -> pure ()
+
     -- run the doc generator on that file
-    mbResult <- runExceptT $ extractDocs
+    mbResult <- runMaybeT $ extractDocs
         defaultExtractOptions
+        diagLogger
         (toCompileOpts opts' (IdeReportProgress False))
         [toNormalizedFilePath testfile]
 
     case mbResult of
-      Left err ->
-        assertFailure $ unlines ["Parse error(s) for test file " <> testfile, show err]
+      Nothing ->
+        assertFailure $ unlines ["Parse error(s) for test file " <> testfile]
 
-      Right docs -> do
+      Just docs -> do
           let docs' = applyTransform [] docs
                 -- apply transforms to get instance data
               name = md_name (head docs)

compiler/damlc/lib/DA/Cli/Damlc/Command/Damldoc.hs

@@ -5,6 +5,7 @@
 module DA.Cli.Damlc.Command.Damldoc(cmd, exec) where
 
 import DA.Cli.Options
+import DA.Cli.Output
 import DA.Daml.Doc.Driver
 import DA.Daml.Doc.Extract
 import DA.Daml.Options
@@ -190,6 +191,7 @@ exec Damldoc{..} = do
     runDamlDoc DamldocOptions
         { do_ideOptions = toCompileOpts opts { optHaddock=Haddock True}
             (IdeReportProgress False)
+        , do_diagsLogger = diagnosticsLogger
         , do_outputPath = cOutputPath
         , do_outputFormat = cOutputFormat
         , do_inputFormat = cInputFormat

compiler/damlc/lib/DA/Cli/Output.hs

@@ -8,14 +8,15 @@ module DA.Cli.Output
   , diagnosticsLogger
   ) where
 
+import qualified Data.ByteString.Char8 as BS
 import qualified Data.ByteString.Lazy                           as BSL
 import           Data.String                                    (IsString)
-import qualified Data.Text.IO as T
+import qualified Data.Text.Encoding as T
 import Development.IDE.LSP.Protocol
 import Development.IDE.Types.Diagnostics
 import Development.IDE.Types.Location
 import Language.Haskell.LSP.Messages
-import           System.IO                                      (Handle, hClose, hPutStr, stdout, openFile, IOMode (WriteMode))
+import System.IO
 import           Control.Exception (bracket)
 
 -- | Write some text to the destination specified on the command line.
@@ -45,9 +46,14 @@ writeOutput = writeOutputWith hPutStr
 writeOutputBSL :: FilePath -> BSL.ByteString -> IO ()
 writeOutputBSL = writeOutputWith BSL.hPutStr
 
+-- WARNING: Here be dragons
+-- T.putStrLn is locale-dependent. This seems to cause issues with Nix’ patched glibc that
+-- relies on LOCALE_ARCHIVE being set correctly. This is the case in our dev-env
+-- but not when we ship the SDK. If LOCALE_ARCHIVE is not set properly the colored
+-- diagnostics get eaten somewhere in glibc and we don’t even get a write syscall containing them.
 printDiagnostics :: [FileDiagnostic] -> IO ()
 printDiagnostics [] = return ()
-printDiagnostics xs = T.putStrLn $ showDiagnosticsColored xs
+printDiagnostics xs = BS.hPutStrLn stderr $ T.encodeUtf8 $ showDiagnosticsColored xs
 
 diagnosticsLogger :: FromServerMessage -> IO ()
 diagnosticsLogger = \case

compiler/damlc/tests/src/DA/Test/DamlDocTestIntegration.hs

@@ -32,8 +32,8 @@ tests damlcPath = testGroup "doctest integration tests"
                   , "add x y = 0"
                   ]
               (exit, stdout, stderr) <- readProcessWithExitCode damlcPath ["doctest", f] ""
-              assertBool ("error in: " <> stdout) ("expected 0 === 2" `isInfixOf` stdout)
-              stderr @?= ""
+              assertBool ("error in: " <> stderr) ("expected 0 === 2" `isInfixOf` stderr)
+              stdout @?= ""
               assertEqual "exit code" (ExitFailure 1) exit
     , testCase "succeeding doctest" $
           withTempDir $ \tmpDir -> do