{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE TupleSections #-}
module GHC.Driver.Session.Units (initMake, initMulti) where

-- The official GHC API
import qualified GHC
import GHC              (parseTargetFiles, Ghc, GhcMonad(..))

import GHC.Driver.Env
import GHC.Driver.Errors
import GHC.Driver.Errors.Types
import GHC.Driver.Phases
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Driver.Pipeline  ( oneShot, compileFile )
import GHC.Driver.Config.Diagnostic

import GHC.Unit.Env
import GHC.Unit (UnitId)
import GHC.Unit.Home.PackageTable
import qualified GHC.Unit.Home.Graph as HUG
import GHC.Unit.State  ( emptyUnitState )
import qualified GHC.Unit.State as State

import GHC.Types.SrcLoc
import GHC.Types.SourceError

import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Monad       ( liftIO, mapMaybeM )
import GHC.Data.Maybe

import System.IO
import System.Exit
import System.FilePath
import Control.Monad
import Data.List ( partition, (\\) )
import qualified Data.Set as Set
import Prelude
import GHC.ResponseFile (expandResponse)
import Data.Bifunctor
import GHC.Data.Graph.Directed
import qualified Data.List.NonEmpty as NE

-- Strip out any ["+RTS", ..., "-RTS"] sequences in the command string list.
removeRTS :: [String] -> [String]
removeRTS :: [String] -> [String]
removeRTS (String
"+RTS" : [String]
xs)  =
  case (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"-RTS") [String]
xs of
    [] -> []
    (String
_ : [String]
ys) -> [String] -> [String]
removeRTS [String]
ys
removeRTS (String
y:[String]
ys)         = String
y String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String] -> [String]
removeRTS [String]
ys
removeRTS []             = []

initMake :: [(String,Maybe Phase)] -> Ghc [(String, Maybe Phase)]
initMake :: [(String, Maybe Phase)] -> Ghc [(String, Maybe Phase)]
initMake [(String, Maybe Phase)]
srcs  = do
    let ([(String, Maybe Phase)]
hs_srcs, [(String, Maybe Phase)]
non_hs_srcs) = ((String, Maybe Phase) -> Bool)
-> [(String, Maybe Phase)]
-> ([(String, Maybe Phase)], [(String, Maybe Phase)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (String, Maybe Phase) -> Bool
isHaskellishTarget [(String, Maybe Phase)]
srcs

    hsc_env <- Ghc HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
GHC.getSession

    -- if we have no haskell sources from which to do a dependency
    -- analysis, then just do one-shot compilation and/or linking.
    -- This means that "ghc Foo.o Bar.o -o baz" links the program as
    -- we expect.
    if (null hs_srcs)
       then liftIO (oneShot hsc_env NoStop srcs) >> return []
       else do

    o_files <- mapMaybeM (\(String, Maybe Phase)
x -> IO (Maybe String) -> Ghc (Maybe String)
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> Ghc (Maybe String))
-> IO (Maybe String) -> Ghc (Maybe String)
forall a b. (a -> b) -> a -> b
$ HscEnv -> StopPhase -> (String, Maybe Phase) -> IO (Maybe String)
compileFile HscEnv
hsc_env StopPhase
NoStop (String, Maybe Phase)
x)
                 non_hs_srcs
    dflags <- GHC.getSessionDynFlags
    let dflags' = DynFlags
dflags { ldInputs = map (FileOption "") o_files
                                      ++ ldInputs dflags }
    _ <- GHC.setSessionDynFlags dflags'
    return hs_srcs

initMulti :: NE.NonEmpty String
          -> (DynFlags -> [(String,Maybe Phase)] -> [String] -> [String] -> IO ())
          -- ^ Function to lint initMulti DynFlags and sources.
          -- In GHC, this is instanced to @checkOptions@.
          -> Ghc ([(String, Maybe UnitId, Maybe Phase)])
initMulti :: NonEmpty String
-> (DynFlags
    -> [(String, Maybe Phase)] -> [String] -> [String] -> IO ())
-> Ghc [(String, Maybe UnitId, Maybe Phase)]
initMulti NonEmpty String
unitArgsFiles DynFlags
-> [(String, Maybe Phase)] -> [String] -> [String] -> IO ()
lintDynFlagsAndSrcs = do
  hsc_env <- Ghc HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
GHC.getSession
  let logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
  initial_dflags <- GHC.getSessionDynFlags

  dynFlagsAndSrcs <- forM unitArgsFiles $ \String
f -> do
    Bool -> Ghc () -> Ghc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> Int
verbosity DynFlags
initial_dflags Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2) (IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. Show a => a -> IO ()
print String
f)
    args <- IO [String] -> Ghc [String]
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> Ghc [String]) -> IO [String] -> Ghc [String]
forall a b. (a -> b) -> a -> b
$ [String] -> IO [String]
expandResponse [String
f]
    (dflags2, fileish_args, warns) <- parseDynamicFlagsCmdLine logger initial_dflags (map (mkGeneralLocated f) (removeRTS args))
    handleSourceError (\SourceError
e -> do
       SourceError -> Ghc ()
forall (m :: * -> *).
(HasLogger m, MonadIO m, HasDynFlags m) =>
SourceError -> m ()
GHC.printException SourceError
e
       IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)) $ do
         liftIO $ printOrThrowDiagnostics logger (initPrintConfig dflags2) (initDiagOpts dflags2) (GhcDriverMessage <$> warns)

    let (dflags3, srcs, objs) = parseTargetFiles dflags2 (map unLoc fileish_args)
        dflags4 = DynFlags -> DynFlags
