{-
-----------------------------------------------------------------------------
--
-- (c) The University of Glasgow 2015
--
-- ELF format tools
--
-----------------------------------------------------------------------------
-}

module Elf (
    readElfSectionByName,
    readElfNoteAsString,
    makeElfNote
  ) where

import GhcPrelude

import AsmUtils
import Exception
import DynFlags
import ErrUtils
import Maybes     (MaybeT(..),runMaybeT)
import Util       (charToC)
import Outputable (text,hcat,SDoc)

import Control.Monad (when)
import Data.Binary.Get
import Data.Word
import Data.Char (ord)
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Char8 as B8

{- Note [ELF specification]
   ~~~~~~~~~~~~~~~~~~~~~~~~

   ELF (Executable and Linking Format) is described in the System V Application
   Binary Interface (or ABI). The latter is composed of two parts: a generic
   part and a processor specific part. The generic ABI describes the parts of
   the interface that remain constant across all hardware implementations of
   System V.

   The latest release of the specification of the generic ABI is the version
   4.1 from March 18, 1997:

     - http://www.sco.com/developers/devspecs/gabi41.pdf

   Since 1997, snapshots of the draft for the "next" version are published:

     - http://www.sco.com/developers/gabi/

   Quoting the notice on the website: "There is more than one instance of these
   chapters to permit references to older instances to remain valid. All
   modifications to these chapters are forward-compatible, so that correct use
   of an older specification will not be invalidated by a newer instance.
   Approximately on a yearly basis, a new instance will be saved, as it reaches
   what appears to be a stable state."

   Nevertheless we will see that since 1998 it is not true for Note sections.

   Many ELF sections
   -----------------

   ELF-4.1: the normal section number fields in ELF are limited to 16 bits,
   which runs out of bits when you try to cram in more sections than that. Two
   fields are concerned: the one containing the number of the sections and the
   one containing the index of the section that contains section's names. (The
   same thing applies to the field containing the number of segments, but we
   don't care about it here).

   ELF-next: to solve this, theses fields in the ELF header have an escape
   value (different for each case), and the actual section number is stashed
   into unused fields in the first section header.

   We support this extension as it is forward-compatible with ELF-4.1.
   Moreover, GHC may generate objects with a lot of sections with the
   "function-sections" feature (one section per function).

   Note sections
   -------------

   Sections with type "note" (SHT_NOTE in the specification) are used to add
   arbitrary data into an ELF file. An entry in a note section is composed of a
   name, a type and a value.

   ELF-4.1: "The note information in sections and program header elements holds
   any number of entries, each of which is an array of 4-byte words in the
   format of the target processor." Each entry has the following format:
         | namesz |   Word32: size of the name string (including the ending \0)
         | descsz |   Word32: size of the value
         |  type  |   Word32: type of the note
         |  name  |   Name string (with \0 padding to ensure 4-byte alignment)
         |  ...   |
         |  desc  |   Value (with \0 padding to ensure 4-byte alignment)
         |  ...   |

   ELF-next: "The note information in sections and program header elements
   holds a variable amount of entries. In 64-bit objects (files with
   e_ident[EI_CLASS] equal to ELFCLASS64), each entry is an array of 8-byte
   words in the format of the target processor. In 32-bit objects (files with
   e_ident[EI_CLASS] equal to ELFCLASS32), each entry is an array of 4-byte
   words in the format of the target processor." (from 1998-2015 snapshots)

   This is not forward-compatible with ELF-4.1. In practice, for almost all
   platforms namesz, descz and type fields are 4-byte words for both 32-bit and
   64-bit objects (see elf.h and readelf source code).

   The only exception in readelf source code is for IA_64 machines with OpenVMS
   OS: "This OS has so many departures from the ELF standard that we test it at
   many places" (comment for is_ia64_vms() in readelf.c). In this case, namesz,
   descsz and type fields are 8-byte words and name and value fields are padded
   to ensure 8-byte alignment.

   We don't support this platform in the following code. Reading a note section
   could be done easily (by testing Machine and OS fields in the ELF header).
   Writing a note section, however, requires that we generate a different
   assembly code for GAS depending on the target platform and this is a little
   bit more involved.

-}

-- | ELF header
--
-- The ELF header indicates the native word size (32-bit or 64-bit) and the
-- endianness of the target machine. We directly store getters for words of
-- different sizes as it is more convenient to use. We also store the word size
-- as it is useful to skip some uninteresting fields.
--
-- Other information such as the target machine and OS are left out as we don't
-- use them yet. We could add them in the future if we ever need them.
data ElfHeader = ElfHeader
   { gw16     :: Get Word16   -- ^ Get a Word16 with the correct endianness
   , gw32     :: Get Word32   -- ^ Get a Word32 with the correct endianness
   , gwN      :: Get Word64   -- ^ Get a Word with the correct word size
                              --   and endianness
   , wordSize :: Int          -- ^ Word size in bytes
   }

-- | Read the ELF header
readElfHeader :: DynFlags -> ByteString -> IO (Maybe ElfHeader)
readElfHeader dflags bs = runGetOrThrow getHeader bs `catchIO` \_ -> do
    debugTraceMsg dflags 3 $
      text ("Unable to read ELF header")
    return Nothing
  where
    getHeader = do
      magic    <- getWord32be
      ws       <- getWord8
      endian   <- getWord8
      version  <- getWord8
      skip 9  -- skip OSABI, ABI version and padding
      when (magic /= 0x7F454C46 || version /= 1) $ fail "Invalid ELF header"

      case (ws, endian) of
          -- ELF 32, little endian
          (1,1) -> return . Just $ ElfHeader
                           getWord16le
                           getWord32le
                           (fmap fromIntegral getWord32le) 4
          -- ELF 32, big endian
          (1,2) -> return . Just $ ElfHeader
                           getWord16be
                           getWord32be
                           (fmap fromIntegral getWord32be) 4
          -- ELF 64, little endian
          (2,1) -> return . Just $ ElfHeader
                           getWord16le
                           getWord32le
                           (fmap fromIntegral getWord64le) 8
          -- ELF 64, big endian
          (2,2) -> return . Just $ ElfHeader
                           getWord16be
                           getWord32be
                           (fmap fromIntegral getWord64be) 8
          _     -> fail "Invalid ELF header"

------------------
-- SECTIONS
------------------

-- | Description of the section table
data SectionTable = SectionTable
  { sectionTableOffset :: Word64  -- ^ offset of the table describing sections
  , sectionEntrySize   :: Word16  -- ^ size of an entry in the section table
  , sectionEntryCount  :: Word64  -- ^ number of sections
  , sectionNameIndex   :: Word32  -- ^ index of a special section which
                                  --   contains section's names
  }

-- | Read the ELF section table
readElfSectionTable :: DynFlags
                    -> ElfHeader
                    -> ByteString
                    -> IO (Maybe SectionTable)

readElfSectionTable dflags hdr bs = action `catchIO` \_ -> do
    debugTraceMsg dflags 3 $
      text ("Unable to read ELF section table")
    return Nothing
  where
    getSectionTable :: Get SectionTable
    getSectionTable = do
      skip (24 + 2*wordSize hdr) -- skip header and some other fields
      secTableOffset <- gwN hdr
      skip 10
      entrySize      <- gw16 hdr
      entryCount     <- gw16 hdr
      secNameIndex   <- gw16 hdr
      return (SectionTable secTableOffset entrySize
                           (fromIntegral entryCount)
                           (fromIntegral secNameIndex))

    action = do
      secTable <- runGetOrThrow getSectionTable bs
      -- In some cases, the number of entries and the index of the section
      -- containing section's names must be found in unused fields of the first
      -- section entry (see Note [ELF specification])
      let
        offSize0 = fromIntegral $ sectionTableOffset secTable + 8
                                  + 3 * fromIntegral (wordSize hdr)
        offLink0 = fromIntegral $ offSize0 + fromIntegral (wordSize hdr)

      entryCount'     <- if sectionEntryCount secTable /= 0
                          then return (sectionEntryCount secTable)
                          else runGetOrThrow (gwN hdr) (LBS.drop offSize0 bs)
      entryNameIndex' <- if sectionNameIndex secTable /= 0xffff
                          then return (sectionNameIndex secTable)
                          else runGetOrThrow (gw32 hdr) (LBS.drop offLink0 bs)
      return (Just $ secTable
        { sectionEntryCount = entryCount'
        , sectionNameIndex  = entryNameIndex'
        })

-- | A section
data Section = Section
  { entryName :: ByteString   -- ^ Name of the section
  , entryBS   :: ByteString   -- ^ Content of the section
  }

-- | Read a ELF section
readElfSectionByIndex :: DynFlags
                      -> ElfHeader
                      -> SectionTable
                      -> Word64
                      -> ByteString
                      -> IO (Maybe Section)

