+
+-- | Write out a dump.
+-- If --dump-to-file is set then this goes to a file.
+-- otherwise emit to stdout.
+dumpSDoc :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
+dumpSDoc dflags dflag hdr doc
+ = do let mFile = chooseDumpFile dflags dflag
+ case mFile of
+ -- write the dump to a file
+ -- don't add the header in this case, we can see what kind
+ -- of dump it is from the filename.
+ Just fileName
+ -> do
+ let gdref = generatedDumps dflags
+ gd <- readIORef gdref
+ let append = Set.member fileName gd
+ mode = if append then AppendMode else WriteMode
+ when (not append) $
+ writeIORef gdref (Set.insert fileName gd)
+ handle <- openFile fileName mode
+ hPrintDump handle doc
+ hClose handle
+
+ -- write the dump to stdout
+ Nothing
+ -> printDump (mkDumpDoc hdr doc)
+
+
+-- | Choose where to put a dump file based on DynFlags
+--
+chooseDumpFile :: DynFlags -> DynFlag -> Maybe String
+chooseDumpFile dflags dflag
+
+ -- dump file location is being forced
+ -- by the --ddump-file-prefix flag.
+ | dumpToFile
+ , Just prefix <- dumpPrefixForce dflags
+ = Just $ prefix ++ (beautifyDumpName dflag)
+
+ -- dump file location chosen by DriverPipeline.runPipeline
+ | dumpToFile
+ , Just prefix <- dumpPrefix dflags
+ = Just $ prefix ++ (beautifyDumpName dflag)
+
+ -- we haven't got a place to put a dump file.
+ | otherwise
+ = Nothing
+
+ where dumpToFile = dopt Opt_DumpToFile dflags
+
+
+-- | Build a nice file name from name of a DynFlag constructor
+beautifyDumpName :: DynFlag -> String
+beautifyDumpName dflag
+ = let str = show dflag
+ cut = if isPrefixOf "Opt_D_" str
+ then drop 6 str
+ else str
+ dash = map (\c -> case c of
+ '_' -> '-'
+ _ -> c)
+ cut
+ in dash
+
+