offsetDynFlags DynFlags
dflags3

    let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs

    -- This is dubious as the whole unit environment won't be set-up correctly, but
    -- that doesn't matter for what we use it for (linking and oneShot)
    let dubious_hsc_env = HasDebugCallStack => DynFlags -> HscEnv -> HscEnv
DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
dflags4 HscEnv
hsc_env
    -- if we have no haskell sources from which to do a dependency
    -- analysis, then just do one-shot compilation and/or linking.
    -- This means that "ghc Foo.o Bar.o -o baz" links the program as
    -- we expect.
    if (null hs_srcs)
       then liftIO (oneShot dubious_hsc_env NoStop srcs) >> return (dflags4, [])
       else do

    o_files <- mapMaybeM (\(String, Maybe Phase)
x -> IO (Maybe String) -> Ghc (Maybe String)
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> Ghc (Maybe String))
-> IO (Maybe String) -> Ghc (Maybe String)
forall a b. (a -> b) -> a -> b
$ HscEnv -> StopPhase -> (String, Maybe Phase) -> IO (Maybe String)
compileFile HscEnv
dubious_hsc_env StopPhase
NoStop (String, Maybe Phase)
x)
                 non_hs_srcs
    let dflags5 = DynFlags
dflags4 { ldInputs = map (FileOption "") o_files
                                      ++ ldInputs dflags4 }

    liftIO $ lintDynFlagsAndSrcs dflags5 srcs objs []

    pure (dflags5, hs_srcs)

  let
    unitDflags = ((DynFlags, [(String, Maybe Phase)]) -> DynFlags)
-> NonEmpty (DynFlags, [(String, Maybe Phase)])
-> NonEmpty DynFlags
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (DynFlags, [(String, Maybe Phase)]) -> DynFlags
forall a b. (a, b) -> a
fst NonEmpty (DynFlags, [(String, Maybe Phase)])
dynFlagsAndSrcs
    srcs = ((DynFlags, [(String, Maybe Phase)])
 -> [(String, Maybe UnitId, Maybe Phase)])
-> NonEmpty (DynFlags, [(String, Maybe Phase)])
-> NonEmpty [(String, Maybe UnitId, Maybe Phase)]
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (\(DynFlags
dflags, [(String, Maybe Phase)]
lsrcs) -> ((String, Maybe Phase) -> (String, Maybe UnitId, Maybe Phase))
-> [(String, Maybe Phase)] -> [(String, Maybe UnitId, Maybe Phase)]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> Maybe Phase -> (String, Maybe UnitId, Maybe Phase))
-> (String, Maybe Phase) -> (String, Maybe UnitId, Maybe Phase)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (,UnitId -> Maybe UnitId
forall a. a -> Maybe a
Just (UnitId -> Maybe UnitId) -> UnitId -> Maybe UnitId
forall a b. (a -> b) -> a -> b
$ DynFlags -> UnitId
homeUnitId_ DynFlags
dflags,)) [(String, Maybe Phase)]
lsrcs) NonEmpty (DynFlags, [(String, Maybe Phase)])
dynFlagsAndSrcs
    (hs_srcs, _non_hs_srcs) = unzip (map (partition (\(String
file, Maybe UnitId
_uid, Maybe Phase
phase) -> (String, Maybe Phase) -> Bool
isHaskellishTarget (String
file, Maybe Phase
phase))) (NE.toList srcs))

  checkDuplicateUnits initial_dflags (NE.toList (NE.zip unitArgsFiles unitDflags))

  (initial_home_graph, mainUnitId) <- liftIO $ createUnitEnvFromFlags unitDflags
  let home_units = HomeUnitGraph -> Set UnitId