readElfSectionByIndex dflags hdr secTable i bs = action `catchIO` \_ -> do
    debugTraceMsg dflags 3 $
      text ("Unable to read ELF section")
    return Nothing
  where
    -- read an entry from the section table
    getEntry = do
      nameIndex <- gw32 hdr
      skip (4+2*wordSize hdr)
      offset    <- fmap fromIntegral $ gwN hdr
      size      <- fmap fromIntegral $ gwN hdr
      let bs' = LBS.take size (LBS.drop offset bs)
      return (nameIndex,bs')

    -- read the entry with the given index in the section table
    getEntryByIndex x = runGetOrThrow getEntry bs'
      where
        bs' = LBS.drop off bs
        off = fromIntegral $ sectionTableOffset secTable +
                             x * fromIntegral (sectionEntrySize secTable)

    -- Get the name of a section
    getEntryName nameIndex = do
      let idx = fromIntegral (sectionNameIndex secTable)
      (_,nameTable) <- getEntryByIndex idx
      let bs' = LBS.drop nameIndex nameTable
      runGetOrThrow getLazyByteStringNul bs'

    action = do
      (nameIndex,bs') <- getEntryByIndex (fromIntegral i)
      name            <- getEntryName (fromIntegral nameIndex)
      return (Just $ Section name bs')

-- | Find a section from its name. Return the section contents.
--
-- We do not perform any check on the section type.
findSectionFromName :: DynFlags
                    -> ElfHeader
                    -> SectionTable
                    -> String
                    -> ByteString
                    -> IO (Maybe ByteString)
findSectionFromName dflags hdr secTable name bs =
    rec [0..sectionEntryCount secTable - 1]
  where
    -- convert the required section name into a ByteString to perform
    -- ByteString comparison instead of String comparison
    name' = B8.pack name

    -- compare recursively each section name and return the contents of
    -- the matching one, if any
    rec []     = return Nothing
    rec (x:xs) = do
      me <- readElfSectionByIndex dflags hdr secTable x bs
      case me of
        Just e | entryName e == name' -> return (Just (entryBS e))
        _                             -> rec xs

-- | Given a section name, read its contents as a ByteString.
--
-- If the section isn't found or if there is any parsing error, we return
-- Nothing
readElfSectionByName :: DynFlags
                     -> ByteString
                     -> String
                     -> IO (Maybe LBS.ByteString)

readElfSectionByName dflags bs name = action `catchIO` \_ -> do
    debugTraceMsg dflags 3 $
      text ("Unable to read ELF section \"" ++ name ++ "\"")
    return Nothing
  where
    action = runMaybeT $ do
      hdr      <- MaybeT $ readElfHeader dflags bs
      secTable <- MaybeT $ readElfSectionTable dflags hdr bs
      MaybeT $ findSectionFromName dflags hdr secTable name bs

------------------
-- NOTE SECTIONS
------------------

-- | read a Note as a ByteString
--
-- If you try to read a note from a section which does not support the Note
-- format, the parsing is likely to fail and Nothing will be returned
readElfNoteBS :: DynFlags
              -> ByteString
              -> String
              -> String
              -> IO (Maybe LBS.ByteString)

readElfNoteBS dflags bs sectionName noteId = action `catchIO`  \_ -> do
    debugTraceMsg dflags 3 $
         text ("Unable to read ELF note \"" ++ noteId ++
               "\" in section \"" ++ sectionName ++ "\"")
    return Nothing
  where
    -- align the getter on n bytes
    align n = do
      m <- bytesRead
      if m `mod` n == 0
        then return ()
        else skip 1 >> align n

    -- noteId as a bytestring
    noteId' = B8.pack noteId

    -- read notes recursively until the one with a valid identifier is found
    findNote hdr = do
      align 4
      namesz <- gw32 hdr
      descsz <- gw32 hdr
      _      <- gw32 hdr -- we don't use the note type
      name   <- if namesz == 0
                  then return LBS.empty
                  else getLazyByteStringNul
      align 4
      desc  <- if descsz == 0
                  then return LBS.empty
                  else getLazyByteString (fromIntegral descsz)
      if name == noteId'
        then return $ Just desc
        else findNote hdr

    action = runMaybeT $ do
      hdr  <- MaybeT $ readElfHeader dflags bs
      sec  <- MaybeT $ readElfSectionByName dflags bs sectionName
      MaybeT $ runGetOrThrow (findNote hdr) sec

-- | read a Note as a String
--
-- If you try to read a note from a section which does not support the Note
-- format, the parsing is likely to fail and Nothing will be returned
readElfNoteAsString :: DynFlags
                    -> FilePath
                    -> String
                    -> String
                    -> IO (Maybe String)

readElfNoteAsString dflags path sectionName noteId = action `catchIO`  \_ -> do
    debugTraceMsg dflags 3 $
         text ("Unable to read ELF note \"" ++ noteId ++
               "\" in section \"" ++ sectionName ++ "\"")
    return Nothing
  where
    action = do
      bs   <- LBS.readFile path
      note <- readElfNoteBS dflags bs sectionName noteId
      return (fmap B8.unpack note)

-- | Generate the GAS code to create a Note section
--
-- Header fields for notes are 32-bit long (see Note [ELF specification]).
--
-- It seems there is no easy way to force GNU AS to generate a 32-bit word in
-- every case. Hence we use .int directive to create them: however "The byte
-- order and bit size of the number depends on what kind of target the assembly
-- is for." (https://sourceware.org/binutils/docs/as/Int.html#Int)
--
-- If we add new target platforms, we need to check that the generated words
-- are 32-bit long, otherwise we need to use platform specific directives to
-- force 32-bit .int in asWord32.
makeElfNote :: String -> String -> Word32 -> String -> SDoc
makeElfNote sectionName noteName typ contents = hcat [
    text "\t.section ",
    text sectionName,
    text ",\"\",",
    sectionType "note",
    text "\n",

    -- note name length (+ 1 for ending \0)
    asWord32 (length noteName + 1),

    -- note contents size
    asWord32 (length contents),

    -- note type
    asWord32 typ,

    -- note name (.asciz for \0 ending string) + padding
    text "\t.asciz \"",
    text noteName,
    text "\"\n",
    text "\t.align 4\n",

    -- note contents (.ascii to avoid ending \0) + padding
    text "\t.ascii \"",
    text (escape contents),
    text "\"\n",
    text "\t.align 4\n"]
  where
    escape :: String -> String
    escape = concatMap (charToC.fromIntegral.ord)

    asWord32 :: Show a => a -> SDoc
    asWord32 x = hcat [
      text "\t.int ",
      text (show x),
      text "\n"]

------------------
-- Helpers
------------------

-- | runGet in IO monad that throws an IOException on failure
runGetOrThrow :: Get a -> LBS.ByteString -> IO a
runGetOrThrow g bs = case runGetOrFail g bs of
  Left _        -> fail "Error while reading file"
  Right (_,_,a) -> return a


{-
(c) The AQUA Project, Glasgow University, 1994-1998

\section[ErrsUtils]{Utilities for error reporting}
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RecordWildCards #-}

module ErrUtils (
        -- * Basic types
        Validity(..), andValid, allValid, isValid, getInvalids, orValid,
        Severity(..),

        -- * Messages
        ErrMsg, errMsgDoc, errMsgSeverity, errMsgReason,
        ErrDoc, errDoc, errDocImportant, errDocContext, errDocSupplementary,
        WarnMsg, MsgDoc,
        Messages, ErrorMessages, WarningMessages,
        unionMessages,
        errMsgSpan, errMsgContext,
        errorsFound, isEmptyMessages,
        isWarnMsgFatal,
        warningsToMessages,

        -- ** Formatting
        pprMessageBag, pprErrMsgBagWithLoc,
        pprLocErrMsg, printBagOfErrors,
        formatErrDoc,

        -- ** Construction
        emptyMessages, mkLocMessage, mkLocMessageAnn, makeIntoWarning,
        mkErrMsg, mkPlainErrMsg, mkErrDoc, mkLongErrMsg, mkWarnMsg,
        mkPlainWarnMsg,
        mkLongWarnMsg,

        -- * Utilities
        doIfSet, doIfSet_dyn,
        getCaretDiagnostic,

        -- * Dump files
        dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_printer,
        mkDumpDoc, dumpSDoc, dumpSDocForUser,
        dumpSDocWithStyle,

        -- * Issuing messages during compilation
        putMsg, printInfoForUser, printOutputForUser,
        logInfo, logOutput,
        errorMsg, warningMsg,
        fatalErrorMsg, fatalErrorMsg'',
        compilationProgressMsg,
        showPass, withTiming,
        debugTraceMsg,
        ghcExit,
        prettyPrintGhcErrors,
        traceCmd
    ) where

#include "HsVersions.h"

import GhcPrelude

import Bag
import Exception
import Outputable
import Panic
import qualified PprColour as Col
import SrcLoc
import DynFlags
import FastString (unpackFS)
import StringBuffer (atLine, hGetStringBuffer, len, lexemeToString)
import Json

import System.Directory
import System.Exit      ( ExitCode(..), exitWith )
import System.FilePath  ( takeDirectory, (</>) )
import Data.List
import qualified Data.Set as Set
import Data.IORef
import Data.Maybe       ( fromMaybe )
import Data.Ord
import Data.Time
import Control.Monad
import Control.Monad.IO.Class
import System.IO
import System.IO.Error  ( catchIOError )
import GHC.Conc         ( getAllocationCounter )
import System.CPUTime

-------------------------
type MsgDoc  = SDoc

-------------------------
data Validity
  = IsValid            -- ^ Everything is fine
  | NotValid MsgDoc    -- ^ A problem, and some indication of why

isValid :: Validity -> Bool
isValid IsValid       = True
isValid (NotValid {}) = False

andValid :: Validity -> Validity -> Validity
andValid IsValid v = v
andValid v _       = v

-- | If they aren't all valid, return the first
allValid :: [Validity] -> Validity
allValid []       = IsValid
allValid (v : vs) = v `andValid` allValid vs

getInvalids :: [Validity] -> [MsgDoc]
getInvalids vs = [d | NotValid d <- vs]

orValid :: Validity -> Validity -> Validity
orValid IsValid _ = IsValid
orValid _       v = v

-- -----------------------------------------------------------------------------
-- Basic error messages: just render a message with a source location.

type Messages        = (WarningMessages, ErrorMessages)
type WarningMessages = Bag WarnMsg
type ErrorMessages   = Bag ErrMsg

unionMessages :: Messages -> Messages -> Messages
unionMessages (warns1, errs1) (warns2, errs2) =
  (warns1 `unionBags` warns2, errs1 `unionBags` errs2)

data ErrMsg = ErrMsg {
        errMsgSpan        :: SrcSpan,
        errMsgContext     :: PrintUnqualified,
        errMsgDoc         :: ErrDoc,
        -- | This has the same text as errDocImportant . errMsgDoc.
        errMsgShortString :: String,
        errMsgSeverity    :: Severity,
        errMsgReason      :: WarnReason
        }
        -- The SrcSpan is used for sorting errors into line-number order

-- | Categorise error msgs by their importance.  This is so each section can
-- be rendered visually distinct.  See Note [Error report] for where these come
-- from.
data ErrDoc = ErrDoc {
        -- | Primary error msg.
        errDocImportant     :: [MsgDoc],
        -- | Context e.g. \"In the second argument of ...\".
        errDocContext       :: [MsgDoc],
        -- | Supplementary information, e.g. \"Relevant bindings include ...\".
        errDocSupplementary :: [MsgDoc]
        }

errDoc :: [MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc
errDoc = ErrDoc

type WarnMsg = ErrMsg

data Severity
  = SevOutput
  | SevFatal
  | SevInteractive

  | SevDump
    -- ^ Log message intended for compiler developers
    -- No file/line/column stuff

  | SevInfo
    -- ^ Log messages intended for end users.
    -- No file/line/column stuff.

  | SevWarning
  | SevError
    -- ^ SevWarning and SevError are used for warnings and errors
    --   o The message has a file/line/column heading,
    --     plus "warning:" or "error:",
    --     added by mkLocMessags
    --   o Output is intended for end users
  deriving Show

instance ToJson Severity where
  json s = JSString (show s)

instance Show ErrMsg where
    show em = errMsgShortString em

pprMessageBag :: Bag MsgDoc -> SDoc
pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))

-- | Make an unannotated error message with location info.
mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc
mkLocMessage = mkLocMessageAnn Nothing

-- | Make a possibly annotated error message with location info.
mkLocMessageAnn
  :: Maybe String                       -- ^ optional annotation
  -> Severity                           -- ^ severity
  -> SrcSpan                            -- ^ location
  -> MsgDoc                             -- ^ message
  -> MsgDoc
  -- Always print the location, even if it is unhelpful.  Error messages
  -- are supposed to be in a standard format, and one without a location
  -- would look strange.  Better to say explicitly "<no location info>".
mkLocMessageAnn ann severity locn msg
    = sdocWithDynFlags $ \dflags ->
      let locn' = if gopt Opt_ErrorSpans dflags
                  then ppr locn
                  else ppr (srcSpanStart locn)

          sevColour = getSeverityColour severity (colScheme dflags)

          -- Add optional information
          optAnn = case ann of
            Nothing -> text ""
            Just i  -> text " [" <> coloured sevColour (text i) <> text "]"

          -- Add prefixes, like    Foo.hs:34: warning:
          --                           <the warning message>
          header = locn' <> colon <+>
                   coloured sevColour sevText <> optAnn

      in coloured (Col.sMessage (colScheme dflags))
                  (hang (coloured (Col.sHeader (colScheme dflags)) header) 4
                        msg)

  where
    sevText =
      case severity of
        SevWarning -> text "warning:"
        SevError   -> text "error:"
        SevFatal   -> text "fatal:"
        _          -> empty

getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour
getSeverityColour SevWarning = Col.sWarning
getSeverityColour SevError   = Col.sError
getSeverityColour SevFatal   = Col.sFatal
getSeverityColour _          = const mempty

getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc
getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty
getCaretDiagnostic severity (RealSrcSpan span) = do
  caretDiagnostic <$> getSrcLine (srcSpanFile span) row

  where
    getSrcLine fn i =
      getLine i (unpackFS fn)
        `catchIOError` \_ ->
          pure Nothing

    getLine i fn = do
      -- StringBuffer has advantages over readFile:
      -- (a) no lazy IO, otherwise IO exceptions may occur in pure code
      -- (b) always UTF-8, rather than some system-dependent encoding
      --     (Haskell source code must be UTF-8 anyway)
      content <- hGetStringBuffer fn
      case atLine i content of
        Just at_line -> pure $
          case lines (fix <$> lexemeToString at_line (len at_line)) of
            srcLine : _ -> Just srcLine
            _           -> Nothing
        _ -> pure Nothing

    -- allow user to visibly see that their code is incorrectly encoded
    -- (StringBuffer.nextChar uses \0 to represent undecodable characters)
    fix '\0' = '\xfffd'
    fix c    = c

    row = srcSpanStartLine span
    rowStr = show row
    multiline = row /= srcSpanEndLine span

    caretDiagnostic Nothing = empty
    caretDiagnostic (Just srcLineWithNewline) =
      sdocWithDynFlags $ \ dflags ->
      let sevColour = getSeverityColour severity (colScheme dflags)
          marginColour = Col.sMargin (colScheme dflags)
      in
      coloured marginColour (text marginSpace) <>
      text ("\n") <>
      coloured marginColour (text marginRow) <>
      text (" " ++ srcLinePre) <>
      coloured sevColour (text srcLineSpan) <>
      text (srcLinePost ++ "\n") <>
      coloured marginColour (text marginSpace) <>
      coloured sevColour (text (" " ++ caretLine))

      where

        -- expand tabs in a device-independent manner #13664
        expandTabs tabWidth i s =
          case s of
            ""        -> ""
            '\t' : cs -> replicate effectiveWidth ' ' ++
                         expandTabs tabWidth (i + effectiveWidth) cs
            c    : cs -> c : expandTabs tabWidth (i + 1) cs
          where effectiveWidth = tabWidth - i `mod` tabWidth

        srcLine = filter (/= '\n') (expandTabs 8 0 srcLineWithNewline)

        start = srcSpanStartCol span - 1
        end | multiline = length srcLine
            | otherwise = srcSpanEndCol span - 1
        width = max 1 (end - start)

        marginWidth = length rowStr
        marginSpace = replicate marginWidth ' ' ++ " |"
        marginRow   = rowStr ++ " |"

        (srcLinePre,  srcLineRest) = splitAt start srcLine
        (srcLineSpan, srcLinePost) = splitAt width srcLineRest

        caretEllipsis | multiline = "..."
                      | otherwise = ""
        caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis

makeIntoWarning :: WarnReason -> ErrMsg -> ErrMsg
makeIntoWarning reason err = err
    { errMsgSeverity = SevWarning
    , errMsgReason = reason }

-- -----------------------------------------------------------------------------
-- Collecting up messages for later ordering and printing.

mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
mk_err_msg dflags sev locn print_unqual doc
 = ErrMsg { errMsgSpan = locn
          , errMsgContext = print_unqual
          , errMsgDoc = doc
          , errMsgShortString = showSDoc dflags (vcat (errDocImportant doc))
          , errMsgSeverity = sev
          , errMsgReason = NoReason }

mkErrDoc :: DynFlags -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
mkErrDoc dflags = mk_err_msg dflags SevError

mkLongErrMsg, mkLongWarnMsg   :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg
-- ^ A long (multi-line) error message
mkErrMsg, mkWarnMsg           :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc            -> ErrMsg
-- ^ A short (one-line) error message
mkPlainErrMsg, mkPlainWarnMsg :: DynFlags -> SrcSpan ->                     MsgDoc            -> ErrMsg
-- ^ Variant that doesn't care about qualified/unqualified names

mkLongErrMsg   dflags locn unqual msg extra = mk_err_msg dflags SevError   locn unqual        (ErrDoc [msg] [] [extra])
mkErrMsg       dflags locn unqual msg       = mk_err_msg dflags SevError   locn unqual        (ErrDoc [msg] [] [])
mkPlainErrMsg  dflags locn        msg       = mk_err_msg dflags SevError   locn alwaysQualify (ErrDoc [msg] [] [])
mkLongWarnMsg  dflags locn unqual msg extra = mk_err_msg dflags SevWarning locn unqual        (ErrDoc [msg] [] [extra])
mkWarnMsg      dflags locn unqual msg       = mk_err_msg dflags SevWarning locn unqual        (ErrDoc [msg] [] [])
mkPlainWarnMsg dflags locn        msg       = mk_err_msg dflags SevWarning locn alwaysQualify (ErrDoc [msg] [] [])

----------------
emptyMessages :: Messages
emptyMessages = (emptyBag, emptyBag)

isEmptyMessages :: Messages -> Bool
isEmptyMessages (warns, errs) = isEmptyBag warns && isEmptyBag errs

errorsFound :: DynFlags -> Messages -> Bool
errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)

warningsToMessages :: DynFlags -> WarningMessages -> Messages
warningsToMessages dflags =
  partitionBagWith $ \warn ->
    case isWarnMsgFatal dflags warn of
      Nothing -> Left warn
      Just err_reason ->
        Right warn{ errMsgSeverity = SevError
                  , errMsgReason = ErrReason err_reason }

printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
printBagOfErrors dflags bag_of_errors
  = sequence_ [ let style = mkErrStyle dflags unqual
                in putLogMsg dflags reason sev s style (formatErrDoc dflags doc)
              | ErrMsg { errMsgSpan      = s,
                         errMsgDoc       = doc,
                         errMsgSeverity  = sev,
                         errMsgReason    = reason,
                         errMsgContext   = unqual } <- sortMsgBag (Just dflags)
                                                                  bag_of_errors ]

formatErrDoc :: DynFlags -> ErrDoc -> SDoc
formatErrDoc dflags (ErrDoc important context supplementary)
  = case msgs of
        [msg] -> vcat msg
        _ -> vcat $ map starred msgs
    where
    msgs = filter (not . null) $ map (filter (not . Outputable.isEmpty dflags))
        [important, context, supplementary]
    starred = (bullet<+>) . vcat

pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc]
pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag Nothing bag ]

