ghc-debugger 0.3.0.0 → 0.4.0.0
raw patch · 5 files changed
+302/−66 lines, 5 filesdep ~directorydep ~hie-biosPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: directory, hie-bios
API changes (from Hackage documentation)
+ GHC.Debugger.Session: TargetDetails :: Target -> [FilePath] -> UnitId -> TargetDetails
+ GHC.Debugger.Session: TargetFile :: FilePath -> Target
+ GHC.Debugger.Session: TargetModule :: ModuleName -> Target
+ GHC.Debugger.Session: [targetLocations] :: TargetDetails -> [FilePath]
+ GHC.Debugger.Session: [targetTarget] :: TargetDetails -> Target
+ GHC.Debugger.Session: [targetUnitId] :: TargetDetails -> UnitId
+ GHC.Debugger.Session: data Target
+ GHC.Debugger.Session: data TargetDetails
+ GHC.Debugger.Session: instance GHC.Internal.Classes.Eq GHC.Debugger.Session.Target
+ GHC.Debugger.Session: instance GHC.Internal.Classes.Eq GHC.Debugger.Session.TargetDetails
+ GHC.Debugger.Session: instance GHC.Internal.Classes.Ord GHC.Debugger.Session.Target
+ GHC.Debugger.Session: instance GHC.Internal.Classes.Ord GHC.Debugger.Session.TargetDetails
+ GHC.Debugger.Session: instance GHC.Internal.Show.Show GHC.Debugger.Session.Target
+ GHC.Debugger.Session: parseHomeUnitArguments :: GhcMonad m => FilePath -> FilePath -> [String] -> [String] -> DynFlags -> FilePath -> m (NonEmpty (DynFlags, [Target]))
+ GHC.Debugger.Session: setupHomeUnitGraph :: GhcMonad m => [(DynFlags, [Target])] -> m ()
+ GHC.Debugger.Session: toGhcTarget :: TargetDetails -> Target
- GHC.Debugger.Monad: runDebugger :: Handle -> FilePath -> [String] -> [String] -> RunDebuggerSettings -> Debugger a -> IO a
+ GHC.Debugger.Monad: runDebugger :: Handle -> FilePath -> FilePath -> FilePath -> [String] -> [String] -> FilePath -> RunDebuggerSettings -> Debugger a -> IO a
Files
- ghc-debug-adapter/Development/Debug/Adapter/Flags.hs +22/−9
- ghc-debug-adapter/Development/Debug/Adapter/Init.hs +5/−4
- ghc-debugger.cabal +4/−1
- ghc-debugger/GHC/Debugger/Monad.hs +21/−52
- ghc-debugger/GHC/Debugger/Session.hs +250/−0
ghc-debug-adapter/Development/Debug/Adapter/Flags.hs view
@@ -1,15 +1,12 @@ {-# LANGUAGE CPP, RecordWildCards, LambdaCase #-} module Development.Debug.Adapter.Flags where -import Data.Maybe import Data.Function import System.FilePath import System.Directory import Control.Monad.Except import Control.Monad.IO.Class -import qualified Data.List as L- import qualified HIE.Bios as HIE import qualified HIE.Bios.Types as HIE import qualified HIE.Bios.Environment as HIE@@ -19,6 +16,12 @@ { ghcInvocation :: [String] , libdir :: FilePath , units :: [String]+ , rootDir :: FilePath+ -- ^ Root dir as reported by the 'Cradle'+ , componentDir :: FilePath+ -- ^ Root dir of the loaded 'ComponentOptions'.+ -- Important for multi-package cabal projects, as packages are not in the+ -- root of the cradle, but in some sub-directory. } -- | Make 'HieBiosFlags' from the given target file@@ -28,6 +31,7 @@ let target = root </> relTarget explicitCradle <- HIE.findCradle target & liftIO+ -- TODO: Use proper loggers here cradle <- maybe (HIE.loadImplicitCradle mempty target) (HIE.loadCradle mempty) explicitCradle & liftIO @@ -38,29 +42,38 @@ -- (HIE.getCompilerOptions depends on CWD being the proper root dir) let compilerOpts = liftIO $ withCurrentDirectory root $ #if MIN_VERSION_hie_bios(0,14,0)- HIE.getCompilerOptions target HIE.LoadFile cradle+ HIE.getCompilerOptions target (HIE.LoadWithContext [target]) cradle #else HIE.getCompilerOptions target [] cradle #endif- HIE.ComponentOptions {HIE.componentOptions = flags} <- compilerOpts >>= unwrapCradleResult "Failed to get compiler options using hie-bios cradle"-+ componentOpts <- compilerOpts >>= unwrapCradleResult "Failed to get compiler options using hie-bios cradle" #if __GLASGOW_HASKELL__ >= 913 -- fwrite-if-simplified-core requires a recent bug fix regarding GHCi loading -- ROMES:TODO: Re-enable as soon as I'm using Matthew's patch. -- ["-fwrite-if-simplified-core"] ++ #endif + let (units', flags') = extractUnits (HIE.componentOptions componentOpts) return HieBiosFlags- { ghcInvocation = [ relTarget | not $ any (`L.isSuffixOf` target) flags ] ++ -- TODO is this correct? else, the debugger won't work on single files.- flags ++ ghcDebuggerFlags+ { ghcInvocation = flags' ++ ghcDebuggerFlags , libdir = libdir- , units = mapMaybe (\case ("-unit", u) -> Just u; _ -> Nothing) $ zip flags (drop 1 flags)+ , units = units'+ , rootDir = HIE.cradleRootDir cradle+ , componentDir = HIE.componentRoot componentOpts } where unwrapCradleResult m = \case HIE.CradleNone -> throwError $ "HIE.CradleNone\n" ++ m HIE.CradleFail err -> throwError $ unlines (HIE.cradleErrorStderr err) ++ "\n" ++ m HIE.CradleSuccess x -> return x++extractUnits :: [String] -> ([String], [String])+extractUnits = go [] []+ where+ -- TODO: we should likely use the 'processCmdLineP' instead+ go units rest ("-unit" : x : xs) = go (x : units) rest xs+ go units rest (x : xs) = go units (x : rest) xs+ go units rest [] = (reverse units, reverse rest) -- | Flags specific to ghc-debugger to append to all GHC invocations. ghcDebuggerFlags :: [String]
ghc-debug-adapter/Development/Debug/Adapter/Init.hs view
@@ -108,7 +108,7 @@ finished_init <- liftIO $ newEmptyMVar registerNewDebugSession (maybe "debug-session" T.pack __sessionId) DAS{..}- [ debuggerThread finished_init writeDebuggerOutput projectRoot flags extraGhcArgs defaultRunConf syncRequests syncResponses+ [ debuggerThread finished_init writeDebuggerOutput projectRoot flags extraGhcArgs entryFile defaultRunConf syncRequests syncResponses , handleDebuggerOutput readDebuggerOutput , stdoutCaptureThread , stderrCaptureThread@@ -166,13 +166,14 @@ -> FilePath -- ^ Working directory for GHC session -> HieBiosFlags -- ^ GHC Invocation flags -> [String] -- ^ Extra ghc args+ -> FilePath -> Debugger.RunDebuggerSettings -- ^ Settings for running the debugger -> MVar D.Command -- ^ Read commands -> MVar D.Response -- ^ Write reponses -> (DebugAdaptorCont () -> IO ()) -- ^ Allows unlifting DebugAdaptor actions to IO. See 'registerNewDebugSession'. -> IO ()-debuggerThread finished_init writeDebuggerOutput workDir HieBiosFlags{..} extraGhcArgs runConf requests replies withAdaptor = do+debuggerThread finished_init writeDebuggerOutput workDir HieBiosFlags{..} extraGhcArgs mainFp runConf requests replies withAdaptor = do let finalGhcInvocation = ghcInvocation ++ extraGhcArgs @@ -188,9 +189,9 @@ catches (do- Debugger.runDebugger writeDebuggerOutput libdir units finalGhcInvocation runConf $ do+ Debugger.runDebugger writeDebuggerOutput rootDir componentDir libdir units finalGhcInvocation mainFp runConf $ do liftIO $ signalInitialized (Right ())- + forever $ do req <- takeMVar requests & liftIO resp <- (Debugger.execute req <&> Right)
ghc-debugger.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: ghc-debugger-version: 0.3.0.0+version: 0.4.0.0 synopsis: A step-through machine-interface debugger for GHC Haskell @@ -53,6 +53,7 @@ GHC.Debugger.Runtime.Term.Cache, GHC.Debugger.Monad,+ GHC.Debugger.Session, GHC.Debugger.Interface.Messages -- other-modules: -- other-extensions:@@ -65,9 +66,11 @@ process >= 1.6.25 && < 1.7, unix >= 2.8.6 && < 2.9, filepath >= 1.5.4 && < 1.6,+ directory >= 1.3.9.0 && < 1.4, exceptions >= 0.10.9 && < 0.11, bytestring >= 0.12.1 && < 0.13, aeson >= 2.2.3 && < 2.3,+ hie-bios, hs-source-dirs: ghc-debugger default-language: Haskell2010
ghc-debugger/GHC/Debugger/Monad.hs view
@@ -3,9 +3,11 @@ import Prelude hiding (mod) import Data.Function+import qualified Data.Foldable as Foldable import System.Exit import System.IO import System.FilePath (normalise)+import System.Directory (makeAbsolute) import Control.Monad import Control.Monad.IO.Class import Control.Exception (assert)@@ -13,29 +15,21 @@ import Control.Monad.Catch import GHC-import GHC.Types.Name (mkDerivedInternalName)-import GHC.Types.Name.Occurrence (mkVarOcc) import qualified GHCi.BreakArray as BA import GHC.Driver.DynFlags as GHC-import GHC.Driver.Phases as GHC-import GHC.Driver.Pipeline as GHC-import GHC.Driver.Config.Logger as GHC-import GHC.Driver.Session.Units as GHC import GHC.Unit.Module.ModSummary as GHC import GHC.Utils.Outputable as GHC-import GHC.Utils.Monad as GHC import GHC.Utils.Logger as GHC import GHC.Types.Unique.Supply as GHC import GHC.Runtime.Loader as GHC import GHC.Runtime.Interpreter as GHCi import GHC.Runtime.Heap.Inspect import GHC.Unit.Module.Env as GHC-import GHC.Types.Name.Env import GHC.Driver.Env import Data.IORef import Data.Maybe-import qualified Data.List.NonEmpty as NE+import qualified Data.List.NonEmpty as NonEmpty import qualified Data.List as List import qualified Data.IntMap as IM @@ -44,6 +38,7 @@ import GHC.Debugger.Interface.Messages import GHC.Debugger.Runtime.Term.Key import GHC.Debugger.Runtime.Term.Cache+import GHC.Debugger.Session import System.Posix.Signals -- | A debugger action.@@ -103,13 +98,16 @@ -- | Run a 'Debugger' action on a session constructed from a given GHC invocation. runDebugger :: Handle -- ^ The handle to which GHC's output is logged. The debuggee output is not affected by this parameter.+ -> FilePath -- ^ Cradle root directory+ -> FilePath -- ^ Component root directory -> FilePath -- ^ The libdir (given with -B as an arg) -> [String] -- ^ The list of units included in the invocation -> [String] -- ^ The full ghc invocation (as constructed by hie-bios flags)+ -> FilePath -- ^ Path to the main function -> RunDebuggerSettings -- ^ Other debugger run settings -> Debugger a -- ^ 'Debugger' action to run on the session constructed from this invocation -> IO a-runDebugger dbg_out libdir units ghcInvocation' conf (Debugger action) = do+runDebugger dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (Debugger action) = do let ghcInvocation = filter (\case ('-':'B':_) -> False; _ -> True) ghcInvocation' GHC.runGhc (Just libdir) $ do@@ -136,53 +134,23 @@ -- Override the logger to output to the given handle GHC.pushLogHook (const $ debuggerLoggerAction dbg_out) - logger1 <- GHC.getLogger- let logger2 = GHC.setLogFlags logger1 (GHC.initLogFlags dflags1)-- -- The rest of the arguments are "dynamic"- -- Leftover ones are presumably files- (dflags4, fileish_args, _dynamicFlagWarnings) <-- GHC.parseDynamicFlags logger2 dflags1 (map (GHC.mkGeneralLocated "on ghc-debugger command arg") ghcInvocation)+ -- TODO: this is weird, we set the session dynflags now to initialise+ -- the hsc_interp.+ -- This is incredibly dubious+ _ <- GHC.setSessionDynFlags dflags1 - let (dflags5, srcs, objs) = GHC.parseTargetFiles dflags4 (map GHC.unLoc fileish_args)+ -- Initialise plugins here because the plugin author might already expect this+ -- subsequent call to `getLogger` to be affected by a plugin.+ GHC.initializeSessionPlugins - -- we've finished manipulating the DynFlags, update the session- _ <- GHC.setSessionDynFlags dflags5+ flagsAndTargets <- parseHomeUnitArguments mainFp compDir units ghcInvocation dflags1 rootDir+ setupHomeUnitGraph (NonEmpty.toList flagsAndTargets) dflags6 <- GHC.getSessionDynFlags -- Should this be done in GHC= liftIO $ GHC.initUniqSupply (GHC.initialUnique dflags6) (GHC.uniqueIncrement dflags6) - -- Initialise plugins here because the plugin author might already expect this- -- subsequent call to `getLogger` to be affected by a plugin.- GHC.initializeSessionPlugins- hsc_env <- GHC.getSession- - hs_srcs <- case NE.nonEmpty units of- Just ne_units -> do- GHC.initMulti ne_units (\_ _ _ _ -> {-no options extra check-} pure ())- Nothing -> do- case srcs of- [] -> return []- _ -> do- let (hs_srcs, non_hs_srcs) = List.partition GHC.isHaskellishTarget srcs-- -- 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 (GHC.oneShot hsc_env GHC.NoStop srcs) >> return []- else do- o_files <- GHC.mapMaybeM (\x -> liftIO $ GHC.compileFile hsc_env GHC.NoStop x) non_hs_srcs- dflags7 <- GHC.getSessionDynFlags- let dflags' = dflags7 { GHC.ldInputs = map (GHC.FileOption "") o_files ++ GHC.ldInputs dflags7 }- _ <- GHC.setSessionDynFlags dflags'- return $ map (uncurry (,Nothing,)) hs_srcs-- targets' <- mapM (\(src, uid, phase) -> GHC.guessTarget src uid phase) hs_srcs- GHC.setTargets targets' ok_flag <- GHC.load GHC.LoadAllTargets when (GHC.failed ok_flag) (liftIO $ exitWith (ExitFailure 1)) @@ -192,7 +160,7 @@ -- TODO: Think about Note [GHCi and local Preludes] and what is done in `getImplicitPreludeImports` let preludeImp = GHC.IIDecl . GHC.simpleImportDecl $ GHC.mkModuleName "Prelude" mss <- getAllLoadedModules- GHC.setContext $ preludeImp : map (GHC.IIDecl . GHC.simpleImportDecl . GHC.ms_mod_name) mss+ GHC.setContext $ preludeImp : map (GHC.IIModule . GHC.ms_mod) mss runReaderT action =<< initialDebuggerState @@ -299,9 +267,10 @@ -- | Get a 'ModSummary' of a loaded module given its 'FilePath' getModuleByPath :: FilePath -> Debugger (Either String ModSummary) getModuleByPath path = do- -- do this everytime as the loaded modules may have changed+ -- do this every time as the loaded modules may have changed lms <- getAllLoadedModules- let matches ms = normalise (msHsFilePath ms) `List.isSuffixOf` path+ absPath <- liftIO $ makeAbsolute path+ let matches ms = normalise (msHsFilePath ms) == normalise absPath return $ case filter matches lms of [x] -> Right x [] -> Left $ "No module matched " ++ path ++ ".\nLoaded modules:\n" ++ show (map msHsFilePath lms) ++ "\n. Perhaps you've set a breakpoint on a module that isn't loaded into the session?"
+ ghc-debugger/GHC/Debugger/Session.hs view
@@ -0,0 +1,250 @@+{-# LANGUAGE DerivingStrategies #-}++-- | Initialise the GHC session for one or more home units.+--+-- This code is inspired of HLS's session initialisation.+-- It would be great to extract common functions in the future.+module GHC.Debugger.Session (+ parseHomeUnitArguments,+ setupHomeUnitGraph,+ TargetDetails(..),+ Target(..),+ toGhcTarget,+ )+ where++import Control.Monad+import Control.Monad.IO.Class++import qualified GHC+import GHC.Driver.DynFlags as GHC+import GHC.Driver.Monad+import qualified GHC.Driver.Session as GHC+import GHC.Utils.Monad as GHC+import GHC.Unit.Home.Graph+import GHC.Unit.Home.PackageTable+import GHC.Unit.Env+import GHC.Unit.Types+import qualified GHC.Unit.State as State+import GHC.Driver.Env+import GHC.Types.SrcLoc+import Language.Haskell.Syntax.Module.Name++import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Map as Map+import qualified Data.List as L+import qualified Data.Containers.ListUtils as L+import GHC.ResponseFile (expandResponse)+import HIE.Bios.Environment as HIE+import System.FilePath++-- | Throws if package flags are unsatisfiable+parseHomeUnitArguments :: GhcMonad m+ => FilePath -- ^ Main entry point function+ -> FilePath -- ^ Component root. Important for multi-package cabal projects.+ -> [String]+ -> [String] -- ghcInvocation+ -> DynFlags+ -> FilePath -- ^ root dir, see Note [Root Directory]+ -> m (NonEmpty.NonEmpty (DynFlags, [GHC.Target]))+parseHomeUnitArguments cfp compRoot units theOpts dflags rootDir = do+ ((theOpts',_errs,_warns),_units) <- GHC.processCmdLineP [] [] (map noLoc theOpts)+ case NonEmpty.nonEmpty units of+ Just us -> initMulti us+ Nothing -> do+ (df, targets) <- initOne (map unLoc theOpts')+ -- A special target for the file which caused this wonderful+ -- component to be created. In case the cradle doesn't list all the targets for+ -- the component, in which case things will be horribly broken anyway.+ --+ -- When we have a singleComponent that is caused to be loaded due to a+ -- file, we assume the file is part of that component. This is useful+ -- for bare GHC sessions, such as many of the ones used in the testsuite+ --+ -- We don't do this when we have multiple components, because each+ -- component better list all targets or there will be anarchy.+ -- It is difficult to know which component to add our file to in+ -- that case.+ -- Multi unit arguments are likely to come from cabal, which+ -- does list all targets.+ --+ -- If we don't end up with a target for the current file in the end, then+ -- we will report it as an error for that file+ let abs_fp = rootDir </> cfp+ let special_target = mkSimpleTarget df abs_fp+ pure $ (df, special_target : targets) NonEmpty.:| []+ where+ initMulti unitArgFiles =+ forM unitArgFiles $ \f -> do+ args <- liftIO $ expandResponse [f]+ initOne args+ initOne this_opts = do+ (dflags', targets') <- addCmdOpts this_opts dflags++ let targets = HIE.makeTargetsAbsolute root targets'+ root = case workingDirectory dflags' of+ Nothing -> compRoot+ Just wdir -> compRoot </> wdir+ let dflags'' =+ setWorkingDirectory root $+ makeDynFlagsAbsolute compRoot -- makeDynFlagsAbsolute already accounts for workingDirectory+ dflags'+ return (dflags'', targets)++setupHomeUnitGraph :: GhcMonad m => [(DynFlags, [GHC.Target])] -> m ()+setupHomeUnitGraph flagsAndTargets = do+ hsc_env <- GHC.getSession+ (hsc_env', targetDetails) <- liftIO $ setupMultiHomeUnitGhcSession [".hs", ".lhs"] hsc_env flagsAndTargets+ GHC.setSession hsc_env'+ GHC.setTargets (fmap toGhcTarget targetDetails)++-- | Set up the 'HomeUnitGraph' with empty 'HomeUnitEnv's.+createUnitEnvFromFlags :: NonEmpty.NonEmpty DynFlags -> IO HomeUnitGraph+createUnitEnvFromFlags unitDflags = do+ let+ newInternalUnitEnv dflags hpt = mkHomeUnitEnv State.emptyUnitState Nothing dflags hpt Nothing++ unitEnvList <- traverse (\dflags -> do+ emptyHpt <- emptyHomePackageTable+ pure (homeUnitId_ dflags, newInternalUnitEnv dflags emptyHpt)) unitDflags++ pure $ unitEnv_new (Map.fromList (NonEmpty.toList unitEnvList))++-- | Given a set of 'DynFlags', set up the 'UnitEnv' and 'HomeUnitEnv' for this+-- 'HscEnv'.+-- We assume the 'HscEnv' is "empty", e.g. wasn't already used to compile+-- anything.+initHomeUnitEnv :: [DynFlags] -> HscEnv -> IO HscEnv+initHomeUnitEnv unitDflags env = do+ let dflags0 = hsc_dflags env+ -- additionally, set checked dflags so we don't lose fixes+ initial_home_graph <- createUnitEnvFromFlags (dflags0 NonEmpty.:| unitDflags)+ let home_units = unitEnv_keys initial_home_graph+ home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do+ let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv+ dflags = homeUnitEnv_dflags homeUnitEnv+ old_hpt = homeUnitEnv_hpt homeUnitEnv++ (dbs,unit_state,home_unit,mconstants) <- State.initUnits (hsc_logger env) dflags cached_unit_dbs home_units++ updated_dflags <- GHC.updatePlatformConstants dflags mconstants+ pure HomeUnitEnv+ { homeUnitEnv_units = unit_state+ , homeUnitEnv_unit_dbs = Just dbs+ , homeUnitEnv_dflags = updated_dflags+ , homeUnitEnv_hpt = old_hpt+ , homeUnitEnv_home_unit = Just home_unit+ }++ let dflags1 = homeUnitEnv_dflags $ unitEnv_lookup (homeUnitId_ dflags0) home_unit_graph+ let unit_env = UnitEnv+ { ue_platform = targetPlatform dflags1+ , ue_namever = GHC.ghcNameVersion dflags1+ , ue_home_unit_graph = home_unit_graph+ , ue_current_unit = homeUnitId_ dflags0+ , ue_eps = ue_eps (hsc_unit_env env)+ }+ pure $ hscSetFlags dflags1 $ hscSetUnitEnv unit_env env+++-- | Setup the given 'HscEnv' to hold a 'UnitEnv'+-- with all the given components.+-- We return the modified 'HscEnv' and all the 'TargetDetails' for+-- the given 'GHC.Target's.+setupMultiHomeUnitGhcSession+ :: [String] -- ^ File extensions to consider. This is mostly a remnant of HLS.+ -> HscEnv -- ^ An empty HscEnv that we can use the setup the session.+ -> [(DynFlags, [GHC.Target])] -- ^ New components to be loaded. Expected to be non-empty.+ -> IO (HscEnv, [TargetDetails])+setupMultiHomeUnitGhcSession exts hsc_env cis = do+ let dfs = map fst cis++ hscEnv' <- initHomeUnitEnv dfs hsc_env+ -- TODO: this should be reported+ -- _ <- maybeToList $ GHC.checkHomeUnitsClosed (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv')+ ts <- forM cis $ \(df, targets) -> do+ -- evaluate $ liftRnf rwhnf targets++ let mk t = fromTargetId (importPaths df) exts (homeUnitId_ df) (GHC.targetId t)+ ctargets <- concatMapM mk targets++ return (L.nubOrdOn targetTarget ctargets)+ pure (hscEnv', concat ts)++data TargetDetails = TargetDetails+ { targetTarget :: Target+ -- ^ Simplified version of 'TargetId', storing enough information+ --+ , targetLocations :: [FilePath]+ -- ^ The physical location of 'targetTarget'.+ -- Contains '-boot' file locations.+ -- At this moment in time, these are unused, but could be used to create+ -- convenient lookup table from 'FilePath' to 'TargetDetails'.+ , targetUnitId :: UnitId+ -- ^ UnitId of 'targetTarget'.+ }+ deriving (Eq, Ord)++-- | A simplified view on a 'TargetId'.+--+-- Implements 'Ord' and 'Show' which can be convenient.+data Target = TargetModule ModuleName | TargetFile FilePath+ deriving ( Eq, Ord, Show )++-- | Turn a 'TargetDetails' into a 'GHC.Target'.+toGhcTarget :: TargetDetails -> GHC.Target+toGhcTarget (TargetDetails tid _ uid) = case tid of+ TargetModule modl -> GHC.Target (GHC.TargetModule modl) True uid Nothing+ TargetFile fp -> GHC.Target (GHC.TargetFile fp Nothing) True uid Nothing++fromTargetId :: [FilePath] -- ^ import paths+ -> [String] -- ^ extensions to consider+ -> UnitId+ -> GHC.TargetId+ -> IO [TargetDetails]+-- For a target module we consider all the import paths+fromTargetId is exts unitId (GHC.TargetModule modName) = do+ let fps = [i </> moduleNameSlashes modName -<.> ext <> boot+ | ext <- exts+ , i <- is+ , boot <- ["", "-boot"]+ ]+ return [TargetDetails (TargetModule modName) fps unitId]+-- For a 'TargetFile' we consider all the possible module names+fromTargetId _ _ unitId (GHC.TargetFile f _) = do+ let other+ | "-boot" `L.isSuffixOf` f = dropEnd 5 f+ | otherwise = (f ++ "-boot")+ return [TargetDetails (TargetFile f) [f, other] unitId]++-- ----------------------------------------------------------------------------+-- GHC Utils that should likely be exposed by GHC+-- ----------------------------------------------------------------------------++mkSimpleTarget :: DynFlags -> FilePath -> GHC.Target+mkSimpleTarget df fp = GHC.Target (GHC.TargetFile fp Nothing) True (homeUnitId_ df) Nothing++hscSetUnitEnv :: UnitEnv -> HscEnv -> HscEnv+hscSetUnitEnv ue env = env { hsc_unit_env = ue }++setWorkingDirectory :: FilePath -> DynFlags -> DynFlags+setWorkingDirectory p d = d { workingDirectory = Just p }++-- ----------------------------------------------------------------------------+-- Utils that we need, but don't want to incur an additional dependency for.+-- ----------------------------------------------------------------------------++-- | Drop a number of elements from the end of the list.+--+-- > dropEnd 3 "hello" == "he"+-- > dropEnd 5 "bye" == ""+-- > dropEnd (-1) "bye" == "bye"+-- > \i xs -> dropEnd i xs `isPrefixOf` xs+-- > \i xs -> length (dropEnd i xs) == max 0 (length xs - max 0 i)+-- > \i -> take 3 (dropEnd 5 [i..]) == take 3 [i..]+dropEnd :: Int -> [a] -> [a]+dropEnd i xs+ | i <= 0 = xs+ | otherwise = f xs (drop i xs)+ where f (a:as) (_:bs) = a : f as bs+ f _ _ = []