ErrUtils: Refactor dump file logic
authorBen Gamari <ben@smart-cactus.org>
Wed, 22 Nov 2017 03:57:27 +0000 (22:57 -0500)
committerBen Gamari <ben@smart-cactus.org>
Wed, 22 Nov 2017 04:00:34 +0000 (23:00 -0500)
This refactors the dump file setup path, separating concerns a bit. It also
fixes an exception-unsafe usage of openFile.

compiler/main/ErrUtils.hs

index 1aa5238..43eb925 100644 (file)
@@ -456,6 +456,29 @@ mkDumpDoc hdr doc
      where
         line = text (replicate 20 '=')
 
+-- | Run an action with the handle of a 'DumpFlag' if we are outputting to a
+-- file, otherwise 'Nothing'.
+withDumpFileHandle :: DynFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO ()
+withDumpFileHandle dflags flag action = do
+    let mFile = chooseDumpFile dflags flag
+    case mFile of
+      Just fileName -> do
+        let gdref = generatedDumps dflags
+        gd <- readIORef gdref
+        let append = Set.member fileName gd
+            mode = if append then AppendMode else WriteMode
+        unless append $
+            writeIORef gdref (Set.insert fileName gd)
+        createDirectoryIfMissing True (takeDirectory fileName)
+        withFile fileName mode $ \handle -> do
+            -- We do not want the dump file to be affected by
+            -- environment variables, but instead to always use
+            -- UTF8. See:
+            -- https://ghc.haskell.org/trac/ghc/ticket/10762
+            hSetEncoding handle utf8
+
+            action (Just handle)
+      Nothing -> action Nothing
 
 -- | Write out a dump.
 -- If --dump-to-file is set then this goes to a file.
@@ -467,43 +490,28 @@ mkDumpDoc hdr doc
 -- The 'DumpFlag' is used only to choose the filename to use if @--dump-to-file@
 -- is used; it is not used to decide whether to dump the output
 dumpSDoc :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO ()
-dumpSDoc dflags print_unqual flag hdr doc
- = do let mFile = chooseDumpFile dflags flag
-          dump_style = mkDumpStyle dflags print_unqual
-      case mFile of
-            Just fileName
-                 -> do
-                        let gdref = generatedDumps dflags
-                        gd <- readIORef gdref
-                        let append = Set.member fileName gd
-                            mode = if append then AppendMode else WriteMode
-                        unless append $
-                            writeIORef gdref (Set.insert fileName gd)
-                        createDirectoryIfMissing True (takeDirectory fileName)
-                        handle <- openFile fileName mode
-
-                        -- We do not want the dump file to be affected by
-                        -- environment variables, but instead to always use
-                        -- UTF8. See:
-                        -- https://ghc.haskell.org/trac/ghc/ticket/10762
-                        hSetEncoding handle utf8
-
-                        doc' <- if null hdr
-                                then return doc
-                                else do t <- getCurrentTime
-                                        let d = text (show t)
-                                             $$ blankLine
-                                             $$ doc
-                                        return $ mkDumpDoc hdr d
-                        defaultLogActionHPrintDoc dflags handle doc' dump_style
-                        hClose handle
-
-            -- write the dump to stdout
-            Nothing -> do
-              let (doc', severity)
-                    | null hdr  = (doc, SevOutput)
-                    | otherwise = (mkDumpDoc hdr doc, SevDump)
-              putLogMsg dflags NoReason severity noSrcSpan dump_style doc'
+dumpSDoc dflags print_unqual flag hdr doc =
+    withDumpFileHandle dflags flag writeDump
+  where
+    dump_style = mkDumpStyle dflags print_unqual
+
+    -- write dump to file
+    writeDump (Just handle) = do
+        doc' <- if null hdr
+                then return doc
+                else do t <- getCurrentTime
+                        let d = text (show t)
+                              $$ blankLine
+                              $$ doc
+                        return $ mkDumpDoc hdr d
+        defaultLogActionHPrintDoc dflags handle doc' dump_style
+
+    -- write the dump to stdout
+    writeDump Nothing = do
+        let (doc', severity)
+              | null hdr  = (doc, SevOutput)
+              | otherwise = (mkDumpDoc hdr doc, SevDump)
+        putLogMsg dflags NoReason severity noSrcSpan dump_style doc'
 
 
 -- | Choose where to put a dump file based on DynFlags