pprLocErrMsg :: ErrMsg -> SDoc
pprLocErrMsg (ErrMsg { errMsgSpan      = s
                     , errMsgDoc       = doc
                     , errMsgSeverity  = sev
                     , errMsgContext   = unqual })
  = sdocWithDynFlags $ \dflags ->
    withPprStyle (mkErrStyle dflags unqual) $
    mkLocMessage sev s (formatErrDoc dflags doc)

sortMsgBag :: Maybe DynFlags -> Bag ErrMsg -> [ErrMsg]
sortMsgBag dflags = maybeLimit . sortBy (maybeFlip cmp) . bagToList
  where maybeFlip :: (a -> a -> b) -> (a -> a -> b)
        maybeFlip
          | fromMaybe False (fmap reverseErrors dflags) = flip
          | otherwise                                   = id
        cmp = comparing errMsgSpan
        maybeLimit = case join (fmap maxErrors dflags) of
          Nothing        -> id
          Just err_limit -> take err_limit

ghcExit :: DynFlags -> Int -> IO ()
ghcExit dflags val
  | val == 0  = exitWith ExitSuccess
  | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n")
                   exitWith (ExitFailure val)

doIfSet :: Bool -> IO () -> IO ()
doIfSet flag action | flag      = action
                    | otherwise = return ()

doIfSet_dyn :: DynFlags -> GeneralFlag -> IO () -> IO()
doIfSet_dyn dflags flag action | gopt flag dflags = action
                               | otherwise        = return ()

-- -----------------------------------------------------------------------------
-- Dumping

dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO ()
dumpIfSet dflags flag hdr doc
  | not flag   = return ()
  | otherwise  = putLogMsg  dflags
                            NoReason
                            SevDump
                            noSrcSpan
                            (defaultDumpStyle dflags)
                            (mkDumpDoc hdr doc)

-- | a wrapper around 'dumpSDoc'.
-- First check whether the dump flag is set
-- Do nothing if it is unset
dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn dflags flag hdr doc
  = when (dopt flag dflags) $ dumpSDoc dflags alwaysQualify flag hdr doc

-- | a wrapper around 'dumpSDoc'.
-- First check whether the dump flag is set
-- Do nothing if it is unset
--
-- Unlike 'dumpIfSet_dyn',
-- has a printer argument but no header argument
dumpIfSet_dyn_printer :: PrintUnqualified
                      -> DynFlags -> DumpFlag -> SDoc -> IO ()
