1{-# LANGUAGE NoImplicitPrelude #-} 2{-# LANGUAGE FlexibleContexts #-} 3{-# LANGUAGE OverloadedStrings #-} 4{-# LANGUAGE TupleSections #-} 5{-# LANGUAGE DeriveDataTypeable #-} 6{-# LANGUAGE RecordWildCards #-} 7{-# LANGUAGE ConstraintKinds #-} 8 9-- | Run a GHCi configured with the user's package(s). 10 11module Stack.Ghci 12 ( GhciOpts(..) 13 , GhciPkgInfo(..) 14 , GhciException(..) 15 , ghci 16 ) where 17 18import Stack.Prelude hiding (Display (..)) 19import Control.Monad.State.Strict (State, execState, get, modify) 20import Data.ByteString.Builder (byteString) 21import qualified Data.ByteString.Char8 as S8 22import qualified Data.ByteString.Lazy as LBS 23import Data.List 24import qualified Data.List.NonEmpty as NE 25import qualified Data.Map.Strict as M 26import qualified Data.Set as S 27import qualified Data.Text as T 28import qualified Data.Text.Lazy as TL 29import qualified Data.Text.Lazy.Encoding as TLE 30import qualified Distribution.PackageDescription as C 31import Path 32import Path.Extra (toFilePathNoTrailingSep) 33import Path.IO hiding (withSystemTempDir) 34import qualified RIO 35import RIO.PrettyPrint 36import RIO.Process (HasProcessContext, exec, proc, readProcess_, withWorkingDir) 37import Stack.Build 38import Stack.Build.Installed 39import Stack.Build.Source 40import Stack.Build.Target 41import Stack.Constants 42import Stack.Constants.Config 43import Stack.Ghci.Script 44import Stack.Package 45import Stack.Types.Build 46import Stack.Types.Config 47import Stack.Types.NamedComponent 48import Stack.Types.Package 49import Stack.Types.SourceMap 50import System.IO (putStrLn) 51import System.IO.Temp (getCanonicalTemporaryDirectory) 52import System.Permissions (setScriptPerms) 53 54-- | Command-line options for GHC. 55data GhciOpts = GhciOpts 56 { ghciTargets :: ![Text] 57 , ghciArgs :: ![String] 58 , ghciGhcOptions :: ![String] 59 , ghciFlags :: !(Map ApplyCLIFlag (Map FlagName Bool)) 60 , ghciGhcCommand :: !(Maybe FilePath) 61 , ghciNoLoadModules :: !Bool 62 , ghciAdditionalPackages :: ![String] 63 , ghciMainIs :: !(Maybe Text) 64 , ghciLoadLocalDeps :: !Bool 65 , ghciSkipIntermediate :: !Bool 66 , ghciHidePackages :: !(Maybe Bool) 67 , ghciNoBuild :: !Bool 68 , ghciOnlyMain :: !Bool 69 } deriving Show 70 71-- | Necessary information to load a package or its components. 72-- 73-- NOTE: GhciPkgInfo has paths as list instead of a Set to preserve files order 74-- as a workaround for bug https://ghc.haskell.org/trac/ghc/ticket/13786 75data GhciPkgInfo = GhciPkgInfo 76 { ghciPkgName :: !PackageName 77 , ghciPkgOpts :: ![(NamedComponent, BuildInfoOpts)] 78 , ghciPkgDir :: !(Path Abs Dir) 79 , ghciPkgModules :: !ModuleMap 80 , ghciPkgCFiles :: ![Path Abs File] -- ^ C files. 81 , ghciPkgMainIs :: !(Map NamedComponent [Path Abs File]) 82 , ghciPkgTargetFiles :: !(Maybe [Path Abs File]) 83 , ghciPkgPackage :: !Package 84 } deriving Show 85 86-- | Loaded package description and related info. 87data GhciPkgDesc = GhciPkgDesc 88 { ghciDescPkg :: !Package 89 , ghciDescCabalFp :: !(Path Abs File) 90 , ghciDescTarget :: !Target 91 } 92 93-- Mapping from a module name to a map with all of the paths that use 94-- that name. Each of those paths is associated with a set of components 95-- that contain it. Purpose of this complex structure is for use in 96-- 'checkForDuplicateModules'. 97type ModuleMap = Map ModuleName (Map (Path Abs File) (Set (PackageName, NamedComponent))) 98 99unionModuleMaps :: [ModuleMap] -> ModuleMap 100unionModuleMaps = M.unionsWith (M.unionWith S.union) 101 102data GhciException 103 = InvalidPackageOption String 104 | LoadingDuplicateModules 105 | MissingFileTarget String 106 | Can'tSpecifyFilesAndTargets 107 | Can'tSpecifyFilesAndMainIs 108 | GhciTargetParseException [Text] 109 deriving (Typeable) 110 111instance Exception GhciException 112 113instance Show GhciException where 114 show (InvalidPackageOption name) = 115 "Failed to parse --package option " ++ name 116 show LoadingDuplicateModules = unlines 117 [ "Not attempting to start ghci due to these duplicate modules." 118 , "Use --no-load to try to start it anyway, without loading any modules (but these are still likely to cause errors)" 119 ] 120 show (MissingFileTarget name) = 121 "Cannot find file target " ++ name 122 show Can'tSpecifyFilesAndTargets = 123 "Cannot use 'stack ghci' with both file targets and package targets" 124 show Can'tSpecifyFilesAndMainIs = 125 "Cannot use 'stack ghci' with both file targets and --main-is flag" 126 show (GhciTargetParseException xs) = 127 show (TargetParseException xs) ++ 128 "\nNote that to specify options to be passed to GHCi, use the --ghci-options flag" 129 130-- | Launch a GHCi session for the given local package targets with the 131-- given options and configure it with the load paths and extensions 132-- of those targets. 133ghci :: HasEnvConfig env => GhciOpts -> RIO env () 134ghci opts@GhciOpts{..} = do 135 let buildOptsCLI = defaultBuildOptsCLI 136 { boptsCLITargets = [] 137 , boptsCLIFlags = ghciFlags 138 } 139 sourceMap <- view $ envConfigL.to envConfigSourceMap 140 installMap <- toInstallMap sourceMap 141 locals <- projectLocalPackages 142 depLocals <- localDependencies 143 let localMap = 144 M.fromList [(packageName $ lpPackage lp, lp) | lp <- locals ++ depLocals] 145 -- FIXME:qrilka this looks wrong to go back to SMActual 146 sma = SMActual 147 { smaCompiler = smCompiler sourceMap 148 , smaProject = smProject sourceMap 149 , smaDeps = smDeps sourceMap 150 , smaGlobal = smGlobal sourceMap 151 } 152 -- Parse --main-is argument. 153 mainIsTargets <- parseMainIsTargets buildOptsCLI sma ghciMainIs 154 -- Parse to either file targets or build targets 155 etargets <- preprocessTargets buildOptsCLI sma ghciTargets 156 (inputTargets, mfileTargets) <- case etargets of 157 Right packageTargets -> return (packageTargets, Nothing) 158 Left rawFileTargets -> do 159 case mainIsTargets of 160 Nothing -> return () 161 Just _ -> throwM Can'tSpecifyFilesAndMainIs 162 -- Figure out targets based on filepath targets 163 (targetMap, fileInfo, extraFiles) <- findFileTargets locals rawFileTargets 164 return (targetMap, Just (fileInfo, extraFiles)) 165 -- Get a list of all the local target packages. 166 localTargets <- getAllLocalTargets opts inputTargets mainIsTargets localMap 167 -- Get a list of all the non-local target packages. 168 nonLocalTargets <- getAllNonLocalTargets inputTargets 169 -- Check if additional package arguments are sensible. 170 addPkgs <- checkAdditionalPackages ghciAdditionalPackages 171 -- Load package descriptions. 172 pkgDescs <- loadGhciPkgDescs buildOptsCLI localTargets 173 -- If necessary, ask user about which main module to load. 174 bopts <- view buildOptsL 175 mainFile <- 176 if ghciNoLoadModules 177 then return Nothing 178 else do 179 -- Figure out package files, in order to ask the user 180 -- about which main module to load. See the note below for 181 -- why this is done again after the build. This could 182 -- potentially be done more efficiently, because all we 183 -- need is the location of main modules, not the rest. 184 pkgs0 <- getGhciPkgInfos installMap addPkgs (fmap fst mfileTargets) pkgDescs 185 figureOutMainFile bopts mainIsTargets localTargets pkgs0 186 let pkgTargets pn targets = 187 case targets of 188 TargetAll _ -> [T.pack (packageNameString pn)] 189 TargetComps comps -> [renderPkgComponent (pn, c) | c <- toList comps] 190 -- Build required dependencies and setup local packages. 191 buildDepsAndInitialSteps opts $ 192 concatMap (\(pn, (_, t)) -> pkgTargets pn t) localTargets 193 targetWarnings localTargets nonLocalTargets mfileTargets 194 -- Load the list of modules _after_ building, to catch changes in 195 -- unlisted dependencies (#1180) 196 pkgs <- getGhciPkgInfos installMap addPkgs (fmap fst mfileTargets) pkgDescs 197 checkForIssues pkgs 198 -- Finally, do the invocation of ghci 199 runGhci opts localTargets mainFile pkgs (maybe [] snd mfileTargets) (nonLocalTargets ++ addPkgs) 200 201preprocessTargets 202 :: HasEnvConfig env 203 => BuildOptsCLI 204 -> SMActual GlobalPackage 205 -> [Text] 206 -> RIO env (Either [Path Abs File] (Map PackageName Target)) 207preprocessTargets buildOptsCLI sma rawTargets = do 208 let (fileTargetsRaw, normalTargetsRaw) = 209 partition (\t -> ".hs" `T.isSuffixOf` t || ".lhs" `T.isSuffixOf` t) 210 rawTargets 211 -- Only use file targets if we have no normal targets. 212 if not (null fileTargetsRaw) && null normalTargetsRaw 213 then do 214 fileTargets <- forM fileTargetsRaw $ \fp0 -> do 215 let fp = T.unpack fp0 216 mpath <- liftIO $ forgivingAbsence (resolveFile' fp) 217 case mpath of 218 Nothing -> throwM (MissingFileTarget fp) 219 Just path -> return path 220 return (Left fileTargets) 221 else do 222 -- Try parsing targets before checking if both file and 223 -- module targets are specified (see issue#3342). 224 let boptsCLI = buildOptsCLI { boptsCLITargets = normalTargetsRaw } 225 normalTargets <- parseTargets AllowNoTargets False boptsCLI sma 226 `catch` \ex -> case ex of 227 TargetParseException xs -> throwM (GhciTargetParseException xs) 228 _ -> throwM ex 229 unless (null fileTargetsRaw) $ throwM Can'tSpecifyFilesAndTargets 230 return (Right $ smtTargets normalTargets) 231 232parseMainIsTargets 233 :: HasEnvConfig env 234 => BuildOptsCLI 235 -> SMActual GlobalPackage 236 -> Maybe Text 237 -> RIO env (Maybe (Map PackageName Target)) 238parseMainIsTargets buildOptsCLI sma mtarget = forM mtarget $ \target -> do 239 let boptsCLI = buildOptsCLI { boptsCLITargets = [target] } 240 targets <- parseTargets AllowNoTargets False boptsCLI sma 241 return $ smtTargets targets 242 243-- | Display PackageName + NamedComponent 244displayPkgComponent :: (PackageName, NamedComponent) -> StyleDoc 245displayPkgComponent = style PkgComponent . fromString . T.unpack . renderPkgComponent 246 247findFileTargets 248 :: HasEnvConfig env 249 => [LocalPackage] 250 -> [Path Abs File] 251 -> RIO env (Map PackageName Target, Map PackageName [Path Abs File], [Path Abs File]) 252findFileTargets locals fileTargets = do 253 filePackages <- forM locals $ \lp -> do 254 (_,compFiles,_,_) <- getPackageFiles (packageFiles (lpPackage lp)) (lpCabalFile lp) 255 return (lp, M.map (map dotCabalGetPath) compFiles) 256 let foundFileTargetComponents :: [(Path Abs File, [(PackageName, NamedComponent)])] 257 foundFileTargetComponents = 258 map (\fp -> (fp, ) $ sort $ 259 concatMap (\(lp, files) -> map ((packageName (lpPackage lp), ) . fst) 260 (filter (elem fp . snd) (M.toList files)) 261 ) filePackages 262 ) fileTargets 263 results <- forM foundFileTargetComponents $ \(fp, xs) -> 264 case xs of 265 [] -> do 266 prettyWarn $ vsep 267 [ "Couldn't find a component for file target" <+> 268 pretty fp <> 269 ". This means that the correct ghc options might not be used." 270 , "Attempting to load the file anyway." 271 ] 272 return $ Left fp 273 [x] -> do 274 prettyInfo $ 275 "Using configuration for" <+> displayPkgComponent x <+> 276 "to load" <+> pretty fp 277 return $ Right (fp, x) 278 (x:_) -> do 279 prettyWarn $ 280 "Multiple components contain file target" <+> 281 pretty fp <> ":" <+> 282 mconcat (intersperse ", " (map displayPkgComponent xs)) <> line <> 283 "Guessing the first one," <+> displayPkgComponent x <> "." 284 return $ Right (fp, x) 285 let (extraFiles, associatedFiles) = partitionEithers results 286 targetMap = 287 foldl unionTargets M.empty $ 288 map (\(_, (name, comp)) -> M.singleton name (TargetComps (S.singleton comp))) 289 associatedFiles 290 infoMap = 291 foldl (M.unionWith (<>)) M.empty $ 292 map (\(fp, (name, _)) -> M.singleton name [fp]) 293 associatedFiles 294 return (targetMap, infoMap, extraFiles) 295 296getAllLocalTargets 297 :: HasEnvConfig env 298 => GhciOpts 299 -> Map PackageName Target 300 -> Maybe (Map PackageName Target) 301 -> Map PackageName LocalPackage 302 -> RIO env [(PackageName, (Path Abs File, Target))] 303getAllLocalTargets GhciOpts{..} targets0 mainIsTargets localMap = do 304 -- Use the 'mainIsTargets' as normal targets, for CLI concision. See 305 -- #1845. This is a little subtle - we need to do the target parsing 306 -- independently in order to handle the case where no targets are 307 -- specified. 308 let targets = maybe targets0 (unionTargets targets0) mainIsTargets 309 packages <- view $ envConfigL.to envConfigSourceMap.to smProject 310 -- Find all of the packages that are directly demanded by the 311 -- targets. 312 let directlyWanted = flip mapMaybe (M.toList packages) $ 313 \(name, pp) -> 314 case M.lookup name targets of 315 Just simpleTargets -> Just (name, (ppCabalFP pp, simpleTargets)) 316 Nothing -> Nothing 317 -- Figure out 318 let extraLoadDeps = getExtraLoadDeps ghciLoadLocalDeps localMap directlyWanted 319 if (ghciSkipIntermediate && not ghciLoadLocalDeps) || null extraLoadDeps 320 then return directlyWanted 321 else do 322 let extraList = 323 mconcat $ intersperse ", " (map (fromString . packageNameString . fst) extraLoadDeps) 324 if ghciLoadLocalDeps 325 then logInfo $ 326 "The following libraries will also be loaded into GHCi because " <> 327 "they are local dependencies of your targets, and you specified --load-local-deps:\n " <> 328 extraList 329 else logInfo $ 330 "The following libraries will also be loaded into GHCi because " <> 331 "they are intermediate dependencies of your targets:\n " <> 332 extraList <> 333 "\n(Use --skip-intermediate-deps to omit these)" 334 return (directlyWanted ++ extraLoadDeps) 335 336getAllNonLocalTargets 337 :: Map PackageName Target 338 -> RIO env [PackageName] 339getAllNonLocalTargets targets = do 340 let isNonLocal (TargetAll PTDependency) = True 341 isNonLocal _ = False 342 return $ map fst $ filter (isNonLocal . snd) (M.toList targets) 343 344buildDepsAndInitialSteps :: HasEnvConfig env => GhciOpts -> [Text] -> RIO env () 345buildDepsAndInitialSteps GhciOpts{..} localTargets = do 346 let targets = localTargets ++ map T.pack ghciAdditionalPackages 347 -- If necessary, do the build, for local packagee targets, only do 348 -- 'initialBuildSteps'. 349 case NE.nonEmpty targets of 350 -- only new local targets could appear here 351 Just nonEmptyTargets | not ghciNoBuild -> do 352 eres <- buildLocalTargets nonEmptyTargets 353 case eres of 354 Right () -> return () 355 Left err -> do 356 prettyError $ fromString (show err) 357 prettyWarn "Build failed, but trying to launch GHCi anyway" 358 _ -> 359 return () 360 361checkAdditionalPackages :: MonadThrow m => [String] -> m [PackageName] 362checkAdditionalPackages pkgs = forM pkgs $ \name -> do 363 let mres = (pkgName <$> parsePackageIdentifier name) 364 <|> parsePackageNameThrowing name 365 maybe (throwM $ InvalidPackageOption name) return mres 366 367runGhci 368 :: HasEnvConfig env 369 => GhciOpts 370 -> [(PackageName, (Path Abs File, Target))] 371 -> Maybe (Path Abs File) 372 -> [GhciPkgInfo] 373 -> [Path Abs File] 374 -> [PackageName] 375 -> RIO env () 376runGhci GhciOpts{..} targets mainFile pkgs extraFiles exposePackages = do 377 config <- view configL 378 let pkgopts = hidePkgOpts ++ genOpts ++ ghcOpts 379 shouldHidePackages = 380 fromMaybe (not (null pkgs && null exposePackages)) ghciHidePackages 381 hidePkgOpts = 382 if shouldHidePackages 383 then 384 ["-hide-all-packages"] ++ 385 -- This is necessary, because current versions of ghci 386 -- will entirely fail to start if base isn't visible. This 387 -- is because it tries to use the interpreter to set 388 -- buffering options on standard IO. 389 (if null targets then ["-package", "base"] else []) ++ 390 concatMap (\n -> ["-package", packageNameString n]) exposePackages 391 else [] 392 oneWordOpts bio 393 | shouldHidePackages = bioOneWordOpts bio ++ bioPackageFlags bio 394 | otherwise = bioOneWordOpts bio 395 genOpts = nubOrd (concatMap (concatMap (oneWordOpts . snd) . ghciPkgOpts) pkgs) 396 (omittedOpts, ghcOpts) = partition badForGhci $ 397 concatMap (concatMap (bioOpts . snd) . ghciPkgOpts) pkgs ++ map T.unpack 398 ( fold (configGhcOptionsByCat config) -- include everything, locals, and targets 399 ++ concatMap (getUserOptions . ghciPkgName) pkgs 400 ) 401 getUserOptions pkg = M.findWithDefault [] pkg (configGhcOptionsByName config) 402 badForGhci x = 403 isPrefixOf "-O" x || elem x (words "-debug -threaded -ticky -static -Werror") 404 unless (null omittedOpts) $ 405 logWarn 406 ("The following GHC options are incompatible with GHCi and have not been passed to it: " <> 407 mconcat (intersperse " " (fromString <$> nubOrd omittedOpts))) 408 oiDir <- view objectInterfaceDirL 409 let odir = 410 [ "-odir=" <> toFilePathNoTrailingSep oiDir 411 , "-hidir=" <> toFilePathNoTrailingSep oiDir ] 412 logInfo $ 413 "Configuring GHCi with the following packages: " <> 414 mconcat (intersperse ", " (map (fromString . packageNameString . ghciPkgName) pkgs)) 415 compilerExeName <- view $ compilerPathsL.to cpCompiler.to toFilePath 416 let execGhci extras = do 417 menv <- liftIO $ configProcessContextSettings config defaultEnvSettings 418 withPackageWorkingDir $ withProcessContext menv $ exec 419 (fromMaybe compilerExeName ghciGhcCommand) 420 (("--interactive" : ) $ 421 -- This initial "-i" resets the include directories to 422 -- not include CWD. If there aren't any packages, CWD 423 -- is included. 424 (if null pkgs then id else ("-i" : )) $ 425 odir <> pkgopts <> extras <> ghciGhcOptions <> ghciArgs) 426 withPackageWorkingDir = 427 case pkgs of 428 [pkg] -> withWorkingDir (toFilePath $ ghciPkgDir pkg) 429 _ -> id 430 -- TODO: Consider optimizing this check. Perhaps if no 431 -- "with-ghc" is specified, assume that it is not using intero. 432 checkIsIntero = 433 -- Optimization dependent on the behavior of renderScript - 434 -- it doesn't matter if it's intero or ghci when loading 435 -- multiple packages. 436 case pkgs of 437 [_] -> do 438 menv <- liftIO $ configProcessContextSettings config defaultEnvSettings 439 output <- withProcessContext menv 440 $ runGrabFirstLine (fromMaybe compilerExeName ghciGhcCommand) ["--version"] 441 return $ "Intero" `isPrefixOf` output 442 _ -> return False 443 -- Since usage of 'exec' does not return, we cannot do any cleanup 444 -- on ghci exit. So, instead leave the generated files. To make this 445 -- more efficient and avoid gratuitous generation of garbage, the 446 -- file names are determined by hashing. This also has the nice side 447 -- effect of making it possible to copy the ghci invocation out of 448 -- the log and have it still work. 449 tmpDirectory <- 450 (</> relDirHaskellStackGhci) <$> 451 (parseAbsDir =<< liftIO getCanonicalTemporaryDirectory) 452 ghciDir <- view ghciDirL 453 ensureDir ghciDir 454 ensureDir tmpDirectory 455 macrosOptions <- writeMacrosFile ghciDir pkgs 456 if ghciNoLoadModules 457 then execGhci macrosOptions 458 else do 459 checkForDuplicateModules pkgs 460 isIntero <- checkIsIntero 461 scriptOptions <- writeGhciScript tmpDirectory (renderScript isIntero pkgs mainFile ghciOnlyMain extraFiles) 462 execGhci (macrosOptions ++ scriptOptions) 463 464writeMacrosFile :: HasTerm env => Path Abs Dir -> [GhciPkgInfo] -> RIO env [String] 465writeMacrosFile outputDirectory pkgs = do 466 fps <- fmap (nubOrd . catMaybes . concat) $ 467 forM pkgs $ \pkg -> forM (ghciPkgOpts pkg) $ \(_, bio) -> do 468 let cabalMacros = bioCabalMacros bio 469 exists <- liftIO $ doesFileExist cabalMacros 470 if exists 471 then return $ Just cabalMacros 472 else do 473 prettyWarnL ["Didn't find expected autogen file:", pretty cabalMacros] 474 return Nothing 475 files <- liftIO $ mapM (S8.readFile . toFilePath) fps 476 if null files then return [] else do 477 out <- liftIO $ writeHashedFile outputDirectory relFileCabalMacrosH $ 478 S8.concat $ map (<> "\n#undef CURRENT_PACKAGE_KEY\n#undef CURRENT_COMPONENT_ID\n") files 479 return ["-optP-include", "-optP" <> toFilePath out] 480 481writeGhciScript :: (MonadIO m) => Path Abs Dir -> GhciScript -> m [String] 482writeGhciScript outputDirectory script = do 483 scriptPath <- liftIO $ writeHashedFile outputDirectory relFileGhciScript $ 484 LBS.toStrict $ scriptToLazyByteString script 485 let scriptFilePath = toFilePath scriptPath 486 setScriptPerms scriptFilePath 487 return ["-ghci-script=" <> scriptFilePath] 488 489writeHashedFile :: Path Abs Dir -> Path Rel File -> ByteString -> IO (Path Abs File) 490writeHashedFile outputDirectory relFile contents = do 491 relSha <- shaPathForBytes contents 492 let outDir = outputDirectory </> relSha 493 outFile = outDir </> relFile 494 alreadyExists <- doesFileExist outFile 495 unless alreadyExists $ do 496 ensureDir outDir 497 writeBinaryFileAtomic outFile $ byteString contents 498 return outFile 499 500renderScript :: Bool -> [GhciPkgInfo] -> Maybe (Path Abs File) -> Bool -> [Path Abs File] -> GhciScript 501renderScript isIntero pkgs mainFile onlyMain extraFiles = do 502 let cdPhase = case (isIntero, pkgs) of 503 -- If only loading one package, set the cwd properly. 504 -- Otherwise don't try. See 505 -- https://github.com/commercialhaskell/stack/issues/3309 506 (True, [pkg]) -> cmdCdGhc (ghciPkgDir pkg) 507 _ -> mempty 508 addPhase = cmdAdd $ S.fromList (map Left allModules ++ addMain) 509 addMain = case mainFile of 510 Just path -> [Right path] 511 _ -> [] 512 modulePhase = cmdModule $ S.fromList allModules 513 allModules = nubOrd $ concatMap (M.keys . ghciPkgModules) pkgs 514 case getFileTargets pkgs <> extraFiles of 515 [] -> 516 if onlyMain 517 then cdPhase <> if isJust mainFile then cmdAdd (S.fromList addMain) else mempty 518 else cdPhase <> addPhase <> modulePhase 519 fileTargets -> cmdAdd (S.fromList (map Right fileTargets)) 520 521-- Hacky check if module / main phase should be omitted. This should be 522-- improved if / when we have a better per-component load. 523getFileTargets :: [GhciPkgInfo] -> [Path Abs File] 524getFileTargets = concatMap (concat . maybeToList . ghciPkgTargetFiles) 525 526-- | Figure out the main-is file to load based on the targets. Asks the 527-- user for input if there is more than one candidate main-is file. 528figureOutMainFile 529 :: HasRunner env 530 => BuildOpts 531 -> Maybe (Map PackageName Target) 532 -> [(PackageName, (Path Abs File, Target))] 533 -> [GhciPkgInfo] 534 -> RIO env (Maybe (Path Abs File)) 535figureOutMainFile bopts mainIsTargets targets0 packages = do 536 case candidates of 537 [] -> return Nothing 538 [c@(_,_,fp)] -> do logInfo ("Using main module: " <> RIO.display (renderCandidate c)) 539 return (Just fp) 540 candidate:_ -> do 541 borderedWarning $ do 542 logWarn "The main module to load is ambiguous. Candidates are: " 543 forM_ (map renderCandidate candidates) (logWarn . RIO.display) 544 logWarn 545 "You can specify which one to pick by: " 546 logWarn 547 (" * Specifying targets to stack ghci e.g. stack ghci " <> 548 RIO.display ( sampleTargetArg candidate)) 549 logWarn 550 (" * Specifying what the main is e.g. stack ghci " <> 551 RIO.display (sampleMainIsArg candidate)) 552 logWarn 553 (" * Choosing from the candidate above [1.." <> 554 RIO.display (length candidates) <> "]") 555 liftIO userOption 556 where 557 targets = fromMaybe (M.fromList $ map (\(k, (_, x)) -> (k, x)) targets0) 558 mainIsTargets 559 candidates = do 560 pkg <- packages 561 case M.lookup (ghciPkgName pkg) targets of 562 Nothing -> [] 563 Just target -> do 564 (component,mains) <- 565 M.toList $ 566 M.filterWithKey (\k _ -> k `S.member` wantedComponents) 567 (ghciPkgMainIs pkg) 568 main <- mains 569 return (ghciPkgName pkg, component, main) 570 where 571 wantedComponents = 572 wantedPackageComponents bopts target (ghciPkgPackage pkg) 573 renderCandidate c@(pkgName,namedComponent,mainIs) = 574 let candidateIndex = T.pack . show . (+1) . fromMaybe 0 . elemIndex c 575 pkgNameText = T.pack (packageNameString pkgName) 576 in candidateIndex candidates <> ". Package `" <> 577 pkgNameText <> 578 "' component " <> 579 -- This is the format that can be directly copy-pasted as 580 -- an argument to `stack ghci`. 581 pkgNameText <> ":" <> renderComp namedComponent <> 582 " with main-is file: " <> 583 T.pack (toFilePath mainIs) 584 candidateIndices = take (length candidates) [1 :: Int ..] 585 userOption = do 586 option <- prompt "Specify main module to use (press enter to load none): " 587 let selected = fromMaybe 588 ((+1) $ length candidateIndices) 589 (readMaybe (T.unpack option) :: Maybe Int) 590 case elemIndex selected candidateIndices of 591 Nothing -> do 592 putStrLn 593 "Not loading any main modules, as no valid module selected" 594 putStrLn "" 595 return Nothing 596 Just op -> do 597 let (_,_,fp) = candidates !! op 598 putStrLn 599 ("Loading main module from candidate " <> 600 show (op + 1) <> ", --main-is " <> 601 toFilePath fp) 602 putStrLn "" 603 return $ Just fp 604 renderComp c = 605 case c of 606 CLib -> "lib" 607 CInternalLib name -> "internal-lib:" <> name 608 CExe name -> "exe:" <> name 609 CTest name -> "test:" <> name 610 CBench name -> "bench:" <> name 611 sampleTargetArg (pkg,comp,_) = 612 T.pack (packageNameString pkg) <> ":" <> renderComp comp 613 sampleMainIsArg (pkg,comp,_) = 614 "--main-is " <> T.pack (packageNameString pkg) <> ":" <> renderComp comp 615 616loadGhciPkgDescs 617 :: HasEnvConfig env 618 => BuildOptsCLI 619 -> [(PackageName, (Path Abs File, Target))] 620 -> RIO env [GhciPkgDesc] 621loadGhciPkgDescs buildOptsCLI localTargets = 622 forM localTargets $ \(name, (cabalfp, target)) -> 623 loadGhciPkgDesc buildOptsCLI name cabalfp target 624 625-- | Load package description information for a ghci target. 626loadGhciPkgDesc 627 :: HasEnvConfig env 628 => BuildOptsCLI 629 -> PackageName 630 -> Path Abs File 631 -> Target 632 -> RIO env GhciPkgDesc 633loadGhciPkgDesc buildOptsCLI name cabalfp target = do 634 econfig <- view envConfigL 635 compilerVersion <- view actualCompilerVersionL 636 let SourceMap{..} = envConfigSourceMap econfig 637 -- Currently this source map is being build with 638 -- the default targets 639 sourceMapGhcOptions = fromMaybe [] $ 640 (cpGhcOptions . ppCommon <$> M.lookup name smProject) 641 <|> 642 (cpGhcOptions . dpCommon <$> M.lookup name smDeps) 643 sourceMapCabalConfigOpts = fromMaybe [] $ 644 (cpCabalConfigOpts . ppCommon <$> M.lookup name smProject) 645 <|> 646 (cpCabalConfigOpts . dpCommon <$> M.lookup name smDeps) 647 config = 648 PackageConfig 649 { packageConfigEnableTests = True 650 , packageConfigEnableBenchmarks = True 651 , packageConfigFlags = getLocalFlags buildOptsCLI name 652 , packageConfigGhcOptions = sourceMapGhcOptions 653 , packageConfigCabalConfigOpts = sourceMapCabalConfigOpts 654 , packageConfigCompilerVersion = compilerVersion 655 , packageConfigPlatform = view platformL econfig 656 } 657 -- TODO we've already parsed this information, otherwise we 658 -- wouldn't have figured out the cabalfp already. In the future: 659 -- retain that GenericPackageDescription in the relevant data 660 -- structures to avoid reparsing. 661 (gpdio, _name, _cabalfp) <- loadCabalFilePath (parent cabalfp) 662 gpkgdesc <- liftIO $ gpdio YesPrintWarnings 663 664 -- Source the package's *.buildinfo file created by configure if any. See 665 -- https://www.haskell.org/cabal/users-guide/developing-packages.html#system-dependent-parameters 666 buildinfofp <- parseRelFile (packageNameString name ++ ".buildinfo") 667 hasDotBuildinfo <- doesFileExist (parent cabalfp </> buildinfofp) 668 let mbuildinfofp 669 | hasDotBuildinfo = Just (parent cabalfp </> buildinfofp) 670 | otherwise = Nothing 671 mbuildinfo <- forM mbuildinfofp readDotBuildinfo 672 let pdp = resolvePackageDescription config gpkgdesc 673 pkg = 674 packageFromPackageDescription config (C.genPackageFlags gpkgdesc) $ 675 maybe 676 pdp 677 (\bi -> 678 let PackageDescriptionPair x y = pdp 679 in PackageDescriptionPair 680 (C.updatePackageDescription bi x) 681 (C.updatePackageDescription bi y)) 682 mbuildinfo 683 return GhciPkgDesc 684 { ghciDescPkg = pkg 685 , ghciDescCabalFp = cabalfp 686 , ghciDescTarget = target 687 } 688 689getGhciPkgInfos 690 :: HasEnvConfig env 691 => InstallMap 692 -> [PackageName] 693 -> Maybe (Map PackageName [Path Abs File]) 694 -> [GhciPkgDesc] 695 -> RIO env [GhciPkgInfo] 696getGhciPkgInfos installMap addPkgs mfileTargets localTargets = do 697 (installedMap, _, _, _) <- getInstalled installMap 698 let localLibs = 699 [ packageName (ghciDescPkg desc) 700 | desc <- localTargets 701 , hasLocalComp isCLib (ghciDescTarget desc) 702 ] 703 forM localTargets $ \pkgDesc -> 704 makeGhciPkgInfo installMap installedMap localLibs addPkgs mfileTargets pkgDesc 705 706-- | Make information necessary to load the given package in GHCi. 707makeGhciPkgInfo 708 :: HasEnvConfig env 709 => InstallMap 710 -> InstalledMap 711 -> [PackageName] 712 -> [PackageName] 713 -> Maybe (Map PackageName [Path Abs File]) 714 -> GhciPkgDesc 715 -> RIO env GhciPkgInfo 716makeGhciPkgInfo installMap installedMap locals addPkgs mfileTargets pkgDesc = do 717 bopts <- view buildOptsL 718 let pkg = ghciDescPkg pkgDesc 719 cabalfp = ghciDescCabalFp pkgDesc 720 target = ghciDescTarget pkgDesc 721 name = packageName pkg 722 (mods,files,opts) <- getPackageOpts (packageOpts pkg) installMap installedMap locals addPkgs cabalfp 723 let filteredOpts = filterWanted opts 724 filterWanted = M.filterWithKey (\k _ -> k `S.member` allWanted) 725 allWanted = wantedPackageComponents bopts target pkg 726 return 727 GhciPkgInfo 728 { ghciPkgName = name 729 , ghciPkgOpts = M.toList filteredOpts 730 , ghciPkgDir = parent cabalfp 731 , ghciPkgModules = unionModuleMaps $ 732 map (\(comp, mp) -> M.map (\fp -> M.singleton fp (S.singleton (packageName pkg, comp))) mp) 733 (M.toList (filterWanted mods)) 734 , ghciPkgMainIs = M.map (mapMaybe dotCabalMainPath) files 735 , ghciPkgCFiles = mconcat (M.elems (filterWanted (M.map (mapMaybe dotCabalCFilePath) files))) 736 , ghciPkgTargetFiles = mfileTargets >>= M.lookup name 737 , ghciPkgPackage = pkg 738 } 739 740-- NOTE: this should make the same choices as the components code in 741-- 'loadLocalPackage'. Unfortunately for now we reiterate this logic 742-- (differently). 743wantedPackageComponents :: BuildOpts -> Target -> Package -> Set NamedComponent 744wantedPackageComponents _ (TargetComps cs) _ = cs 745wantedPackageComponents bopts (TargetAll PTProject) pkg = S.fromList $ 746 (case packageLibraries pkg of 747 NoLibraries -> [] 748 HasLibraries names -> CLib : map CInternalLib (S.toList names)) ++ 749 map CExe (S.toList (packageExes pkg)) <> 750 map CInternalLib (S.toList $ packageInternalLibraries pkg) <> 751 (if boptsTests bopts then map CTest (M.keys (packageTests pkg)) else []) <> 752 (if boptsBenchmarks bopts then map CBench (S.toList (packageBenchmarks pkg)) else []) 753wantedPackageComponents _ _ _ = S.empty 754 755checkForIssues :: HasLogFunc env => [GhciPkgInfo] -> RIO env () 756checkForIssues pkgs = do 757 when (length pkgs > 1) $ borderedWarning $ do 758 -- Cabal flag issues could arise only when there are at least 2 packages 759 unless (null cabalFlagIssues) $ borderedWarning $ do 760 logWarn "Warning: There are cabal flags for this project which may prevent GHCi from loading your code properly." 761 logWarn "In some cases it can also load some projects which would otherwise fail to build." 762 logWarn "" 763 mapM_ (logWarn . RIO.display) $ intercalate [""] cabalFlagIssues 764 logWarn "" 765 logWarn "To resolve, remove the flag(s) from the cabal file(s) and instead put them at the top of the haskell files." 766 logWarn "" 767 logWarn "It isn't yet possible to load multiple packages into GHCi in all cases - see" 768 logWarn "https://ghc.haskell.org/trac/ghc/ticket/10827" 769 where 770 cabalFlagIssues = concatMap mixedFlag 771 [ ( "-XNoImplicitPrelude" 772 , [ "-XNoImplicitPrelude will be used, but GHCi will likely fail to build things which depend on the implicit prelude."] 773 ) 774 , ( "-XCPP" 775 , [ "-XCPP will be used, but it can cause issues with multiline strings." 776 , "See https://downloads.haskell.org/~ghc/7.10.2/docs/html/users_guide/options-phases.html#cpp-string-gaps" 777 ] 778 ) 779 , ( "-XNoTraditionalRecordSyntax" 780 , [ "-XNoTraditionalRecordSyntax will be used, but it break modules which use record syntax." ] 781 ) 782 , ( "-XTemplateHaskell" 783 , [ "-XTemplateHaskell will be used, but it may cause compilation issues due to different parsing of '$' when there's no space after it." ] 784 ) 785 , ( "-XQuasiQuotes" 786 , [ "-XQuasiQuotes will be used, but it may cause parse failures due to a different meaning for list comprehension syntax like [x| ... ]" ] 787 ) 788 , ( "-XSafe" 789 , [ "-XSafe will be used, but it will fail to compile unsafe modules." ] 790 ) 791 , ( "-XArrows" 792 , [ "-XArrows will be used, but it will cause non-arrow usages of proc, (-<), (-<<) to fail" ] 793 ) 794 , ( "-XOverloadedStrings" 795 , [ "-XOverloadedStrings will be used, but it can cause type ambiguity in code not usually compiled with it." ] 796 ) 797 , ( "-XOverloadedLists" 798 , [ "-XOverloadedLists will be used, but it can cause type ambiguity in code not usually compiled with it." ] 799 ) 800 , ( "-XMonoLocalBinds" 801 , [ "-XMonoLocalBinds will be used, but it can cause type errors in code which expects generalized local bindings." ] 802 ) 803 , ( "-XTypeFamilies" 804 , [ "-XTypeFamilies will be used, but it implies -XMonoLocalBinds, and so can cause type errors in code which expects generalized local bindings." ] 805 ) 806 , ( "-XGADTs" 807 , [ "-XGADTs will be used, but it implies -XMonoLocalBinds, and so can cause type errors in code which expects generalized local bindings." ] 808 ) 809 , ( "-XNewQualifiedOperators" 810 , [ "-XNewQualifiedOperators will be used, but this will break usages of the old qualified operator syntax." ] 811 ) 812 ] 813 mixedFlag (flag, msgs) = 814 let x = partitionComps (== flag) in 815 [ msgs ++ showWhich x | mixedSettings x ] 816 mixedSettings (xs, ys) = xs /= [] && ys /= [] 817 showWhich (haveIt, don'tHaveIt) = 818 [ "It is specified for:" 819 , " " <> renderPkgComponents haveIt 820 , "But not for: " 821 , " " <> renderPkgComponents don'tHaveIt 822 ] 823 partitionComps f = (map fst xs, map fst ys) 824 where 825 (xs, ys) = partition (any f . snd) compsWithOpts 826 compsWithOpts = map (\(k, bio) -> (k, bioOneWordOpts bio ++ bioOpts bio)) compsWithBios 827 compsWithBios = 828 [ ((ghciPkgName pkg, c), bio) 829 | pkg <- pkgs 830 , (c, bio) <- ghciPkgOpts pkg 831 ] 832 833borderedWarning :: HasLogFunc env => RIO env a -> RIO env a 834borderedWarning f = do 835 logWarn "" 836 logWarn "* * * * * * * *" 837 x <- f 838 logWarn "* * * * * * * *" 839 logWarn "" 840 return x 841 842-- TODO: Should this also tell the user the filepaths, not just the 843-- module name? 844checkForDuplicateModules :: HasTerm env => [GhciPkgInfo] -> RIO env () 845checkForDuplicateModules pkgs = do 846 unless (null duplicates) $ do 847 borderedWarning $ do 848 prettyWarn $ "Multiple files use the same module name:" <> 849 line <> bulletedList (map prettyDuplicate duplicates) 850 -- MSS 2020-10-13 Disabling, may remove entirely in the future 851 -- See: https://github.com/commercialhaskell/stack/issues/5407#issuecomment-707339928 852 -- throwM LoadingDuplicateModules 853 where 854 duplicates :: [(ModuleName, Map (Path Abs File) (Set (PackageName, NamedComponent)))] 855 duplicates = 856 filter (\(_, mp) -> M.size mp > 1) $ 857 M.toList $ 858 unionModuleMaps (map ghciPkgModules pkgs) 859 prettyDuplicate :: (ModuleName, Map (Path Abs File) (Set (PackageName, NamedComponent))) -> StyleDoc 860 prettyDuplicate (mn, mp) = 861 style Error (pretty mn) <+> "found at the following paths" <> line <> 862 bulletedList (map fileDuplicate (M.toList mp)) 863 fileDuplicate :: (Path Abs File, Set (PackageName, NamedComponent)) -> StyleDoc 864 fileDuplicate (fp, comps) = 865 pretty fp <+> parens (fillSep (punctuate "," (map displayPkgComponent (S.toList comps)))) 866 867targetWarnings 868 :: HasBuildConfig env 869 => [(PackageName, (Path Abs File, Target))] 870 -> [PackageName] 871 -> Maybe (Map PackageName [Path Abs File], [Path Abs File]) 872 -> RIO env () 873targetWarnings localTargets nonLocalTargets mfileTargets = do 874 unless (null nonLocalTargets) $ 875 prettyWarnL 876 [ flow "Some targets" 877 , parens $ fillSep $ punctuate "," $ map (style Good . fromString . packageNameString) nonLocalTargets 878 , flow "are not local packages, and so cannot be directly loaded." 879 , flow "In future versions of stack, this might be supported - see" 880 , style Url "https://github.com/commercialhaskell/stack/issues/1441" 881 , "." 882 , flow "It can still be useful to specify these, as they will be passed to ghci via -package flags." 883 ] 884 when (null localTargets && isNothing mfileTargets) $ do 885 smWanted <- view $ buildConfigL.to bcSMWanted 886 stackYaml <- view stackYamlL 887 prettyNote $ vsep 888 [ flow "No local targets specified, so a plain ghci will be started with no package hiding or package options." 889 , "" 890 , flow $ T.unpack $ utf8BuilderToText $ 891 "You are using snapshot: " <> 892 RIO.display (smwSnapshotLocation smWanted) 893 , "" 894 , flow "If you want to use package hiding and options, then you can try one of the following:" 895 , "" 896 , bulletedList 897 [ fillSep 898 [ flow "If you want to start a different project configuration than" <+> pretty stackYaml <> ", then you can use" 899 , style Shell "stack init" 900 , flow "to create a new stack.yaml for the packages in the current directory." 901 , line 902 ] 903 , flow "If you want to use the project configuration at" <+> pretty stackYaml <> ", then you can add to its 'packages' field." 904 ] 905 , "" 906 ] 907 908-- Adds in intermediate dependencies between ghci targets. Note that it 909-- will return a Lib component for these intermediate dependencies even 910-- if they don't have a library (but that's fine for the usage within 911-- this module). 912-- 913-- If 'True' is passed for loadAllDeps, this loads all local deps, even 914-- if they aren't intermediate. 915getExtraLoadDeps 916 :: Bool 917 -> Map PackageName LocalPackage 918 -> [(PackageName, (Path Abs File, Target))] 919 -> [(PackageName, (Path Abs File, Target))] 920getExtraLoadDeps loadAllDeps localMap targets = 921 M.toList $ 922 (\mp -> foldl' (flip M.delete) mp (map fst targets)) $ 923 M.mapMaybe id $ 924 execState (mapM_ (mapM_ go . getDeps . fst) targets) 925 (M.fromList (map (second Just) targets)) 926 where 927 getDeps :: PackageName -> [PackageName] 928 getDeps name = 929 case M.lookup name localMap of 930 Just lp -> M.keys (packageDeps (lpPackage lp)) -- FIXME just Local? 931 _ -> [] 932 go :: PackageName -> State (Map PackageName (Maybe (Path Abs File, Target))) Bool 933 go name = do 934 cache <- get 935 case (M.lookup name cache, M.lookup name localMap) of 936 (Just (Just _), _) -> return True 937 (Just Nothing, _) | not loadAllDeps -> return False 938 (_, Just lp) -> do 939 let deps = M.keys (packageDeps (lpPackage lp)) 940 shouldLoad <- liftM or $ mapM go deps 941 if shouldLoad 942 then do 943 modify (M.insert name (Just (lpCabalFile lp, TargetComps (S.singleton CLib)))) 944 return True 945 else do 946 modify (M.insert name Nothing) 947 return False 948 (_, _) -> return False 949 950unionTargets :: Ord k => Map k Target -> Map k Target -> Map k Target 951unionTargets = M.unionWith $ \l r -> 952 case (l, r) of 953 (TargetAll PTDependency, _) -> r 954 (TargetComps sl, TargetComps sr) -> TargetComps (S.union sl sr) 955 (TargetComps _, TargetAll PTProject) -> TargetAll PTProject 956 (TargetComps _, _) -> l 957 (TargetAll PTProject, _) -> TargetAll PTProject 958 959hasLocalComp :: (NamedComponent -> Bool) -> Target -> Bool 960hasLocalComp p t = 961 case t of 962 TargetComps s -> any p (S.toList s) 963 TargetAll PTProject -> True 964 _ -> False 965 966-- | Run a command and grab the first line of stdout, dropping 967-- stderr's contexts completely. 968runGrabFirstLine :: (HasProcessContext env, HasLogFunc env) => String -> [String] -> RIO env String 969runGrabFirstLine cmd0 args = 970 proc cmd0 args $ \pc -> do 971 (out, _err) <- readProcess_ pc 972 return 973 $ TL.unpack 974 $ TL.filter (/= '\r') 975 $ TL.concat 976 $ take 1 977 $ TL.lines 978 $ TLE.decodeUtf8With lenientDecode out 979