HUG.allUnits HomeUnitGraph
initial_home_graph

  home_unit_graph <- forM initial_home_graph $ \HomeUnitEnv
homeUnitEnv -> do
    let cached_unit_dbs :: Maybe [UnitDatabase UnitId]
cached_unit_dbs = HomeUnitEnv -> Maybe [UnitDatabase UnitId]
homeUnitEnv_unit_dbs HomeUnitEnv
homeUnitEnv
        hue_flags :: DynFlags
hue_flags = HomeUnitEnv -> DynFlags
homeUnitEnv_dflags HomeUnitEnv
homeUnitEnv
        dflags :: DynFlags
dflags = HomeUnitEnv -> DynFlags
homeUnitEnv_dflags HomeUnitEnv
homeUnitEnv
    (dbs,unit_state,home_unit,mconstants) <- IO
  ([UnitDatabase UnitId], UnitState, HomeUnit,
   Maybe PlatformConstants)
-> Ghc
     ([UnitDatabase UnitId], UnitState, HomeUnit,
      Maybe PlatformConstants)
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   ([UnitDatabase UnitId], UnitState, HomeUnit,
    Maybe PlatformConstants)
 -> Ghc
      ([UnitDatabase UnitId], UnitState, HomeUnit,
       Maybe PlatformConstants))
-> IO
     ([UnitDatabase UnitId], UnitState, HomeUnit,
      Maybe PlatformConstants)
-> Ghc
     ([UnitDatabase UnitId], UnitState, HomeUnit,
      Maybe PlatformConstants)
forall a b. (a -> b) -> a -> b
$ Logger
-> DynFlags
-> Maybe [UnitDatabase UnitId]
-> Set UnitId
-> IO
     ([UnitDatabase UnitId], UnitState, HomeUnit,
      Maybe PlatformConstants)
State.initUnits Logger
logger DynFlags
hue_flags Maybe [UnitDatabase UnitId]
cached_unit_dbs Set UnitId
home_units

    updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants
    emptyHpt <- liftIO $ emptyHomePackageTable
    pure $ HomeUnitEnv
      { homeUnitEnv_units = unit_state
      , homeUnitEnv_unit_dbs = Just dbs
      , homeUnitEnv_dflags = updated_dflags
      , homeUnitEnv_hpt = emptyHpt
      , homeUnitEnv_home_unit = Just home_unit
      }

  checkUnitCycles initial_dflags home_unit_graph

  let dflags = HomeUnitEnv -> DynFlags
homeUnitEnv_dflags (HomeUnitEnv -> DynFlags) -> HomeUnitEnv -> DynFlags
forall a b. (a -> b) -> a -> b
$ UnitId -> HomeUnitGraph -> HomeUnitEnv
forall v. UnitId -> UnitEnvGraph v -> v
HUG.unitEnv_lookup UnitId
mainUnitId HomeUnitGraph
home_unit_graph
  unitEnv <- assertUnitEnvInvariant <$> (liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags))
  let final_hsc_env = HscEnv
hsc_env { hsc_unit_env = unitEnv }

  GHC.setSession final_hsc_env

  -- if we have no haskell sources from which to do a dependency
  -- analysis, then just do one-shot compilation and/or linking.
  -- This means that "ghc Foo.o Bar.o -o baz" links the program as
  -- we expect.
  if (null hs_srcs)
      then do
        liftIO $ hPutStrLn stderr $ "Multi Mode can not be used for one-shot mode."
        liftIO $ exitWith (ExitFailure 1)
      else do