dumpIfSet_dyn_printer printer dflags flag doc
  = when (dopt flag dflags) $ dumpSDoc dflags printer flag "" doc

mkDumpDoc :: String -> SDoc -> SDoc
mkDumpDoc hdr doc
   = vcat [blankLine,
           line <+> text hdr <+> line,
           doc,
           blankLine]
     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

dumpSDoc, dumpSDocForUser
  :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO ()

-- | A wrapper around 'dumpSDocWithStyle' which uses 'PprDump' style.
dumpSDoc dflags print_unqual
  = dumpSDocWithStyle dump_style dflags
  where dump_style = mkDumpStyle dflags print_unqual

-- | A wrapper around 'dumpSDocWithStyle' which uses 'PprUser' style.
dumpSDocForUser dflags print_unqual
  = dumpSDocWithStyle user_style dflags
  where user_style = mkUserStyle dflags print_unqual AllTheWay

-- | Write out a dump.
-- If --dump-to-file is set then this goes to a file.
-- otherwise emit to stdout.
--
-- When @hdr@ is empty, we print in a more compact format (no separators and
-- blank lines)
--
-- 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
dumpSDocWithStyle :: PprStyle -> DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpSDocWithStyle sty dflags flag hdr doc =
    withDumpFileHandle dflags flag writeDump
  where
    -- write dump to file
    writeDump (Just handle) = do
        doc' <- if null hdr
                then return doc
                else do t <- getCurrentTime
                        let timeStamp = if (gopt Opt_SuppressTimestamps dflags)
                                          then empty
                                          else text (show t)
                        let d = timeStamp
                                $$ blankLine
                                $$ doc
                        return $ mkDumpDoc hdr d
        defaultLogActionHPrintDoc dflags handle doc' sty

    -- 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 sty doc'

-- | Choose where to put a dump file based on DynFlags
--
chooseDumpFile :: DynFlags -> DumpFlag -> Maybe FilePath
chooseDumpFile dflags flag

        | gopt Opt_DumpToFile dflags || flag == Opt_D_th_dec_file
        , Just prefix <- getPrefix
        = Just $ setDir (prefix ++ (beautifyDumpName flag))

        | otherwise
        = Nothing

        where getPrefix
                 -- dump file location is being forced
                 --      by the --ddump-file-prefix flag.
               | Just prefix <- dumpPrefixForce dflags
                  = Just prefix
                 -- dump file location chosen by DriverPipeline.runPipeline
               | Just prefix <- dumpPrefix dflags
                  = Just prefix
                 -- we haven't got a place to put a dump file.
               | otherwise
                  = Nothing
              setDir f = case dumpDir dflags of
                         Just d  -> d </> f
                         Nothing ->       f

-- | Build a nice file name from name of a 'DumpFlag' constructor
beautifyDumpName :: DumpFlag -> String
beautifyDumpName Opt_D_th_dec_file = "th.hs"
beautifyDumpName flag
 = let str = show flag
       suff = case stripPrefix "Opt_D_" str of
              Just x -> x
              Nothing -> panic ("Bad flag name: " ++ str)
       dash = map (\c -> if c == '_' then '-' else c) suff
   in dash

-- -----------------------------------------------------------------------------
-- Outputting messages from the compiler

-- We want all messages to go through one place, so that we can
-- redirect them if necessary.  For example, when GHC is used as a
-- library we might want to catch all messages that GHC tries to
-- output and do something else with them.

ifVerbose :: DynFlags -> Int -> IO () -> IO ()
ifVerbose dflags val act
  | verbosity dflags >= val = act
  | otherwise               = return ()

errorMsg :: DynFlags -> MsgDoc -> IO ()
errorMsg dflags msg
   = putLogMsg dflags NoReason SevError noSrcSpan (defaultErrStyle dflags) msg

warningMsg :: DynFlags -> MsgDoc -> IO ()
warningMsg dflags msg
   = putLogMsg dflags NoReason SevWarning noSrcSpan (defaultErrStyle dflags) msg

fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
fatalErrorMsg dflags msg =
    putLogMsg dflags NoReason SevFatal noSrcSpan (defaultErrStyle dflags) msg

fatalErrorMsg'' :: FatalMessager -> String -> IO ()
fatalErrorMsg'' fm msg = fm msg

compilationProgressMsg :: DynFlags -> String -> IO ()
compilationProgressMsg dflags msg
  = ifVerbose dflags 1 $
    logOutput dflags (defaultUserStyle dflags) (text msg)

showPass :: DynFlags -> String -> IO ()
showPass dflags what
  = ifVerbose dflags 2 $
    logInfo dflags (defaultUserStyle dflags) (text "***" <+> text what <> colon)

-- | Time a compilation phase.
--
-- When timings are enabled (e.g. with the @-v2@ flag), the allocations
-- and CPU time used by the phase will be reported to stderr. Consider
-- a typical usage: @withTiming getDynFlags (text "simplify") force pass@.
-- When timings are enabled the following costs are included in the
-- produced accounting,
--
--  - The cost of executing @pass@ to a result @r@ in WHNF
--  - The cost of evaluating @force r@ to WHNF (e.g. @()@)
--
-- The choice of the @force@ function depends upon the amount of forcing
-- desired; the goal here is to ensure that the cost of evaluating the result
-- is, to the greatest extent possible, included in the accounting provided by
-- 'withTiming'. Often the pass already sufficiently forces its result during
-- construction; in this case @const ()@ is a reasonable choice.
-- In other cases, it is necessary to evaluate the result to normal form, in
-- which case something like @Control.DeepSeq.rnf@ is appropriate.
--
-- To avoid adversely affecting compiler performance when timings are not
-- requested, the result is only forced when timings are enabled.
withTiming :: MonadIO m
           => m DynFlags  -- ^ A means of getting a 'DynFlags' (often
                          -- 'getDynFlags' will work here)
           -> SDoc        -- ^ The name of the phase
           -> (a -> ())   -- ^ A function to force the result
                          -- (often either @const ()@ or 'rnf')
           -> m a         -- ^ The body of the phase to be timed
           -> m a
withTiming getDFlags what force_result action
  = do dflags <- getDFlags
       if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags
          then do liftIO $ logInfo dflags (defaultUserStyle dflags)
                         $ text "***" <+> what <> colon
                  alloc0 <- liftIO getAllocationCounter
                  start <- liftIO getCPUTime
                  !r <- action
                  () <- pure $ force_result r
                  end <- liftIO getCPUTime
                  alloc1 <- liftIO getAllocationCounter
                  -- recall that allocation counter counts down
                  let alloc = alloc0 - alloc1
                      time = realToFrac (end - start) * 1e-9

                  when (verbosity dflags >= 2)
                      $ liftIO $ logInfo dflags (defaultUserStyle dflags)
                          (text "!!!" <+> what <> colon <+> text "finished in"
                           <+> doublePrec 2 time
                           <+> text "milliseconds"
                           <> comma
                           <+> text "allocated"
                           <+> doublePrec 3 (realToFrac alloc / 1024 / 1024)
                           <+> text "megabytes")

                  liftIO $ dumpIfSet_dyn dflags Opt_D_dump_timings ""
                      $ text $ showSDocOneLine dflags
                      $ hsep [ what <> colon
                             , text "alloc=" <> ppr alloc
                             , text "time=" <> doublePrec 3 time
                             ]
                  pure r
           else action

debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
debugTraceMsg dflags val msg = ifVerbose dflags val $
                               logInfo dflags (defaultDumpStyle dflags) msg
putMsg :: DynFlags -> MsgDoc -> IO ()
putMsg dflags msg = logInfo dflags (defaultUserStyle dflags) msg

printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
printInfoForUser dflags print_unqual msg
  = logInfo dflags (mkUserStyle dflags print_unqual AllTheWay) msg

printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
printOutputForUser dflags print_unqual msg
  = logOutput dflags (mkUserStyle dflags print_unqual AllTheWay) msg

logInfo :: DynFlags -> PprStyle -> MsgDoc -> IO ()
logInfo dflags sty msg
  = putLogMsg dflags NoReason SevInfo noSrcSpan sty msg

logOutput :: DynFlags -> PprStyle -> MsgDoc -> IO ()
-- ^ Like 'logInfo' but with 'SevOutput' rather then 'SevInfo'
logOutput dflags sty msg
  = putLogMsg dflags NoReason SevOutput noSrcSpan sty msg

prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a
prettyPrintGhcErrors dflags
    = ghandle $ \e -> case e of
                      PprPanic str doc ->
                          pprDebugAndThen dflags panic (text str) doc
                      PprSorry str doc ->
                          pprDebugAndThen dflags sorry (text str) doc
                      PprProgramError str doc ->
                          pprDebugAndThen dflags pgmError (text str) doc
                      _ ->
                          liftIO $ throwIO e

-- | Checks if given 'WarnMsg' is a fatal warning.
isWarnMsgFatal :: DynFlags -> WarnMsg -> Maybe (Maybe WarningFlag)
isWarnMsgFatal dflags ErrMsg{errMsgReason = Reason wflag}
  = if wopt_fatal wflag dflags
      then Just (Just wflag)
      else Nothing
isWarnMsgFatal dflags _
  = if gopt Opt_WarnIsError dflags
      then Just Nothing
      else Nothing

traceCmd :: DynFlags -> String -> String -> IO a -> IO a
-- trace the command (at two levels of verbosity)
traceCmd dflags phase_name cmd_line action
 = do   { let verb = verbosity dflags
        ; showPass dflags phase_name
        ; debugTraceMsg dflags 3 (text cmd_line)
        ; case flushErr dflags of
              FlushErr io -> io

           -- And run it!
        ; action `catchIO` handle_exn verb
        }
  where
    handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
                              ; debugTraceMsg dflags 2
                                (text "Failed:"
                                 <+> text cmd_line
                                 <+> text (show exn))
                              ; throwGhcExceptionIO (ProgramError (show exn))}


