image: nixos/nix:2.25.2

   dependencies: null

   tags:

     - x86_64-linux

   variables:

     BUILD_FLAVOUR: default

   -- * Common utility functions

   , (</>)

   , (<.>)

   )

   where

 import GHC.Utils.Panic (panic)

 import System.OsPath

 import System.Directory.Internal (os)

 -- | Decode an 'OsPath' to 'FilePath', throwing an 'error' if decoding failed.

         Nothing  -> panic "addUnit: called too early"

         Just dbs ->

          let newdb = UnitDatabase

                , unitDatabaseUnits = [u]

                }

          in return (dbs ++ [newdb]) -- added at the end because ordering matters

     env <- getBkpEnv

     src_hash <- liftIO $ getFileHash (bkp_filename env)

     let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1)

     let fc = hsc_FC hsc_env

                                 HsSrcFile  -> os "hs")

                              hsc_src

     -- This duplicates a pile of logic in GHC.Driver.Make

     -- Also copied from 'getImports'

     let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps

 import GHC.Driver.Ppr

 import GHC.Driver.Backend

 import qualified GHC.Data.ShortText as ST

 import GHC.Data.Stream           ( liftIO )

 import qualified GHC.Data.Stream as Stream

 import GHC.Types.Unique.DSM

 import GHC.Types.Unique.Supply ( UniqueTag(..) )

 import System.IO

 import Data.Set (Set)

 import qualified Data.Set as Set

         stub_h_file_exists <-

           case mkStubPaths (initFinderOpts dflags) (moduleName mod) location of

             Nothing -> pure False

                     ("#include <HsFFI.h>\n" ++ cplusplus_hdr) cplusplus_ftr

         putDumpFileMaybe logger Opt_D_dump_foreign

   | ms_hs_hash old_summary == src_hash &&

       not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do

            -- update the object-file timestamp

            -- We have to repopulate the Finder's cache for file targets

            -- because the file might not even be on the regular search path

                hsc_src = ms_hsc_src old_summary

            addModuleToFinder fc mod location hsc_src

            return $ Right

              ( old_summary

 makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary

 makeNewModSummary hsc_env MakeNewModSummary{..} = do

   let PreprocessedImports{..} = nms_preimps

   extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name

   (implicit_sigs, _inst_deps) <- implicitRequirementsShallow (hscSetActiveUnitId (moduleUnitId nms_mod) hsc_env) pi_theimps

 import GHC.Data.Bool

 import GHC.Data.EnumSet (EnumSet)

 import GHC.Data.Maybe

 import GHC.Builtin.Names ( mAIN_NAME )

 import GHC.Driver.Backend

 import GHC.Driver.Flags

 data PkgDbRef

   = GlobalPkgDb

   | UserPkgDb

   deriving Eq

       linkable $ pure $ DotGBC bco

     linkable parts = do

       time <- maybe getCurrentTime pure if_time

       return $! Linkable time (mi_module iface) parts

       linkable $ NE.singleton (DotGBC bco)

     linkable parts = do

       time <- maybe getCurrentTime pure if_time

       return $!Linkable time (mi_module iface) parts

   -- Either, get the same time as the .gbc file if it exists, or just the current time.

   -- It's important the time of the linkable matches the time of the .gbc file for recompilation

   -- checking.

   return $ mkModuleByteCodeLinkable bco_time bco_object

 mkModuleByteCode :: HscEnv -> Module -> ModLocation -> CgInteractiveGuts -> IO ModuleByteCode

   -- the object file for one module.)

   -- Note the nasty duplication with the same computation in compileFile above

   location <- mkOneShotModLocation pipe_env dflags src_flavour mod_name

   src_hash <- getFileHash (basename <.> suff)

   hi_date <- modificationTimeIfExists hi_file

   hie_date <- modificationTimeIfExists hie_file

   o_mod <- modificationTimeIfExists o_file

   dyn_o_mod <- modificationTimeIfExists dyn_o_file

   -- Tell the finder cache about this module

   mod <- do

 import GHC.Types.Unique.Set

 import Data.Word

 import System.FilePath

 import Text.ParserCombinators.ReadP hiding (char)

 import Text.ParserCombinators.ReadP as R

 package_flags_deps = [

         ------- Packages ----------------------------------------------------

     make_ord_flag defFlag "package-db"

   , make_ord_flag defFlag "clear-package-db"      (NoArg clearPkgDb)

   , make_ord_flag defFlag "no-global-package-db"  (NoArg removeGlobalPkgDb)

   , make_ord_flag defFlag "no-user-package-db"    (NoArg removeUserPkgDb)

       (NoArg (addPkgDbRef UserPkgDb))

     -- backwards compat with GHC<=7.4 :

   , make_dep_flag defFlag "package-conf"

   , make_dep_flag defFlag "no-user-package-conf"

       (NoArg removeUserPkgDb)              "Use -no-user-package-db instead"

   , make_ord_flag defGhcFlag "package-name"       (HasArg $ \name ->

 parseEnvFile envfile = mapM_ parseEntry . lines

   where

     parseEntry str = case words str of

         -- relative package dbs are interpreted relative to the env file

         where envdir = takeDirectory envfile

               db     = drop 11 str

 findBytecodeLinkableMaybe :: HscEnv -> Module -> ModLocation -> IO (Maybe Linkable)

 findBytecodeLinkableMaybe hsc_env mod locn = do

   case maybe_bytecode_time of

     Nothing -> return Nothing

     Just bytecode_time -> do

 import GHC.Fingerprint

 import Data.IORef

 import Control.Applicative ((<|>))

 import Control.Monad

 import Data.Time

 findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable)

 findObjectLinkableMaybe mod locn

    = do let obj_fn = ml_obj_file locn

         case maybe_obj_time of

           Nothing -> return Nothing

           Just obj_time -> liftM Just (findObjectLinkable mod obj_fn obj_time)

 import System.Environment ( getEnv )

 import GHC.Data.FastString

 import qualified GHC.Data.ShortText as ST

 import GHC.Utils.Logger

 import GHC.Utils.Error

 import Control.Monad

 import Data.Graph (stronglyConnComp, SCC(..))

 import Data.Char ( toUpper )

 import Data.Set (Set)

 import Data.Monoid (First(..))

 import qualified Data.Semigroup as Semigroup

   where

     offsetPackageDb :: Maybe FilePath -> PackageDBFlag -> PackageDBFlag

     offsetPackageDb _ p = p

 -- | Unit database

 data UnitDatabase unit = UnitDatabase

    , unitDatabaseUnits :: [GenUnitInfo unit]

    }

 instance Outputable u => Outputable (UnitDatabase u) where

 type UnitInfoMap = UniqMap UnitId UnitInfo

         Left _ -> system_conf_refs

         Right path

          | Just (xs, x) <- snocView path, isSearchPathSeparator x

          | otherwise

   -- Apply the package DB-related flags from the command line to get the

   -- final list of package DBs.

 -- NB: This logic is reimplemented in Cabal, so if you change it,

 -- make sure you update Cabal. (Or, better yet, dump it in the

 -- compiler info so Cabal can use the info.)

 resolveUnitDatabase cfg UserPkgDb = runMaybeT $ do

   dir <- versionedAppDir (unitConfigProgramName cfg) (unitConfigPlatformArchOS cfg)

   let pkgconf = dir </> unitConfigDBName cfg

   exist <- tryMaybeT $ doesDirectoryExist pkgconf

 resolveUnitDatabase _ (PkgDbPath name) = return $ Just name

 readUnitDatabase logger cfg conf_file = do

   proto_pkg_configs <-

     if isdir

        then readDirStyleUnitInfo conf_file

        else do

             if isfile

                then do

                  mpkgs <- tryReadOldFileStyleUnitInfo

                    Just pkgs -> return pkgs

                    Nothing   -> throwGhcExceptionIO $ InstallationError $

                       "ghc no longer supports single-file style package " ++

                       ") use 'ghc-pkg init' to create the database with " ++

                       "the correct format."

                else throwGhcExceptionIO $ InstallationError $

   let

       -- Fix #16360: remove trailing slash from conf_file before calculating pkgroot

       pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo)

                          proto_pkg_configs

   --

   return $ UnitDatabase conf_file' pkg_configs1

   where

     readDirStyleUnitInfo conf_dir = do

       if cache_exists

         then do

         else do

           -- If there is no package.cache file, we check if the database is not

           -- empty by inspecting if the directory contains any .conf file. If it

           -- does, something is wrong and we fail. Otherwise we assume that the

           -- database is empty.

           debugTraceMsg logger 2 $ text "There is no package.cache in"

                        <> text ", checking if the database is empty"

           if db_empty

             then do

               debugTraceMsg logger 3 $ text "There are no .conf files in"

                           <+> text "package database as empty"

               return []

             else

               throwGhcExceptionIO $ InstallationError $

                 " even though package database is not empty"

     -- assumes it's a file and tries to overwrite with 'writeFile'.

     -- ghc-pkg also cooperates with this workaround.

     tryReadOldFileStyleUnitInfo = do

       if take 2 content == "[]"

         then do

           if direxists

                      liftM Just (readDirStyleUnitInfo conf_dir)

              else return (Just []) -- ghc-pkg will create it when it's updated

         else return Nothing

   where

     distrust pkg = pkg{ unitIsTrusted = False }

                    -> UnitInfo -> UnitInfo

 mungeUnitInfo top_dir pkgroot =

     mungeDynLibFields

 mungeDynLibFields :: UnitInfo -> UnitInfo

 mungeDynLibFields pkg =

   where

     merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do

       debugTraceMsg logger 2 $

       forM_ (Set.toList override_set) $ \pkg ->

           debugTraceMsg logger 2 $

               text "package" <+> ppr pkg <+>

 import Control.Monad.IO.Class ( MonadIO, liftIO )

 import System.IO.Error as IO ( isDoesNotExistError )

 import System.Directory ( doesDirectoryExist, getModificationTime, renameFile )

 import System.FilePath

 import Data.Bifunctor   ( first, second )

 -- --------------------------------------------------------------

 -- check existence & modification time at the same time

 modificationTimeIfExists f =

         `catchIO` \e -> if isDoesNotExistError e

                         then return Nothing

                         else ioError e

 import Data.Word

 import System.IO        ( Handle )

 import System.FilePath

 import Text.Printf

 import Numeric (showFFloat)

 import Numeric.Natural (Natural)

 instance Outputable ModuleName where

   ppr = pprModuleName

 pprModuleName :: IsLine doc => ModuleName -> doc

 pprModuleName (ModuleName nm) =