{-
  o_files <- liftIO $ mapMaybeM
                (\(src, uid, mphase) ->
                  compileFile (hscSetActiveHomeUnit (ue_unitHomeUnit (fromJust uid) unitEnv) final_hsc_env) NoStop (src, mphase)
                )
                (concat non_hs_srcs)
                -}

  -- MP: This should probably modify dflags for each unit?
  --let dflags' = dflags { ldInputs = map (FileOption "") o_files
  --                                  ++ ldInputs dflags }
  return $ concat hs_srcs

checkUnitCycles :: DynFlags -> HUG.HomeUnitGraph -> Ghc ()
checkUnitCycles :: DynFlags -> HomeUnitGraph -> Ghc ()
checkUnitCycles DynFlags
dflags HomeUnitGraph
graph = [SCC UnitId] -> Ghc ()
processSCCs (HomeUnitGraph -> [SCC UnitId]
HUG.hugSCCs HomeUnitGraph
graph)
  where

    processSCCs :: [SCC UnitId] -> Ghc ()
processSCCs [] = () -> Ghc ()
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    processSCCs (AcyclicSCC UnitId
_: [SCC UnitId]
other_sccs) = [SCC UnitId] -> Ghc ()
processSCCs [SCC UnitId]
other_sccs
    processSCCs (CyclicSCC [UnitId]
uids: [SCC UnitId]
_) = GhcException -> Ghc ()
forall a. GhcException -> a
throwGhcException (GhcException -> Ghc ()) -> GhcException -> Ghc ()
forall a b. (a -> b) -> a -> b
$ String -> GhcException
CmdLineError (String -> GhcException) -> String -> GhcException
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags ([UnitId] -> SDoc
forall {a}. Outputable a => [a] -> SDoc
cycle_err [UnitId]
uids)


    cycle_err :: [a] -> SDoc
cycle_err [a]
uids =
      SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Units form a dependency cycle:")
           Int
2
           ([a] -> SDoc
forall {a}. Outputable a => [a] -> SDoc
one_err [a]
uids)

    one_err :: [a] -> SDoc
one_err [a]
uids = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$
                    ((a -> SDoc) -> [a] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\a
uid -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"-" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
uid SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"depends on") [a]
start)
                    [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"-" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
final]
      where
        start :: [a]
start = [a] -> [a]
forall a. HasCallStack => [a] -> [a]
init [a]
uids
        final :: a
final = [a] -> a
forall a. HasCallStack => [a] -> a
last [a]
uids

-- | Check that we don't have multiple units with the same UnitId.
checkDuplicateUnits :: DynFlags -> [(FilePath, DynFlags)] -> Ghc ()
checkDuplicateUnits :: DynFlags -> [(String, DynFlags)] -> Ghc ()
checkDuplicateUnits DynFlags
dflags [(String, DynFlags)]
flags =
  Bool -> Ghc () -> Ghc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Set UnitId -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set UnitId
duplicate_ids)
         (GhcException -> Ghc ()
forall a. GhcException -> a
throwGhcException (GhcException -> Ghc ()) -> GhcException -> Ghc ()
forall a b. (a -> b) -> a -> b
$ String -> GhcException
CmdLineError (String -> GhcException) -> String -> GhcException
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags SDoc
multi_err)

  where
    uids :: [(String, UnitId)]
uids = ((String, DynFlags) -> (String, UnitId))
-> [(String, DynFlags)] -> [(String, UnitId)]
forall a b. (a -> b) -> [a] -> [b]
map ((DynFlags -> UnitId) -> (String, DynFlags) -> (String, UnitId)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second DynFlags -> UnitId
homeUnitId_) [(String, DynFlags)]
flags
    deduplicated_uids :: [(String, UnitId)]