{-# LANGUAGE CPP #-}
module FileCleanup
  ( TempFileLifetime(..)
  , cleanTempDirs, cleanTempFiles, cleanCurrentModuleTempFiles
  , addFilesToClean, changeTempFilesLifetime
  , newTempName, newTempLibName, newTempDir
  , withSystemTempDirectory, withTempDirectory
  ) where

import GhcPrelude

import DynFlags
import ErrUtils
import Outputable
import Util
import Exception
import DriverPhases

import Control.Monad
import Data.List
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.IORef
import System.Directory
import System.FilePath
import System.IO.Error

#if !defined(mingw32_HOST_OS)
import qualified System.Posix.Internals
#endif

-- | Used when a temp file is created. This determines which component Set of
-- FilesToClean will get the temp file
data TempFileLifetime
  = TFL_CurrentModule
  -- ^ A file with lifetime TFL_CurrentModule will be cleaned up at the
  -- end of upweep_mod
  | TFL_GhcSession
  -- ^ A file with lifetime TFL_GhcSession will be cleaned up at the end of
  -- runGhc(T)
  deriving (Show)

cleanTempDirs :: DynFlags -> IO ()
cleanTempDirs dflags
   = unless (gopt Opt_KeepTmpFiles dflags)
   $ mask_
   $ do let ref = dirsToClean dflags
        ds <- atomicModifyIORef' ref $ \ds -> (Map.empty, ds)
        removeTmpDirs dflags (Map.elems ds)

-- | Delete all files in @filesToClean dflags@.
cleanTempFiles :: DynFlags -> IO ()
cleanTempFiles dflags
   = unless (gopt Opt_KeepTmpFiles dflags)
   $ mask_
   $ do let ref = filesToClean dflags
        to_delete <- atomicModifyIORef' ref $
            \FilesToClean
                { ftcCurrentModule = cm_files
                , ftcGhcSession = gs_files
                } -> ( emptyFilesToClean
                     , Set.toList cm_files ++ Set.toList gs_files)
        removeTmpFiles dflags to_delete

-- | Delete all files in @filesToClean dflags@. That have lifetime
-- TFL_CurrentModule.
-- If a file must be cleaned eventually, but must survive a
-- cleanCurrentModuleTempFiles, ensure it has lifetime TFL_GhcSession.
cleanCurrentModuleTempFiles :: DynFlags -> IO ()
cleanCurrentModuleTempFiles dflags
   = unless (gopt Opt_KeepTmpFiles dflags)
   $ mask_
   $ do let ref = filesToClean dflags
        to_delete <- atomicModifyIORef' ref $
            \ftc@FilesToClean{ftcCurrentModule = cm_files} ->
                (ftc {ftcCurrentModule = Set.empty}, Set.toList cm_files)
        removeTmpFiles dflags to_delete

-- | Ensure that new_files are cleaned on the next call of
-- 'cleanTempFiles' or 'cleanCurrentModuleTempFiles', depending on lifetime.
-- If any of new_files are already tracked, they will have their lifetime
-- updated.
addFilesToClean :: DynFlags -> TempFileLifetime -> [FilePath] -> IO ()
addFilesToClean dflags lifetime new_files = modifyIORef' (filesToClean dflags) $
  \FilesToClean
    { ftcCurrentModule = cm_files
    , ftcGhcSession = gs_files
    } -> case lifetime of
      TFL_CurrentModule -> FilesToClean
        { ftcCurrentModule = cm_files `Set.union` new_files_set
        , ftcGhcSession = gs_files `Set.difference` new_files_set
        }
      TFL_GhcSession -> FilesToClean
        { ftcCurrentModule = cm_files `Set.difference` new_files_set
        , ftcGhcSession = gs_files `Set.union` new_files_set
        }
  where
    new_files_set = Set.fromList new_files

-- | Update the lifetime of files already being tracked. If any files are
-- not being tracked they will be discarded.
changeTempFilesLifetime :: DynFlags -> TempFileLifetime -> [FilePath] -> IO ()
changeTempFilesLifetime dflags lifetime files = do
  FilesToClean
    { ftcCurrentModule = cm_files
    , ftcGhcSession = gs_files
    } <- readIORef (filesToClean dflags)
  let old_set = case lifetime of
        TFL_CurrentModule -> gs_files
        TFL_GhcSession -> cm_files
      existing_files = [f | f <- files, f `Set.member` old_set]
  addFilesToClean dflags lifetime existing_files

-- Return a unique numeric temp file suffix
newTempSuffix :: DynFlags -> IO Int
newTempSuffix dflags =
  atomicModifyIORef' (nextTempSuffix dflags) $ \n -> (n+1,n)

-- Find a temporary name that doesn't already exist.
newTempName :: DynFlags -> TempFileLifetime -> Suffix -> IO FilePath
newTempName dflags lifetime extn
  = do d <- getTempDir dflags
       findTempName (d </> "ghc_") -- See Note [Deterministic base name]
  where
    findTempName :: FilePath -> IO FilePath
    findTempName prefix
      = do n <- newTempSuffix dflags
           let filename = prefix ++ show n <.> extn
           b <- doesFileExist filename
           if b then findTempName prefix
                else do -- clean it up later
                        addFilesToClean dflags lifetime [filename]
                        return filename

newTempDir :: DynFlags -> IO FilePath
newTempDir dflags
  = do d <- getTempDir dflags
       findTempDir (d </> "ghc_")
  where
    findTempDir :: FilePath -> IO FilePath
    findTempDir prefix
      = do n <- newTempSuffix dflags
           let filename = prefix ++ show n
           b <- doesDirectoryExist filename
           if b then findTempDir prefix
                else do createDirectory filename
                        -- see mkTempDir below; this is wrong: -> consIORef (dirsToClean dflags) filename
                        return filename

newTempLibName :: DynFlags -> TempFileLifetime -> Suffix
  -> IO (FilePath, FilePath, String)
newTempLibName dflags lifetime extn
  = do d <- getTempDir dflags
       findTempName d ("ghc_")
  where
    findTempName :: FilePath -> String -> IO (FilePath, FilePath, String)
    findTempName dir prefix
      = do n <- newTempSuffix dflags -- See Note [Deterministic base name]
           let libname = prefix ++ show n
               filename = dir </> "lib" ++ libname <.> extn
           b <- doesFileExist filename
           if b then findTempName dir prefix
                else do -- clean it up later
                        addFilesToClean dflags lifetime [filename]
                        return (filename, dir, libname)

-- Return our temporary directory within tmp_dir, creating one if we
-- don't have one yet.
getTempDir :: DynFlags -> IO FilePath
getTempDir dflags = do
    mapping <- readIORef dir_ref
    case Map.lookup tmp_dir mapping of
        Nothing -> do
            pid <- getProcessID
            let prefix = tmp_dir </> "ghc" ++ show pid ++ "_"
            mask_ $ mkTempDir prefix
        Just dir -> return dir
  where
    tmp_dir = tmpDir dflags
    dir_ref = dirsToClean dflags

    mkTempDir :: FilePath -> IO FilePath
    mkTempDir prefix = do
        n <- newTempSuffix dflags
        let our_dir = prefix ++ show n

        -- 1. Speculatively create our new directory.
        createDirectory our_dir

        -- 2. Update the dirsToClean mapping unless an entry already exists
        -- (i.e. unless another thread beat us to it).
        their_dir <- atomicModifyIORef' dir_ref $ \mapping ->
            case Map.lookup tmp_dir mapping of
                Just dir -> (mapping, Just dir)
                Nothing  -> (Map.insert tmp_dir our_dir mapping, Nothing)

        -- 3. If there was an existing entry, return it and delete the
        -- directory we created.  Otherwise return the directory we created.
        case their_dir of
            Nothing  -> do
                debugTraceMsg dflags 2 $
                    text "Created temporary directory:" <+> text our_dir
                return our_dir
            Just dir -> do
                removeDirectory our_dir
                return dir
      `catchIO` \e -> if isAlreadyExistsError e
                      then mkTempDir prefix else ioError e

{- Note [Deterministic base name]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

The filename of temporary files, especially the basename of C files, can end
up in the output in some form, e.g. as part of linker debug information. In the
interest of bit-wise exactly reproducible compilation (#4012), the basename of
the temporary file no longer contains random information (it used to contain
the process id).

This is ok, as the temporary directory used contains the pid (see getTempDir).
-}
removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
removeTmpDirs dflags ds
  = traceCmd dflags "Deleting temp dirs"
             ("Deleting: " ++ unwords ds)
             (mapM_ (removeWith dflags removeDirectory) ds)

removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
removeTmpFiles dflags fs
  = warnNon $
    traceCmd dflags "Deleting temp files"
             ("Deleting: " ++ unwords deletees)
             (mapM_ (removeWith dflags removeFile) deletees)
  where
     -- Flat out refuse to delete files that are likely to be source input
     -- files (is there a worse bug than having a compiler delete your source
     -- files?)
     --
     -- Deleting source files is a sign of a bug elsewhere, so prominently flag
     -- the condition.
    warnNon act
     | null non_deletees = act
     | otherwise         = do
        putMsg dflags (text "WARNING - NOT deleting source files:"
                       <+> hsep (map text non_deletees))
        act

    (non_deletees, deletees) = partition isHaskellUserSrcFilename fs

removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
removeWith dflags remover f = remover f `catchIO`
  (\e ->
   let msg = if isDoesNotExistError e
             then text "Warning: deleting non-existent" <+> text f
             else text "Warning: exception raised when deleting"
                                            <+> text f <> colon
               $$ text (show e)
   in debugTraceMsg dflags 2 msg
  )

#if defined(mingw32_HOST_OS)
-- relies on Int == Int32 on Windows
foreign import ccall unsafe "_getpid" getProcessID :: IO Int
#else
getProcessID :: IO Int
getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
#endif

-- The following three functions are from the `temporary` package.

-- | Create and use a temporary directory in the system standard temporary
-- directory.
--
-- Behaves exactly the same as 'withTempDirectory', except that the parent
-- temporary directory will be that returned by 'getTemporaryDirectory'.
withSystemTempDirectory :: String   -- ^ Directory name template. See 'openTempFile'.
                        -> (FilePath -> IO a) -- ^ Callback that can use the directory
                        -> IO a
withSystemTempDirectory template action =
  getTemporaryDirectory >>= \tmpDir -> withTempDirectory tmpDir template action

-- | Create and use a temporary directory.
--
-- Creates a new temporary directory inside the given directory, making use
-- of the template. The temp directory is deleted after use. For example:
--
-- > withTempDirectory "src" "sdist." $ \tmpDir -> do ...
--
-- The @tmpDir@ will be a new subdirectory of the given directory, e.g.
-- @src/sdist.342@.
withTempDirectory :: FilePath -- ^ Temp directory to create the directory in
                  -> String   -- ^ Directory name template. See 'openTempFile'.
                  -> (FilePath -> IO a) -- ^ Callback that can use the directory
                  -> IO a
withTempDirectory targetDir template =
  Exception.bracket
    (createTempDirectory targetDir template)
    (ignoringIOErrors . removeDirectoryRecursive)

ignoringIOErrors :: IO () -> IO ()
ignoringIOErrors ioe = ioe `catch` (\e -> const (return ()) (e :: IOError))

createTempDirectory :: FilePath -> String -> IO FilePath
createTempDirectory dir template = do
  pid <- getProcessID
  findTempName pid
  where findTempName x = do
            let path = dir </> template ++ show x
            createDirectory path
            return path
          `catchIO` \e -> if isAlreadyExistsError e
                          then findTempName (x+1) else ioError e


{-
(c) The University of Glasgow, 2000-2006

\section[Finder]{Module Finder}
-}

{-# LANGUAGE CPP #-}

module Finder (
    flushFinderCaches,
    FindResult(..),
    findImportedModule,
    findPluginModule,
    findExactModule,
    findHomeModule,
    findExposedPackageModule,
    mkHomeModLocation,
    mkHomeModLocation2,
    mkHiOnlyModLocation,
    mkHiPath,
    mkObjPath,
    addHomeModuleToFinder,
    uncacheModule,
    mkStubPaths,

    findObjectLinkableMaybe,
    findObjectLinkable,

    cannotFindModule,
    cannotFindInterface,

  ) where

#include "HsVersions.h"

import GhcPrelude

import Module
import HscTypes
import Packages
import FastString
import Util
import PrelNames        ( gHC_PRIM )
import DynFlags
import Outputable
import Maybes           ( expectJust )

import Data.IORef       ( IORef, readIORef, atomicModifyIORef' )
import System.Directory
import System.FilePath
import Control.Monad
import Data.Time

type FileExt = String   -- Filename extension
type BaseName = String  -- Basename of file

-- -----------------------------------------------------------------------------
-- The Finder

-- The Finder provides a thin filesystem abstraction to the rest of
-- the compiler.  For a given module, it can tell you where the
-- source, interface, and object files for that module live.

-- It does *not* know which particular package a module lives in.  Use
-- Packages.lookupModuleInAllPackages for that.

-- -----------------------------------------------------------------------------
-- The finder's cache

-- remove all the home modules from the cache; package modules are
-- assumed to not move around during a session.
flushFinderCaches :: HscEnv -> IO ()
flushFinderCaches hsc_env =
  atomicModifyIORef' fc_ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ())
 where
        this_pkg = thisPackage (hsc_dflags hsc_env)
        fc_ref = hsc_FC hsc_env
        is_ext mod _ | not (installedModuleUnitId mod `installedUnitIdEq` this_pkg) = True
                     | otherwise = False

addToFinderCache :: IORef FinderCache -> InstalledModule -> InstalledFindResult -> IO ()
addToFinderCache ref key val =
  atomicModifyIORef' ref $ \c -> (extendInstalledModuleEnv c key val, ())

removeFromFinderCache :: IORef FinderCache -> InstalledModule -> IO ()
removeFromFinderCache ref key =
  atomicModifyIORef' ref $ \c -> (delInstalledModuleEnv c key, ())

lookupFinderCache :: IORef FinderCache -> InstalledModule -> IO (Maybe InstalledFindResult)
lookupFinderCache ref key = do
   c <- readIORef ref
   return $! lookupInstalledModuleEnv c key

-- -----------------------------------------------------------------------------
-- The three external entry points

-- | Locate a module that was imported by the user.  We have the
-- module's name, and possibly a package name.  Without a package
-- name, this function will use the search path and the known exposed
-- packages to find the module, if a package is specified then only
-- that package is searched for the module.

findImportedModule :: HscEnv -> ModuleName -> Maybe FastString -> IO FindResult
findImportedModule hsc_env mod_name mb_pkg =
  case mb_pkg of
        Nothing                        -> unqual_import
        Just pkg | pkg == fsLit "this" -> home_import -- "this" is special
                 | otherwise           -> pkg_import
  where
    home_import   = findHomeModule hsc_env mod_name

    pkg_import    = findExposedPackageModule hsc_env mod_name mb_pkg

    unqual_import = home_import
                    `orIfNotFound`
                    findExposedPackageModule hsc_env mod_name Nothing

-- | Locate a plugin module requested by the user, for a compiler
-- plugin.  This consults the same set of exposed packages as
-- 'findImportedModule', unless @-hide-all-plugin-packages@ or
-- @-plugin-package@ are specified.
findPluginModule :: HscEnv -> ModuleName -> IO FindResult
findPluginModule hsc_env mod_name =
  findHomeModule hsc_env mod_name
  `orIfNotFound`
  findExposedPluginPackageModule hsc_env mod_name

-- | Locate a specific 'Module'.  The purpose of this function is to
-- create a 'ModLocation' for a given 'Module', that is to find out
-- where the files associated with this module live.  It is used when
-- reading the interface for a module mentioned by another interface,
-- for example (a "system import").

findExactModule :: HscEnv -> InstalledModule -> IO InstalledFindResult
findExactModule hsc_env mod =
    let dflags = hsc_dflags hsc_env
    in if installedModuleUnitId mod `installedUnitIdEq` thisPackage dflags
       then findInstalledHomeModule hsc_env (installedModuleName mod)
       else findPackageModule hsc_env mod

-- -----------------------------------------------------------------------------
-- Helpers

-- | Given a monadic actions @this@ and @or_this@, first execute
-- @this@.  If the returned 'FindResult' is successful, return
-- it; otherwise, execute @or_this@.  If both failed, this function
-- also combines their failure messages in a reasonable way.
orIfNotFound :: Monad m => m FindResult -> m FindResult -> m FindResult
orIfNotFound this or_this = do
  res <- this
  case res of
    NotFound { fr_paths = paths1, fr_mods_hidden = mh1
             , fr_pkgs_hidden = ph1, fr_unusables = u1, fr_suggestions = s1 }
     -> do res2 <- or_this
           case res2 of
             NotFound { fr_paths = paths2, fr_pkg = mb_pkg2, fr_mods_hidden = mh2
                      , fr_pkgs_hidden = ph2, fr_unusables = u2
                      , fr_suggestions = s2 }
              -> return (NotFound { fr_paths = paths1 ++ paths2
                                  , fr_pkg = mb_pkg2 -- snd arg is the package search
                                  , fr_mods_hidden = mh1 ++ mh2
                                  , fr_pkgs_hidden = ph1 ++ ph2
                                  , fr_unusables = u1 ++ u2
                                  , fr_suggestions = s1  ++ s2 })
             _other -> return res2
    _other -> return res

-- | Helper function for 'findHomeModule': this function wraps an IO action
-- which would look up @mod_name@ in the file system (the home package),
-- and first consults the 'hsc_FC' cache to see if the lookup has already
-- been done.  Otherwise, do the lookup (with the IO action) and save
-- the result in the finder cache and the module location cache (if it
-- was successful.)
homeSearchCache :: HscEnv -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult
homeSearchCache hsc_env mod_name do_this = do
  let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name
  modLocationCache hsc_env mod do_this

findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString
                         -> IO FindResult
findExposedPackageModule hsc_env mod_name mb_pkg
  = findLookupResult hsc_env
  $ lookupModuleWithSuggestions
        (hsc_dflags hsc_env) mod_name mb_pkg

findExposedPluginPackageModule :: HscEnv -> ModuleName
                               -> IO FindResult
findExposedPluginPackageModule hsc_env mod_name
  = findLookupResult hsc_env
  $ lookupPluginModuleWithSuggestions
        (hsc_dflags hsc_env) mod_name Nothing

findLookupResult :: HscEnv -> LookupResult -> IO FindResult
findLookupResult hsc_env r = case r of
     LookupFound m pkg_conf -> do
       let im = fst (splitModuleInsts m)
       r' <- findPackageModule_ hsc_env im pkg_conf
       case r' of
        -- TODO: ghc -M is unlikely to do the right thing
        -- with just the location of the thing that was
        -- instantiated; you probably also need all of the
        -- implicit locations from the instances
        InstalledFound loc   _ -> return (Found loc m)
        InstalledNoPackage   _ -> return (NoPackage (moduleUnitId m))
        InstalledNotFound fp _ -> return (NotFound{ fr_paths = fp, fr_pkg = Just (moduleUnitId m)
                                         , fr_pkgs_hidden = []
                                         , fr_mods_hidden = []
                                         , fr_unusables = []
                                         , fr_suggestions = []})
     LookupMultiple rs ->
       return (FoundMultiple rs)
     LookupHidden pkg_hiddens mod_hiddens ->
       return (NotFound{ fr_paths = [], fr_pkg = Nothing
                       , fr_pkgs_hidden = map (moduleUnitId.fst) pkg_hiddens
                       , fr_mods_hidden = map (moduleUnitId.fst) mod_hiddens
                       , fr_unusables = []
                       , fr_suggestions = [] })
     LookupUnusable unusable ->
       let unusables' = map get_unusable unusable
           get_unusable (m, ModUnusable r) = (moduleUnitId m, r)
           get_unusable (_, r)             =
             pprPanic "findLookupResult: unexpected origin" (ppr r)
       in return (NotFound{ fr_paths = [], fr_pkg = Nothing
                          , fr_pkgs_hidden = []
                          , fr_mods_hidden = []
                          , fr_unusables = unusables'
                          , fr_suggestions = [] })
     LookupNotFound suggest ->
       return (NotFound{ fr_paths = [], fr_pkg = Nothing
                       , fr_pkgs_hidden = []
                       , fr_mods_hidden = []
                       , fr_unusables = []
                       , fr_suggestions = suggest })

modLocationCache :: HscEnv -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult
modLocationCache hsc_env mod do_this = do
  m <- lookupFinderCache (hsc_FC hsc_env) mod
  case m of
    Just result -> return result
    Nothing     -> do
        result <- do_this
        addToFinderCache (hsc_FC hsc_env) mod result
        return result

mkHomeInstalledModule :: DynFlags -> ModuleName -> InstalledModule
mkHomeInstalledModule dflags mod_name =
  let iuid = fst (splitUnitIdInsts (thisPackage dflags))
  in InstalledModule iuid mod_name

-- This returns a module because it's more convenient for users
addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module
addHomeModuleToFinder hsc_env mod_name loc = do
  let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name
  addToFinderCache (hsc_FC hsc_env) mod (InstalledFound loc mod)
  return (mkModule (thisPackage (hsc_dflags hsc_env)) mod_name)

uncacheModule :: HscEnv -> ModuleName -> IO ()
uncacheModule hsc_env mod_name = do
  let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name
  removeFromFinderCache (hsc_FC hsc_env) mod

-- -----------------------------------------------------------------------------
--      The internal workers

findHomeModule :: HscEnv -> ModuleName -> IO FindResult
findHomeModule hsc_env mod_name = do
  r <- findInstalledHomeModule hsc_env mod_name
  return $ case r of
    InstalledFound loc _ -> Found loc (mkModule uid mod_name)
    InstalledNoPackage _ -> NoPackage uid -- impossible
    InstalledNotFound fps _ -> NotFound {
        fr_paths = fps,
        fr_pkg = Just uid,
        fr_mods_hidden = [],
        fr_pkgs_hidden = [],
        fr_unusables = [],
        fr_suggestions = []
      }
 where
  dflags = hsc_dflags hsc_env
  uid = thisPackage dflags

-- | Implements the search for a module name in the home package only.  Calling
-- this function directly is usually *not* what you want; currently, it's used
-- as a building block for the following operations:
--
--  1. When you do a normal package lookup, we first check if the module
--  is available in the home module, before looking it up in the package
--  database.
--
--  2. When you have a package qualified import with package name "this",
--  we shortcut to the home module.
--
--  3. When we look up an exact 'Module', if the unit id associated with
--  the module is the current home module do a look up in the home module.
--
--  4. Some special-case code in GHCi (ToDo: Figure out why that needs to
--  call this.)
findInstalledHomeModule :: HscEnv -> ModuleName -> IO InstalledFindResult
findInstalledHomeModule hsc_env mod_name =
   homeSearchCache hsc_env mod_name $
   let
     dflags = hsc_dflags hsc_env
     home_path = importPaths dflags
     hisuf = hiSuf dflags
     mod = mkHomeInstalledModule dflags mod_name

     source_exts =
      [ ("hs",   mkHomeModLocationSearched dflags mod_name "hs")
      , ("lhs",  mkHomeModLocationSearched dflags mod_name "lhs")
      , ("hsig",  mkHomeModLocationSearched dflags mod_name "hsig")
      , ("lhsig",  mkHomeModLocationSearched dflags mod_name "lhsig")
      ]

     hi_exts = [ (hisuf,                mkHiOnlyModLocation dflags hisuf)
               , (addBootSuffix hisuf,  mkHiOnlyModLocation dflags hisuf)
               ]

        -- In compilation manager modes, we look for source files in the home
        -- package because we can compile these automatically.  In one-shot
        -- compilation mode we look for .hi and .hi-boot files only.
     exts | isOneShot (ghcMode dflags) = hi_exts
          | otherwise                  = source_exts
   in

  -- special case for GHC.Prim; we won't find it in the filesystem.
  -- This is important only when compiling the base package (where GHC.Prim
  -- is a home module).
  if mod `installedModuleEq` gHC_PRIM
        then return (InstalledFound (error "GHC.Prim ModLocation") mod)
        else searchPathExts home_path mod exts

-- | Search for a module in external packages only.
findPackageModule :: HscEnv -> InstalledModule -> IO InstalledFindResult
findPackageModule hsc_env mod = do
  let
        dflags = hsc_dflags hsc_env
        pkg_id = installedModuleUnitId mod
  --
  case lookupInstalledPackage dflags pkg_id of
     Nothing -> return (InstalledNoPackage pkg_id)
     Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf

-- | Look up the interface file associated with module @mod@.  This function
-- requires a few invariants to be upheld: (1) the 'Module' in question must
-- be the module identifier of the *original* implementation of a module,
-- not a reexport (this invariant is upheld by @Packages.hs@) and (2)
-- the 'PackageConfig' must be consistent with the unit id in the 'Module'.
-- The redundancy is to avoid an extra lookup in the package state
-- for the appropriate config.
findPackageModule_ :: HscEnv -> InstalledModule -> PackageConfig -> IO InstalledFindResult
findPackageModule_ hsc_env mod pkg_conf =
  ASSERT2( installedModuleUnitId mod == installedPackageConfigId pkg_conf, ppr (installedModuleUnitId mod) <+> ppr (installedPackageConfigId pkg_conf) )
  modLocationCache hsc_env mod $

  -- special case for GHC.Prim; we won't find it in the filesystem.
  if mod `installedModuleEq` gHC_PRIM
        then return (InstalledFound (error "GHC.Prim ModLocation") mod)
        else

  let
     dflags = hsc_dflags hsc_env
     tag = buildTag dflags

           -- hi-suffix for packages depends on the build tag.
     package_hisuf | null tag  = "hi"
                   | otherwise = tag ++ "_hi"

     mk_hi_loc = mkHiOnlyModLocation dflags package_hisuf

     import_dirs = importDirs pkg_conf
      -- we never look for a .hi-boot file in an external package;
      -- .hi-boot files only make sense for the home package.
  in
  case import_dirs of
    [one] | MkDepend <- ghcMode dflags -> do
          -- there's only one place that this .hi file can be, so
          -- don't bother looking for it.
          let basename = moduleNameSlashes (installedModuleName mod)
          loc <- mk_hi_loc one basename
          return (InstalledFound loc mod)
    _otherwise ->
          searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)]

-- -----------------------------------------------------------------------------
-- General path searching

searchPathExts
  :: [FilePath]         -- paths to search
  -> InstalledModule             -- module name
  -> [ (
        FileExt,                                -- suffix
        FilePath -> BaseName -> IO ModLocation  -- action
       )
     ]
  -> IO InstalledFindResult

searchPathExts paths mod exts
   = do result <- search to_search
{-
        hPutStrLn stderr (showSDoc $
                vcat [text "Search" <+> ppr mod <+> sep (map (text. fst) exts)
                    , nest 2 (vcat (map text paths))
                    , case result of
                        Succeeded (loc, p) -> text "Found" <+> ppr loc
                        Failed fs          -> text "not found"])
-}
        return result

  where
    basename = moduleNameSlashes (installedModuleName mod)

    to_search :: [(FilePath, IO ModLocation)]
    to_search = [ (file, fn path basename)
                | path <- paths,
                  (ext,fn) <- exts,
                  let base | path == "." = basename
                           | otherwise   = path </> basename
                      file = base <.> ext
                ]

    search [] = return (InstalledNotFound (map fst to_search) (Just (installedModuleUnitId mod)))

    search ((file, mk_result) : rest) = do
      b <- doesFileExist file
      if b
        then do { loc <- mk_result; return (InstalledFound loc mod) }
        else search rest

mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt
                          -> FilePath -> BaseName -> IO ModLocation
mkHomeModLocationSearched dflags mod suff path basename = do
   mkHomeModLocation2 dflags mod (path </> basename) suff

-- -----------------------------------------------------------------------------
-- Constructing a home module location

-- This is where we construct the ModLocation for a module in the home
-- package, for which we have a source file.  It is called from three
-- places:
--
--  (a) Here in the finder, when we are searching for a module to import,
--      using the search path (-i option).
--
--  (b) The compilation manager, when constructing the ModLocation for
--      a "root" module (a source file named explicitly on the command line
--      or in a :load command in GHCi).
--
--  (c) The driver in one-shot mode, when we need to construct a
--      ModLocation for a source file named on the command-line.
--
-- Parameters are:
--
-- mod
--      The name of the module
--
-- path
--      (a): The search path component where the source file was found.
--      (b) and (c): "."
--
-- src_basename
--      (a): (moduleNameSlashes mod)
--      (b) and (c): The filename of the source file, minus its extension
--
-- ext
--      The filename extension of the source file (usually "hs" or "lhs").

mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO ModLocation
mkHomeModLocation dflags mod src_filename = do
   let (basename,extension) = splitExtension src_filename
   mkHomeModLocation2 dflags mod basename extension

mkHomeModLocation2 :: DynFlags
                   -> ModuleName
                   -> FilePath  -- Of source module, without suffix
                   -> String    -- Suffix
                   -> IO ModLocation
mkHomeModLocation2 dflags mod src_basename ext = do
   let mod_basename = moduleNameSlashes mod

       obj_fn = mkObjPath  dflags src_basename mod_basename
       hi_fn  = mkHiPath   dflags src_basename mod_basename
       hie_fn = mkHiePath  dflags src_basename mod_basename

   return (ModLocation{ ml_hs_file   = Just (src_basename <.> ext),
                        ml_hi_file   = hi_fn,
                        ml_obj_file  = obj_fn,
                        ml_hie_file  = hie_fn })

mkHiOnlyModLocation :: DynFlags -> Suffix -> FilePath -> String
                    -> IO ModLocation
mkHiOnlyModLocation dflags hisuf path basename
 = do let full_basename = path </> basename
          obj_fn = mkObjPath  dflags full_basename basename
          hie_fn = mkHiePath  dflags full_basename basename
      return ModLocation{    ml_hs_file   = Nothing,
                             ml_hi_file   = full_basename <.> hisuf,
                                -- Remove the .hi-boot suffix from
                                -- hi_file, if it had one.  We always
                                -- want the name of the real .hi file
                                -- in the ml_hi_file field.
                             ml_obj_file  = obj_fn,
                             ml_hie_file  = hie_fn
                  }

-- | Constructs the filename of a .o file for a given source file.
-- Does /not/ check whether the .o file exists
mkObjPath
  :: DynFlags
  -> FilePath           -- the filename of the source file, minus the extension
  -> String             -- the module name with dots replaced by slashes
  -> FilePath
mkObjPath dflags basename mod_basename = obj_basename <.> osuf
  where
                odir = objectDir dflags
                osuf = objectSuf dflags

                obj_basename | Just dir <- odir = dir </> mod_basename
                             | otherwise        = basename

-- | Constructs the filename of a .hi file for a given source file.
-- Does /not/ check whether the .hi file exists
mkHiPath
  :: DynFlags
  -> FilePath           -- the filename of the source file, minus the extension
  -> String             -- the module name with dots replaced by slashes
  -> FilePath
mkHiPath dflags basename mod_basename = hi_basename <.> hisuf
 where
                hidir = hiDir dflags
                hisuf = hiSuf dflags

                hi_basename | Just dir <- hidir = dir </> mod_basename
                            | otherwise         = basename

-- | Constructs the filename of a .hie file for a given source file.
-- Does /not/ check whether the .hie file exists
mkHiePath
  :: DynFlags
  -> FilePath           -- the filename of the source file, minus the extension
  -> String             -- the module name with dots replaced by slashes
  -> FilePath
mkHiePath dflags basename mod_basename = hie_basename <.> hiesuf
 where
                hiedir = hieDir dflags
                hiesuf = hieSuf dflags

                hie_basename | Just dir <- hiedir = dir </> mod_basename
                             | otherwise          = basename

-- -----------------------------------------------------------------------------
-- Filenames of the stub files

-- We don't have to store these in ModLocations, because they can be derived
-- from other available information, and they're only rarely needed.

mkStubPaths
  :: DynFlags
  -> ModuleName
  -> ModLocation
  -> FilePath

mkStubPaths dflags mod location
  = let
        stubdir = stubDir dflags

        mod_basename = moduleNameSlashes mod
        src_basename = dropExtension $ expectJust "mkStubPaths"
                                                  (ml_hs_file location)

        stub_basename0
            | Just dir <- stubdir = dir </> mod_basename
            | otherwise           = src_basename

        stub_basename = stub_basename0 ++ "_stub"
     in
        stub_basename <.> "h"

-- -----------------------------------------------------------------------------
-- findLinkable isn't related to the other stuff in here,
-- but there's no other obvious place for it

findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable)
findObjectLinkableMaybe mod locn
   = do let obj_fn = ml_obj_file locn
        maybe_obj_time <- modificationTimeIfExists obj_fn
        case maybe_obj_time of
          Nothing -> return Nothing
          Just obj_time -> liftM Just (findObjectLinkable mod obj_fn obj_time)

-- Make an object linkable when we know the object file exists, and we know
-- its modification time.
findObjectLinkable :: Module -> FilePath -> UTCTime -> IO Linkable
findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn])
  -- We used to look for _stub.o files here, but that was a bug (#706)
  -- Now GHC merges the stub.o into the main .o (#3687)

-- -----------------------------------------------------------------------------
-- Error messages

cannotFindModule :: DynFlags -> ModuleName -> FindResult -> SDoc
cannotFindModule flags mod res =
  cantFindErr (sLit cannotFindMsg)
              (sLit "Ambiguous module name")
              flags mod res
  where
    cannotFindMsg =
      case res of
        NotFound { fr_mods_hidden = hidden_mods
                 , fr_pkgs_hidden = hidden_pkgs
                 , fr_unusables = unusables }
          | not (null hidden_mods && null hidden_pkgs && null unusables)
          -> "Could not load module"
        _ -> "Could not find module"

cannotFindInterface  :: DynFlags -> ModuleName -> InstalledFindResult -> SDoc
cannotFindInterface = cantFindInstalledErr (sLit "Failed to load interface for")
                                           (sLit "Ambiguous interface for")

cantFindErr :: PtrString -> PtrString -> DynFlags -> ModuleName -> FindResult
            -> SDoc
cantFindErr _ multiple_found _ mod_name (FoundMultiple mods)
  | Just pkgs <- unambiguousPackages
  = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 (
       sep [text "it was found in multiple packages:",
                hsep (map ppr pkgs) ]
    )
  | otherwise
  = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 (
       vcat (map pprMod mods)
    )
  where
    unambiguousPackages = foldl' unambiguousPackage (Just []) mods
    unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _)
        = Just (moduleUnitId m : xs)
    unambiguousPackage _ _ = Nothing

    pprMod (m, o) = text "it is bound as" <+> ppr m <+>
                                text "by" <+> pprOrigin m o
    pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden"
    pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable"
    pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma (
      if e == Just True
          then [text "package" <+> ppr (moduleUnitId m)]
          else [] ++
      map ((text "a reexport in package" <+>)
                .ppr.packageConfigId) res ++
      if f then [text "a package flag"] else []
      )

cantFindErr cannot_find _ dflags mod_name find_result
  = ptext cannot_find <+> quotes (ppr mod_name)
    $$ more_info
  where
    more_info
      = case find_result of
            NoPackage pkg
                -> text "no unit id matching" <+> quotes (ppr pkg) <+>
                   text "was found"

            NotFound { fr_paths = files, fr_pkg = mb_pkg
                     , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens
                     , fr_unusables = unusables, fr_suggestions = suggest }
                | Just pkg <- mb_pkg, pkg /= thisPackage dflags
                -> not_found_in_package pkg files

                | not (null suggest)
                -> pp_suggestions suggest $$ tried_these files dflags

                | null files && null mod_hiddens &&
                  null pkg_hiddens && null unusables
                -> text "It is not a module in the current program, or in any known package."

                | otherwise
                -> vcat (map pkg_hidden pkg_hiddens) $$
                   vcat (map mod_hidden mod_hiddens) $$
                   vcat (map unusable unusables) $$
                   tried_these files dflags

            _ -> panic "cantFindErr"

    build_tag = buildTag dflags

    not_found_in_package pkg files
       | build_tag /= ""
       = let
            build = if build_tag == "p" then "profiling"
                                        else "\"" ++ build_tag ++ "\""
         in
         text "Perhaps you haven't installed the " <> text build <>
         text " libraries for package " <> quotes (ppr pkg) <> char '?' $$
         tried_these files dflags

       | otherwise
       = text "There are files missing in the " <> quotes (ppr pkg) <>
         text " package," $$
         text "try running 'ghc-pkg check'." $$
         tried_these files dflags

    pkg_hidden :: UnitId -> SDoc
    pkg_hidden pkgid =
        text "It is a member of the hidden package"
        <+> quotes (ppr pkgid)
        --FIXME: we don't really want to show the unit id here we should
        -- show the source package id or installed package id if it's ambiguous
        <> dot $$ pkg_hidden_hint pkgid
    pkg_hidden_hint pkgid
     | gopt Opt_BuildingCabalPackage dflags
        = let pkg = expectJust "pkg_hidden" (lookupPackage dflags pkgid)
           in text "Perhaps you need to add" <+>
              quotes (ppr (packageName pkg)) <+>
              text "to the build-depends in your .cabal file."
     | Just pkg <- lookupPackage dflags pkgid
         = text "You can run" <+>
           quotes (text ":set -package " <> ppr (packageName pkg)) <+>
           text "to expose it." $$
           text "(Note: this unloads all the modules in the current scope.)"
     | otherwise = Outputable.empty

    mod_hidden pkg =
        text "it is a hidden module in the package" <+> quotes (ppr pkg)

    unusable (pkg, reason)
      = text "It is a member of the package"
      <+> quotes (ppr pkg)
      $$ pprReason (text "which is") reason

    pp_suggestions :: [ModuleSuggestion] -> SDoc
    pp_suggestions sugs
      | null sugs = Outputable.empty
      | otherwise = hang (text "Perhaps you meant")
                       2 (vcat (map pp_sugg sugs))

    -- NB: Prefer the *original* location, and then reexports, and then
    -- package flags when making suggestions.  ToDo: if the original package
    -- also has a reexport, prefer that one
    pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o
      where provenance ModHidden = Outputable.empty
            provenance (ModUnusable _) = Outputable.empty
            provenance (ModOrigin{ fromOrigPackage = e,
                                   fromExposedReexport = res,
                                   fromPackageFlag = f })
              | Just True <- e
                 = parens (text "from" <+> ppr (moduleUnitId mod))
              | f && moduleName mod == m
                 = parens (text "from" <+> ppr (moduleUnitId mod))
              | (pkg:_) <- res
                 = parens (text "from" <+> ppr (packageConfigId pkg)
                    <> comma <+> text "reexporting" <+> ppr mod)
              | f
                 = parens (text "defined via package flags to be"
                    <+> ppr mod)
              | otherwise = Outputable.empty
    pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o
      where provenance ModHidden =  Outputable.empty
            provenance (ModUnusable _) = Outputable.empty
            provenance (ModOrigin{ fromOrigPackage = e,
                                   fromHiddenReexport = rhs })
              | Just False <- e
                 = parens (text "needs flag -package-key"
                    <+> ppr (moduleUnitId mod))
              | (pkg:_) <- rhs
                 = parens (text "needs flag -package-id"
                    <+> ppr (packageConfigId pkg))
              | otherwise = Outputable.empty

cantFindInstalledErr :: PtrString -> PtrString -> DynFlags -> ModuleName
                     -> InstalledFindResult -> SDoc
cantFindInstalledErr cannot_find _ dflags mod_name find_result
  = ptext cannot_find <+> quotes (ppr mod_name)
    $$ more_info
  where
    more_info
      = case find_result of
            InstalledNoPackage pkg
                -> text "no unit id matching" <+> quotes (ppr pkg) <+>
                   text "was found" $$ looks_like_srcpkgid pkg

            InstalledNotFound files mb_pkg
                | Just pkg <- mb_pkg, not (pkg `installedUnitIdEq` thisPackage dflags)
                -> not_found_in_package pkg files

                | null files
                -> text "It is not a module in the current program, or in any known package."

                | otherwise
                -> tried_these files dflags

            _ -> panic "cantFindInstalledErr"

    build_tag = buildTag dflags

    looks_like_srcpkgid :: InstalledUnitId -> SDoc
    looks_like_srcpkgid pk
     -- Unsafely coerce a unit id FastString into a source package ID
     -- FastString and see if it means anything.
     | (pkg:pkgs) <- searchPackageId dflags (SourcePackageId (installedUnitIdFS pk))
     = parens (text "This unit ID looks like the source package ID;" $$
       text "the real unit ID is" <+> quotes (ftext (installedUnitIdFS (unitId pkg))) $$
       (if null pkgs then Outputable.empty
        else text "and" <+> int (length pkgs) <+> text "other candidates"))
     -- Todo: also check if it looks like a package name!
     | otherwise = Outputable.empty

    not_found_in_package pkg files
       | build_tag /= ""
       = let
            build = if build_tag == "p" then "profiling"
                                        else "\"" ++ build_tag ++ "\""
         in
         text "Perhaps you haven't installed the " <> text build <>
         text " libraries for package " <> quotes (ppr pkg) <> char '?' $$
         tried_these files dflags

       | otherwise
       = text "There are files missing in the " <> quotes (ppr pkg) <>
         text " package," $$
         text "try running 'ghc-pkg check'." $$
         tried_these files dflags

tried_these :: [FilePath] -> DynFlags -> SDoc
tried_these files dflags
    | null files = Outputable.empty
    | verbosity dflags < 3 =
          text "Use -v (or `:set -v` in ghci) " <>
              text "to see a list of the files searched for."
    | otherwise =
          hang (text "Locations searched:") 2 $ vcat (map text files)