deduplicated_uids = ((String, UnitId) -> UnitId)
-> [(String, UnitId)] -> [(String, UnitId)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
ordNubOn (String, UnitId) -> UnitId
forall a b. (a, b) -> b
snd [(String, UnitId)]
uids
    duplicate_ids :: Set UnitId
duplicate_ids = [UnitId] -> Set UnitId
forall a. Ord a => [a] -> Set a
Set.fromList (((String, UnitId) -> UnitId) -> [(String, UnitId)] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map (String, UnitId) -> UnitId
forall a b. (a, b) -> b
snd [(String, UnitId)]
uids [UnitId] -> [UnitId] -> [UnitId]
forall a. Eq a => [a] -> [a] -> [a]
\\ ((String, UnitId) -> UnitId) -> [(String, UnitId)] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map (String, UnitId) -> UnitId
forall a b. (a, b) -> b
snd [(String, UnitId)]
deduplicated_uids)

    duplicate_flags :: [(String, UnitId)]
duplicate_flags = ((String, UnitId) -> Bool)
-> [(String, UnitId)] -> [(String, UnitId)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((UnitId -> Set UnitId -> Bool) -> Set UnitId -> UnitId -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip UnitId -> Set UnitId -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Set UnitId
duplicate_ids (UnitId -> Bool)
-> ((String, UnitId) -> UnitId) -> (String, UnitId) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, UnitId) -> UnitId
forall a b. (a, b) -> b
snd) [(String, UnitId)]
uids

    one_err :: (String, a) -> SDoc
one_err (String
fp, a
home_uid) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"-" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
home_uid SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"defined in" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
fp

    multi_err :: SDoc
multi_err =
      SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Multiple units with the same unit-id:")
           Int
2
           ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat (((String, UnitId) -> SDoc) -> [(String, UnitId)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (String, UnitId) -> SDoc
forall {a}. Outputable a => (String, a) -> SDoc
one_err [(String, UnitId)]
duplicate_flags))


offsetDynFlags :: DynFlags -> DynFlags
offsetDynFlags :: DynFlags -> DynFlags
offsetDynFlags DynFlags
dflags =
  DynFlags
dflags { hiDir = c hiDir
         , objectDir  = c objectDir
         , stubDir = c stubDir
         , hieDir  = c hieDir
         , dumpDir = c dumpDir  }

  where
    c :: (DynFlags -> Maybe String) -> Maybe String
c DynFlags -> Maybe String
f = Maybe String -> Maybe String
augment_maybe (DynFlags -> Maybe String
f DynFlags
dflags)

    augment_maybe :: Maybe String -> Maybe String
augment_maybe Maybe String
Nothing = Maybe String
forall a. Maybe a
Nothing
    augment_maybe (Just String
f) = String -> Maybe String
forall a. a -> Maybe a
Just (String -> String
augment String
f)
    augment :: String -> String
augment String
f | String -> Bool
isRelative String
f, Just String
offset <- DynFlags -> Maybe String
workingDirectory DynFlags
dflags = String
offset String -> String -> String
</> String
f
              | Bool
otherwise = String
f


createUnitEnvFromFlags :: NE.NonEmpty DynFlags -> IO (HomeUnitGraph, UnitId)
createUnitEnvFromFlags :: NonEmpty DynFlags -> IO (HomeUnitGraph, UnitId)
createUnitEnvFromFlags NonEmpty DynFlags
unitDflags = do
  unitEnvList <- NonEmpty DynFlags
-> (DynFlags -> IO (UnitId, HomeUnitEnv))
-> IO (NonEmpty (UnitId, HomeUnitEnv))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM NonEmpty DynFlags
unitDflags ((DynFlags -> IO (UnitId, HomeUnitEnv))
 -> IO (NonEmpty (UnitId, HomeUnitEnv)))
-> (DynFlags -> IO (UnitId, HomeUnitEnv))
-> IO (NonEmpty (UnitId, HomeUnitEnv))
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags -> do
    emptyHpt <- IO HomePackageTable
emptyHomePackageTable
    let newInternalUnitEnv =
          UnitState
-> Maybe [UnitDatabase UnitId]
-> DynFlags
-> HomePackageTable
-> Maybe HomeUnit
-> HomeUnitEnv
HUG.mkHomeUnitEnv UnitState
emptyUnitState Maybe [UnitDatabase UnitId]
forall a. Maybe a
Nothing DynFlags
dflags HomePackageTable
emptyHpt Maybe HomeUnit
forall a. Maybe a
Nothing
    return (homeUnitId_ dflags, newInternalUnitEnv)
  let activeUnit = (UnitId, HomeUnitEnv) -> UnitId
forall a b. (a, b) -> a
fst ((UnitId, HomeUnitEnv) -> UnitId)
-> (UnitId, HomeUnitEnv) -> UnitId
forall a b. (a -> b) -> a -> b
$ NonEmpty (UnitId, HomeUnitEnv) -> (UnitId, HomeUnitEnv)
forall a. NonEmpty a -> a
NE.head NonEmpty (UnitId, HomeUnitEnv)
unitEnvList
  return (HUG.hugFromList (NE.toList unitEnvList), activeUnit)