diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000..1b32eb9 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,944 @@ +{-# LANGUAGE CPP, NondecreasingIndentation, TupleSections #-} +{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-} + +----------------------------------------------------------------------------- +-- +-- GHC Driver program +-- +-- (c) The University of Glasgow 2005 +-- +----------------------------------------------------------------------------- + +module Main (main) where + +-- The official GHC API +import qualified GHC +import GHC ( -- DynFlags(..), HscTarget(..), + -- GhcMode(..), GhcLink(..), + Ghc, GhcMonad(..), + LoadHowMuch(..) ) +import CmdLineParser + +-- Implementations of the various modes (--show-iface, mkdependHS. etc.) +import LoadIface ( showIface ) +import HscMain ( newHscEnv ) +import DriverPipeline ( oneShot, compileFile ) +import DriverMkDepend ( doMkDependHS ) +import DriverBkp ( doBackpack ) +#if defined(GHCI) +import GHCi.UI ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings ) +#endif + +-- Frontend plugins +#if defined(GHCI) +import DynamicLoading ( loadFrontendPlugin ) +import Plugins +#else +import DynamicLoading ( pluginError ) +#endif +import Module ( ModuleName ) + + +-- Various other random stuff that we need +import GHC.HandleEncoding +import Config +import Constants +import HscTypes +import Packages ( pprPackages, pprPackagesSimple ) +import DriverPhases +import BasicTypes ( failed ) +import DynFlags hiding (WarnReason(..)) +import ErrUtils +import FastString +import Outputable +import SrcLoc +import Util +import Panic +import UniqSupply +import MonadUtils ( liftIO ) +import DynamicLoading ( initializePlugins ) + +-- Imports for --abi-hash +import LoadIface ( loadUserInterface ) +import Module ( mkModuleName ) +import Finder ( findImportedModule, cannotFindModule ) +import TcRnMonad ( initIfaceCheck ) +import Binary ( openBinMem, put_ ) +import BinFingerprint ( fingerprintBinMem ) + +-- Standard Haskell libraries +import System.IO +import System.Environment +import System.Exit +import System.FilePath +import Control.Monad +import Data.Char +import Data.List +import Data.Maybe + +----------------------------------------------------------------------------- +-- ToDo: + +-- time commands when run with -v +-- user ways +-- Win32 support: proper signal handling +-- reading the package configuration file is too slow +-- -K + +----------------------------------------------------------------------------- +-- GHC's command-line interface + +main :: IO () +main = do + initGCStatistics -- See Note [-Bsymbolic and hooks] + hSetBuffering stdout LineBuffering + hSetBuffering stderr LineBuffering + + configureHandleEncoding + GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $ do + -- 1. extract the -B flag from the args + argv00 <- getArgs + let argv0 = + if any (`elem` argv00) ["--info", "--interactive", "--make", "-c"] + then argv00 + else "--interactive" : argv00 + + let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0 + mbMinusB | null minusB_args = Nothing + | otherwise = Just (drop 2 (last minusB_args)) + + let argv2 = map (mkGeneralLocated "on the commandline") argv1 + + -- 2. Parse the "mode" flags (--make, --interactive etc.) + (mode, argv3, flagWarnings) <- parseModeFlags argv2 + + -- If all we want to do is something like showing the version number + -- then do it now, before we start a GHC session etc. This makes + -- getting basic information much more resilient. + + -- In particular, if we wait until later before giving the version + -- number then bootstrapping gets confused, as it tries to find out + -- what version of GHC it's using before package.conf exists, so + -- starting the session fails. + case mode of + Left preStartupMode -> + do case preStartupMode of + ShowSupportedExtensions -> showSupportedExtensions + ShowVersion -> showVersion + ShowNumVersion -> putStrLn cProjectVersion + ShowOptions isInteractive -> showOptions isInteractive + Right postStartupMode -> + -- start our GHC session + GHC.runGhc mbMinusB $ do + + dflags <- GHC.getSessionDynFlags + + case postStartupMode of + Left preLoadMode -> + liftIO $ do + case preLoadMode of + ShowInfo -> showInfo dflags + ShowGhcUsage -> showGhcUsage dflags + ShowGhciUsage -> showGhciUsage dflags + PrintWithDynFlags f -> putStrLn (f dflags) + Right postLoadMode -> + main' postLoadMode dflags argv3 flagWarnings + +main' :: PostLoadMode -> DynFlags -> [Located String] -> [Warn] + -> Ghc () +main' postLoadMode dflags0 args flagWarnings = do + -- set the default GhcMode, HscTarget and GhcLink. The HscTarget + -- can be further adjusted on a module by module basis, using only + -- the -fvia-C and -fasm flags. If the default HscTarget is not + -- HscC or HscAsm, -fvia-C and -fasm have no effect. + let dflt_target = hscTarget dflags0 + (mode, lang, link) + = case postLoadMode of + DoInteractive -> (CompManager, HscInterpreted, LinkInMemory) + DoEval _ -> (CompManager, HscInterpreted, LinkInMemory) + DoMake -> (CompManager, dflt_target, LinkBinary) + DoBackpack -> (CompManager, dflt_target, LinkBinary) + DoMkDependHS -> (MkDepend, dflt_target, LinkBinary) + DoAbiHash -> (OneShot, dflt_target, LinkBinary) + _ -> (OneShot, dflt_target, LinkBinary) + + let dflags1 = dflags0{ ghcMode = mode, + hscTarget = lang, + ghcLink = link, + verbosity = case postLoadMode of + DoEval _ -> 0 + _other -> 1 + } + + -- turn on -fimplicit-import-qualified for GHCi now, so that it + -- can be overriden from the command-line + -- XXX: this should really be in the interactive DynFlags, but + -- we don't set that until later in interactiveUI + -- We also set -fignore-optim-changes and -fignore-hpc-changes, + -- which are program-level options. Again, this doesn't really + -- feel like the right place to handle this, but we don't have + -- a great story for the moment. + dflags2 | DoInteractive <- postLoadMode = def_ghci_flags + | DoEval _ <- postLoadMode = def_ghci_flags + | otherwise = dflags1 + where def_ghci_flags = dflags1 `gopt_set` Opt_ImplicitImportQualified + `gopt_set` Opt_IgnoreOptimChanges + `gopt_set` Opt_IgnoreHpcChanges + + -- The rest of the arguments are "dynamic" + -- Leftover ones are presumably files + (dflags3, fileish_args, dynamicFlagWarnings) <- + GHC.parseDynamicFlags dflags2 args + + let dflags4 = case lang of + HscInterpreted | not (gopt Opt_ExternalInterpreter dflags3) -> + let platform = targetPlatform dflags3 + dflags3a = updateWays $ dflags3 { ways = interpWays } + dflags3b = foldl gopt_set dflags3a + $ concatMap (wayGeneralFlags platform) + interpWays + dflags3c = foldl gopt_unset dflags3b + $ concatMap (wayUnsetGeneralFlags platform) + interpWays + in dflags3c + _ -> + dflags3 + + GHC.prettyPrintGhcErrors dflags4 $ do + + let flagWarnings' = flagWarnings ++ dynamicFlagWarnings + + handleSourceError (\e -> do + GHC.printException e + liftIO $ exitWith (ExitFailure 1)) $ do + liftIO $ handleFlagWarnings dflags4 flagWarnings' + + liftIO $ showBanner postLoadMode dflags4 + + let + -- To simplify the handling of filepaths, we normalise all filepaths right + -- away - e.g., for win32 platforms, backslashes are converted + -- into forward slashes. + normal_fileish_paths = map (normalise . unLoc) fileish_args + (srcs, objs) = partition_args normal_fileish_paths [] [] + + dflags5 = dflags4 { ldInputs = map (FileOption "") objs + ++ ldInputs dflags4 } + + -- we've finished manipulating the DynFlags, update the session + _ <- GHC.setSessionDynFlags dflags5 + dflags6 <- GHC.getSessionDynFlags + hsc_env <- GHC.getSession + + ---------------- Display configuration ----------- + case verbosity dflags6 of + v | v == 4 -> liftIO $ dumpPackagesSimple dflags6 + | v >= 5 -> liftIO $ dumpPackages dflags6 + | otherwise -> return () + + liftIO $ initUniqSupply (initialUnique dflags6) (uniqueIncrement dflags6) + ---------------- Final sanity checking ----------- + liftIO $ checkOptions postLoadMode dflags6 srcs objs + + ---------------- Do the business ----------- + handleSourceError (\e -> do + GHC.printException e + liftIO $ exitWith (ExitFailure 1)) $ do + case postLoadMode of + ShowInterface f -> liftIO $ doShowIface dflags6 f + DoMake -> doMake srcs + DoMkDependHS -> doMkDependHS (map fst srcs) + StopBefore p -> liftIO (oneShot hsc_env p srcs) + DoInteractive -> ghciUI hsc_env dflags6 srcs Nothing + DoEval exprs -> ghciUI hsc_env dflags6 srcs $ Just $ + reverse exprs + DoAbiHash -> abiHash (map fst srcs) + ShowPackages -> liftIO $ showPackages dflags6 + DoFrontend f -> doFrontend f srcs + DoBackpack -> doBackpack (map fst srcs) + + liftIO $ dumpFinalStats dflags6 + +ghciUI :: HscEnv -> DynFlags -> [(FilePath, Maybe Phase)] -> Maybe [String] + -> Ghc () +#if !defined(GHCI) +ghciUI _ _ _ _ = + throwGhcException (CmdLineError "not built for interactive use") +#else +ghciUI hsc_env dflags0 srcs maybe_expr = do + dflags1 <- liftIO (initializePlugins hsc_env dflags0) + _ <- GHC.setSessionDynFlags dflags1 + interactiveUI defaultGhciSettings srcs maybe_expr +#endif + +-- ----------------------------------------------------------------------------- +-- Splitting arguments into source files and object files. This is where we +-- interpret the -x option, and attach a (Maybe Phase) to each source +-- file indicating the phase specified by the -x option in force, if any. + +partition_args :: [String] -> [(String, Maybe Phase)] -> [String] + -> ([(String, Maybe Phase)], [String]) +partition_args [] srcs objs = (reverse srcs, reverse objs) +partition_args ("-x":suff:args) srcs objs + | "none" <- suff = partition_args args srcs objs + | StopLn <- phase = partition_args args srcs (slurp ++ objs) + | otherwise = partition_args rest (these_srcs ++ srcs) objs + where phase = startPhase suff + (slurp,rest) = break (== "-x") args + these_srcs = zip slurp (repeat (Just phase)) +partition_args (arg:args) srcs objs + | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs + | otherwise = partition_args args srcs (arg:objs) + + {- + We split out the object files (.o, .dll) and add them + to ldInputs for use by the linker. + + The following things should be considered compilation manager inputs: + + - haskell source files (strings ending in .hs, .lhs or other + haskellish extension), + + - module names (not forgetting hierarchical module names), + + - things beginning with '-' are flags that were not recognised by + the flag parser, and we want them to generate errors later in + checkOptions, so we class them as source files (#5921) + + - and finally we consider everything without an extension to be + a comp manager input, as shorthand for a .hs or .lhs filename. + + Everything else is considered to be a linker object, and passed + straight through to the linker. + -} +looks_like_an_input :: String -> Bool +looks_like_an_input m = isSourceFilename m + || looksLikeModuleName m + || "-" `isPrefixOf` m + || not (hasExtension m) + +-- ----------------------------------------------------------------------------- +-- Option sanity checks + +-- | Ensure sanity of options. +-- +-- Throws 'UsageError' or 'CmdLineError' if not. +checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO () + -- Final sanity checking before kicking off a compilation (pipeline). +checkOptions mode dflags srcs objs = do + -- Complain about any unknown flags + let unknown_opts = [ f | (f@('-':_), _) <- srcs ] + when (notNull unknown_opts) (unknownFlagsErr unknown_opts) + + when (notNull (filter wayRTSOnly (ways dflags)) + && isInterpretiveMode mode) $ + hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi") + + -- -prof and --interactive are not a good combination + when ((filter (not . wayRTSOnly) (ways dflags) /= interpWays) + && isInterpretiveMode mode + && not (gopt Opt_ExternalInterpreter dflags)) $ + do throwGhcException (UsageError + "-fexternal-interpreter is required when using --interactive with a non-standard way (-prof, -static, or -dynamic).") + -- -ohi sanity check + if (isJust (outputHi dflags) && + (isCompManagerMode mode || srcs `lengthExceeds` 1)) + then throwGhcException (UsageError "-ohi can only be used when compiling a single source file") + else do + + -- -o sanity checking + if (srcs `lengthExceeds` 1 && isJust (outputFile dflags) + && not (isLinkMode mode)) + then throwGhcException (UsageError "can't apply -o to multiple source files") + else do + + let not_linking = not (isLinkMode mode) || isNoLink (ghcLink dflags) + + when (not_linking && not (null objs)) $ + hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs) + + -- Check that there are some input files + -- (except in the interactive case) + if null srcs && (null objs || not_linking) && needsInputsMode mode + then throwGhcException (UsageError "no input files") + else do + + case mode of + StopBefore HCc | hscTarget dflags /= HscC + -> throwGhcException $ UsageError $ + "the option -C is only available with an unregisterised GHC" + _ -> return () + + -- Verify that output files point somewhere sensible. + verifyOutputFiles dflags + +-- Compiler output options + +-- Called to verify that the output files point somewhere valid. +-- +-- The assumption is that the directory portion of these output +-- options will have to exist by the time 'verifyOutputFiles' +-- is invoked. +-- +-- We create the directories for -odir, -hidir, -outputdir etc. ourselves if +-- they don't exist, so don't check for those here (#2278). +verifyOutputFiles :: DynFlags -> IO () +verifyOutputFiles dflags = do + let ofile = outputFile dflags + when (isJust ofile) $ do + let fn = fromJust ofile + flg <- doesDirNameExist fn + when (not flg) (nonExistentDir "-o" fn) + let ohi = outputHi dflags + when (isJust ohi) $ do + let hi = fromJust ohi + flg <- doesDirNameExist hi + when (not flg) (nonExistentDir "-ohi" hi) + where + nonExistentDir flg dir = + throwGhcException (CmdLineError ("error: directory portion of " ++ + show dir ++ " does not exist (used with " ++ + show flg ++ " option.)")) + +----------------------------------------------------------------------------- +-- GHC modes of operation + +type Mode = Either PreStartupMode PostStartupMode +type PostStartupMode = Either PreLoadMode PostLoadMode + +data PreStartupMode + = ShowVersion -- ghc -V/--version + | ShowNumVersion -- ghc --numeric-version + | ShowSupportedExtensions -- ghc --supported-extensions + | ShowOptions Bool {- isInteractive -} -- ghc --show-options + +showVersionMode, showNumVersionMode, showSupportedExtensionsMode, showOptionsMode :: Mode +showVersionMode = mkPreStartupMode ShowVersion +showNumVersionMode = mkPreStartupMode ShowNumVersion +showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions +showOptionsMode = mkPreStartupMode (ShowOptions False) + +mkPreStartupMode :: PreStartupMode -> Mode +mkPreStartupMode = Left + +isShowVersionMode :: Mode -> Bool +isShowVersionMode (Left ShowVersion) = True +isShowVersionMode _ = False + +isShowNumVersionMode :: Mode -> Bool +isShowNumVersionMode (Left ShowNumVersion) = True +isShowNumVersionMode _ = False + +data PreLoadMode + = ShowGhcUsage -- ghc -? + | ShowGhciUsage -- ghci -? + | ShowInfo -- ghc --info + | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo + +showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode +showGhcUsageMode = mkPreLoadMode ShowGhcUsage +showGhciUsageMode = mkPreLoadMode ShowGhciUsage +showInfoMode = mkPreLoadMode ShowInfo + +printSetting :: String -> Mode +printSetting k = mkPreLoadMode (PrintWithDynFlags f) + where f dflags = fromMaybe (panic ("Setting not found: " ++ show k)) + $ lookup k (compilerInfo dflags) + +mkPreLoadMode :: PreLoadMode -> Mode +mkPreLoadMode = Right . Left + +isShowGhcUsageMode :: Mode -> Bool +isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True +isShowGhcUsageMode _ = False + +isShowGhciUsageMode :: Mode -> Bool +isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True +isShowGhciUsageMode _ = False + +data PostLoadMode + = ShowInterface FilePath -- ghc --show-iface + | DoMkDependHS -- ghc -M + | StopBefore Phase -- ghc -E | -C | -S + -- StopBefore StopLn is the default + | DoMake -- ghc --make + | DoBackpack -- ghc --backpack foo.bkp + | DoInteractive -- ghc --interactive + | DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"] + | DoAbiHash -- ghc --abi-hash + | ShowPackages -- ghc --show-packages + | DoFrontend ModuleName -- ghc --frontend Plugin.Module + +doMkDependHSMode, doMakeMode, doInteractiveMode, + doAbiHashMode, showPackagesMode :: Mode +doMkDependHSMode = mkPostLoadMode DoMkDependHS +doMakeMode = mkPostLoadMode DoMake +doInteractiveMode = mkPostLoadMode DoInteractive +doAbiHashMode = mkPostLoadMode DoAbiHash +showPackagesMode = mkPostLoadMode ShowPackages + +showInterfaceMode :: FilePath -> Mode +showInterfaceMode fp = mkPostLoadMode (ShowInterface fp) + +stopBeforeMode :: Phase -> Mode +stopBeforeMode phase = mkPostLoadMode (StopBefore phase) + +doEvalMode :: String -> Mode +doEvalMode str = mkPostLoadMode (DoEval [str]) + +doFrontendMode :: String -> Mode +doFrontendMode str = mkPostLoadMode (DoFrontend (mkModuleName str)) + +doBackpackMode :: Mode +doBackpackMode = mkPostLoadMode DoBackpack + +mkPostLoadMode :: PostLoadMode -> Mode +mkPostLoadMode = Right . Right + +isDoInteractiveMode :: Mode -> Bool +isDoInteractiveMode (Right (Right DoInteractive)) = True +isDoInteractiveMode _ = False + +isStopLnMode :: Mode -> Bool +isStopLnMode (Right (Right (StopBefore StopLn))) = True +isStopLnMode _ = False + +isDoMakeMode :: Mode -> Bool +isDoMakeMode (Right (Right DoMake)) = True +isDoMakeMode _ = False + +isDoEvalMode :: Mode -> Bool +isDoEvalMode (Right (Right (DoEval _))) = True +isDoEvalMode _ = False + +#if defined(GHCI) +isInteractiveMode :: PostLoadMode -> Bool +isInteractiveMode DoInteractive = True +isInteractiveMode _ = False +#endif + +-- isInterpretiveMode: byte-code compiler involved +isInterpretiveMode :: PostLoadMode -> Bool +isInterpretiveMode DoInteractive = True +isInterpretiveMode (DoEval _) = True +isInterpretiveMode _ = False + +needsInputsMode :: PostLoadMode -> Bool +needsInputsMode DoMkDependHS = True +needsInputsMode (StopBefore _) = True +needsInputsMode DoMake = True +needsInputsMode _ = False + +-- True if we are going to attempt to link in this mode. +-- (we might not actually link, depending on the GhcLink flag) +isLinkMode :: PostLoadMode -> Bool +isLinkMode (StopBefore StopLn) = True +isLinkMode DoMake = True +isLinkMode DoInteractive = True +isLinkMode (DoEval _) = True +isLinkMode _ = False + +isCompManagerMode :: PostLoadMode -> Bool +isCompManagerMode DoMake = True +isCompManagerMode DoInteractive = True +isCompManagerMode (DoEval _) = True +isCompManagerMode _ = False + +-- ----------------------------------------------------------------------------- +-- Parsing the mode flag + +parseModeFlags :: [Located String] + -> IO (Mode, + [Located String], + [Warn]) +parseModeFlags args = do + let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) = + runCmdLine (processArgs mode_flags args) + (Nothing, [], []) + mode = case mModeFlag of + Nothing -> doMakeMode + Just (m, _) -> m + + -- See Note [Handling errors when parsing commandline flags] + unless (null errs1 && null errs2) $ throwGhcException $ errorsToGhcException $ + map (("on the commandline", )) $ map (unLoc . errMsg) errs1 ++ errs2 + + return (mode, flags' ++ leftover, warns) + +type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String]) + -- mode flags sometimes give rise to new DynFlags (eg. -C, see below) + -- so we collect the new ones and return them. + +mode_flags :: [Flag ModeM] +mode_flags = + [ ------- help / version ---------------------------------------------- + defFlag "?" (PassFlag (setMode showGhcUsageMode)) + , defFlag "-help" (PassFlag (setMode showGhcUsageMode)) + , defFlag "V" (PassFlag (setMode showVersionMode)) + , defFlag "-version" (PassFlag (setMode showVersionMode)) + , defFlag "-numeric-version" (PassFlag (setMode showNumVersionMode)) + , defFlag "-info" (PassFlag (setMode showInfoMode)) + , defFlag "-show-options" (PassFlag (setMode showOptionsMode)) + , defFlag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode)) + , defFlag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode)) + , defFlag "-show-packages" (PassFlag (setMode showPackagesMode)) + ] ++ + [ defFlag k' (PassFlag (setMode (printSetting k))) + | k <- ["Project version", + "Project Git commit id", + "Booter version", + "Stage", + "Build platform", + "Host platform", + "Target platform", + "Have interpreter", + "Object splitting supported", + "Have native code generator", + "Support SMP", + "Unregisterised", + "Tables next to code", + "RTS ways", + "Leading underscore", + "Debug on", + "LibDir", + "Global Package DB", + "C compiler flags", + "C compiler link flags", + "ld flags"], + let k' = "-print-" ++ map (replaceSpace . toLower) k + replaceSpace ' ' = '-' + replaceSpace c = c + ] ++ + ------- interfaces ---------------------------------------------------- + [ defFlag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f) + "--show-iface")) + + ------- primary modes ------------------------------------------------ + , defFlag "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f + addFlag "-no-link" f)) + , defFlag "M" (PassFlag (setMode doMkDependHSMode)) + , defFlag "E" (PassFlag (setMode (stopBeforeMode anyHsc))) + , defFlag "C" (PassFlag (setMode (stopBeforeMode HCc))) + , defFlag "S" (PassFlag (setMode (stopBeforeMode (As False)))) + , defFlag "-make" (PassFlag (setMode doMakeMode)) + , defFlag "-backpack" (PassFlag (setMode doBackpackMode)) + , defFlag "-interactive" (PassFlag (setMode doInteractiveMode)) + , defFlag "-abi-hash" (PassFlag (setMode doAbiHashMode)) + , defFlag "e" (SepArg (\s -> setMode (doEvalMode s) "-e")) + , defFlag "-frontend" (SepArg (\s -> setMode (doFrontendMode s) "-frontend")) + ] + +setMode :: Mode -> String -> EwM ModeM () +setMode newMode newFlag = liftEwM $ do + (mModeFlag, errs, flags') <- getCmdLineState + let (modeFlag', errs') = + case mModeFlag of + Nothing -> ((newMode, newFlag), errs) + Just (oldMode, oldFlag) -> + case (oldMode, newMode) of + -- -c/--make are allowed together, and mean --make -no-link + _ | isStopLnMode oldMode && isDoMakeMode newMode + || isStopLnMode newMode && isDoMakeMode oldMode -> + ((doMakeMode, "--make"), []) + + -- If we have both --help and --interactive then we + -- want showGhciUsage + _ | isShowGhcUsageMode oldMode && + isDoInteractiveMode newMode -> + ((showGhciUsageMode, oldFlag), []) + | isShowGhcUsageMode newMode && + isDoInteractiveMode oldMode -> + ((showGhciUsageMode, newFlag), []) + + -- If we have both -e and --interactive then -e always wins + _ | isDoEvalMode oldMode && + isDoInteractiveMode newMode -> + ((oldMode, oldFlag), []) + | isDoEvalMode newMode && + isDoInteractiveMode oldMode -> + ((newMode, newFlag), []) + + -- Otherwise, --help/--version/--numeric-version always win + | isDominantFlag oldMode -> ((oldMode, oldFlag), []) + | isDominantFlag newMode -> ((newMode, newFlag), []) + -- We need to accumulate eval flags like "-e foo -e bar" + (Right (Right (DoEval esOld)), + Right (Right (DoEval [eNew]))) -> + ((Right (Right (DoEval (eNew : esOld))), oldFlag), + errs) + -- Saying e.g. --interactive --interactive is OK + _ | oldFlag == newFlag -> ((oldMode, oldFlag), errs) + + -- --interactive and --show-options are used together + (Right (Right DoInteractive), Left (ShowOptions _)) -> + ((Left (ShowOptions True), + "--interactive --show-options"), errs) + (Left (ShowOptions _), (Right (Right DoInteractive))) -> + ((Left (ShowOptions True), + "--show-options --interactive"), errs) + -- Otherwise, complain + _ -> let err = flagMismatchErr oldFlag newFlag + in ((oldMode, oldFlag), err : errs) + putCmdLineState (Just modeFlag', errs', flags') + where isDominantFlag f = isShowGhcUsageMode f || + isShowGhciUsageMode f || + isShowVersionMode f || + isShowNumVersionMode f + +flagMismatchErr :: String -> String -> String +flagMismatchErr oldFlag newFlag + = "cannot use `" ++ oldFlag ++ "' with `" ++ newFlag ++ "'" + +addFlag :: String -> String -> EwM ModeM () +addFlag s flag = liftEwM $ do + (m, e, flags') <- getCmdLineState + putCmdLineState (m, e, mkGeneralLocated loc s : flags') + where loc = "addFlag by " ++ flag ++ " on the commandline" + +-- ---------------------------------------------------------------------------- +-- Run --make mode + +doMake :: [(String,Maybe Phase)] -> Ghc () +doMake srcs = do + let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs + + hsc_env <- 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 StopLn srcs) + else do + + o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x) + non_hs_srcs + dflags <- GHC.getSessionDynFlags + let dflags' = dflags { ldInputs = map (FileOption "") o_files + ++ ldInputs dflags } + _ <- GHC.setSessionDynFlags dflags' + + targets <- mapM (uncurry GHC.guessTarget) hs_srcs + GHC.setTargets targets + ok_flag <- GHC.load LoadAllTargets + + when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1)) + return () + + +-- --------------------------------------------------------------------------- +-- --show-iface mode + +doShowIface :: DynFlags -> FilePath -> IO () +doShowIface dflags file = do + hsc_env <- newHscEnv dflags + showIface hsc_env file + +-- --------------------------------------------------------------------------- +-- Various banners and verbosity output. + +showBanner :: PostLoadMode -> DynFlags -> IO () +showBanner _postLoadMode dflags = do + let verb = verbosity dflags + +#if defined(GHCI) + -- Show the GHCi banner + when (isInteractiveMode _postLoadMode && verb >= 1) $ putStrLn ghciWelcomeMsg +#endif + + -- Display details of the configuration in verbose mode + when (verb >= 2) $ + do hPutStr stderr "Glasgow Haskell Compiler, Version " + hPutStr stderr cProjectVersion + hPutStr stderr ", stage " + hPutStr stderr cStage + hPutStr stderr " booted by GHC version " + hPutStrLn stderr cBooterVersion + +-- We print out a Read-friendly string, but a prettier one than the +-- Show instance gives us +showInfo :: DynFlags -> IO () +showInfo dflags = do + let sq x = " [" ++ x ++ "\n ]" + putStrLn $ sq $ intercalate "\n ," $ map show $ compilerInfo dflags + +showSupportedExtensions :: IO () +showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions + +showVersion :: IO () +showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion) + +showOptions :: Bool -> IO () +showOptions isInteractive = putStr (unlines availableOptions) + where + availableOptions = concat [ + flagsForCompletion isInteractive, + map ('-':) (getFlagNames mode_flags) + ] + getFlagNames opts = map flagName opts + +showGhcUsage :: DynFlags -> IO () +showGhcUsage = showUsage False + +showGhciUsage :: DynFlags -> IO () +showGhciUsage = showUsage True + +showUsage :: Bool -> DynFlags -> IO () +showUsage ghci dflags = do + let usage_path = if ghci then ghciUsagePath dflags + else ghcUsagePath dflags + usage <- readFile usage_path + dump usage + where + dump "" = return () + dump ('$':'$':s) = putStr progName >> dump s + dump (c:s) = putChar c >> dump s + +dumpFinalStats :: DynFlags -> IO () +dumpFinalStats dflags = + when (gopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags + +dumpFastStringStats :: DynFlags -> IO () +dumpFastStringStats dflags = do + buckets <- getFastStringTable + let (entries, longest, has_z) = countFS 0 0 0 buckets + msg = text "FastString stats:" $$ + nest 4 (vcat [text "size: " <+> int (length buckets), + text "entries: " <+> int entries, + text "longest chain: " <+> int longest, + text "has z-encoding: " <+> (has_z `pcntOf` entries) + ]) + -- we usually get more "has z-encoding" than "z-encoded", because + -- when we z-encode a string it might hash to the exact same string, + -- which is not counted as "z-encoded". Only strings whose + -- Z-encoding is different from the original string are counted in + -- the "z-encoded" total. + putMsg dflags msg + where + x `pcntOf` y = int ((x * 100) `quot` y) Outputable.<> char '%' + +countFS :: Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int) +countFS entries longest has_z [] = (entries, longest, has_z) +countFS entries longest has_z (b:bs) = + let + len = length b + longest' = max len longest + entries' = entries + len + has_zs = length (filter hasZEncoding b) + in + countFS entries' longest' (has_z + has_zs) bs + +showPackages, dumpPackages, dumpPackagesSimple :: DynFlags -> IO () +showPackages dflags = putStrLn (showSDoc dflags (pprPackages dflags)) +dumpPackages dflags = putMsg dflags (pprPackages dflags) +dumpPackagesSimple dflags = putMsg dflags (pprPackagesSimple dflags) + +-- ----------------------------------------------------------------------------- +-- Frontend plugin support + +doFrontend :: ModuleName -> [(String, Maybe Phase)] -> Ghc () +#if !defined(GHCI) +doFrontend modname _ = pluginError [modname] +#else +doFrontend modname srcs = do + hsc_env <- getSession + frontend_plugin <- liftIO $ loadFrontendPlugin hsc_env modname + frontend frontend_plugin + (reverse $ frontendPluginOpts (hsc_dflags hsc_env)) srcs +#endif + +-- ----------------------------------------------------------------------------- +-- ABI hash support + +{- + ghc --abi-hash Data.Foo System.Bar + +Generates a combined hash of the ABI for modules Data.Foo and +System.Bar. The modules must already be compiled, and appropriate -i +options may be necessary in order to find the .hi files. + +This is used by Cabal for generating the ComponentId for a +package. The ComponentId must change when the visible ABI of +the package chagnes, so during registration Cabal calls ghc --abi-hash +to get a hash of the package's ABI. +-} + +-- | Print ABI hash of input modules. +-- +-- The resulting hash is the MD5 of the GHC version used (Trac #5328, +-- see 'hiVersion') and of the existing ABI hash from each module (see +-- 'mi_mod_hash'). +abiHash :: [String] -- ^ List of module names + -> Ghc () +abiHash strs = do + hsc_env <- getSession + let dflags = hsc_dflags hsc_env + + liftIO $ do + + let find_it str = do + let modname = mkModuleName str + r <- findImportedModule hsc_env modname Nothing + case r of + Found _ m -> return m + _error -> throwGhcException $ CmdLineError $ showSDoc dflags $ + cannotFindModule dflags modname r + + mods <- mapM find_it strs + + let get_iface modl = loadUserInterface False (text "abiHash") modl + ifaces <- initIfaceCheck (text "abiHash") hsc_env $ mapM get_iface mods + + bh <- openBinMem (3*1024) -- just less than a block + put_ bh hiVersion + -- package hashes change when the compiler version changes (for now) + -- see #5328 + mapM_ (put_ bh . mi_mod_hash) ifaces + f <- fingerprintBinMem bh + + putStrLn (showPpr dflags f) + +-- ----------------------------------------------------------------------------- +-- Util + +unknownFlagsErr :: [String] -> a +unknownFlagsErr fs = throwGhcException $ UsageError $ concatMap oneError fs + where + oneError f = + "unrecognised flag: " ++ f ++ "\n" ++ + (case match f (nubSort allNonDeprecatedFlags) of + [] -> "" + suggs -> "did you mean one of:\n" ++ unlines (map (" " ++) suggs)) + -- fixes #11789 + -- If the flag contains '=', + -- this uses both the whole and the left side of '=' for comparing. + match f allFlags + | elem '=' f = + let (flagsWithEq, flagsWithoutEq) = partition (elem '=') allFlags + fName = takeWhile (/= '=') f + in (fuzzyMatch f flagsWithEq) ++ (fuzzyMatch fName flagsWithoutEq) + | otherwise = fuzzyMatch f allFlags + +{- Note [-Bsymbolic and hooks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-Bsymbolic is a flag that prevents the binding of references to global +symbols to symbols outside the shared library being compiled (see `man +ld`). When dynamically linking, we don't use -Bsymbolic on the RTS +package: that is because we want hooks to be overridden by the user, +we don't want to constrain them to the RTS package. + +Unfortunately this seems to have broken somehow on OS X: as a result, +defaultHooks (in hschooks.c) is not called, which does not initialize +the GC stats. As a result, this breaks things like `:set +s` in GHCi +(#8754). As a hacky workaround, we instead call 'defaultHooks' +directly to initalize the flags in the RTS. + +A byproduct of this, I believe, is that hooks are likely broken on OS +X when dynamically linking. But this probably doesn't affect most +people since we're linking GHC dynamically, but most things themselves +link statically. +-} + +foreign import ccall safe "initGCStatistics" + initGCStatistics :: IO () diff --git a/cbits/HsVersions.h b/cbits/HsVersions.h new file mode 100644 index 0000000..6b4ee14 --- /dev/null +++ b/cbits/HsVersions.h @@ -0,0 +1,8 @@ +/* Hack needed because of http://hackage.haskell.org/trac/ghc/ticket/8040 */ + +#define ASSERT(e) if debugIsOn && not (e) then (assertPanic __FILE__ __LINE__) else + +#define GLOBAL_VAR(name,value,ty) \ +{-# NOINLINE name #-}; \ +name :: IORef (ty); \ +name = Util.global (value); diff --git a/cbits/PosixSource.h b/cbits/PosixSource.h new file mode 100644 index 0000000..6659cfe --- /dev/null +++ b/cbits/PosixSource.h @@ -0,0 +1,42 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team, 1998-2005 + * + * Include this file into sources which should not need any non-Posix services. + * That includes most RTS C sources. + * ---------------------------------------------------------------------------*/ + +#ifndef POSIXSOURCE_H +#define POSIXSOURCE_H + +#include + +#if defined(freebsd_HOST_OS) || defined(dragonfly_HOST_OS) +#define _POSIX_C_SOURCE 200112L +#define _XOPEN_SOURCE 600 +#else +#define _POSIX_SOURCE 1 +#define _POSIX_C_SOURCE 199506L +#define _XOPEN_SOURCE 500 +// FreeBSD takes a different approach to _ISOC99_SOURCE: on FreeBSD it +// means "I want *just* C99 things", whereas on GNU libc and Solaris +// it means "I also want C99 things". +// +// On both GNU libc and FreeBSD, _ISOC99_SOURCE is implied by +// _XOPEN_SOURCE==600, but on Solaris it is an error to omit it. +#define _ISOC99_SOURCE +// Defining __USE_MINGW_ANSI_STDIO is the most portable way to tell +// mingw that we want to use the standard %lld style format specifiers, +// rather than the Windows %I64d style +#define __USE_MINGW_ANSI_STDIO 1 +#endif + +#if defined(darwin_HOST_OS) +/* If we don't define this the including sysctl breaks with things like + /usr/include/bsm/audit.h:224:0: + error: syntax error before 'u_char' +*/ +#define _DARWIN_C_SOURCE 1 +#endif + +#endif /* POSIXSOURCE_H */ diff --git a/cbits/hschooks.c b/cbits/hschooks.c new file mode 100644 index 0000000..2be91a0 --- /dev/null +++ b/cbits/hschooks.c @@ -0,0 +1,59 @@ +/* +These routines customise the error messages +for various bits of the RTS. They are linked +in instead of the defaults. +*/ + +#include "PosixSource.h" +#include "Rts.h" + +#include "HsFFI.h" + +#include + +#ifdef HAVE_UNISTD_H +#include +#endif + +void +initGCStatistics(void) +{ + /* Workaround for #8754: if the GC stats aren't enabled because the + compiler couldn't use -Bsymbolic to link the default hooks, then + initialize them sensibly. See Note [-Bsymbolic and hooks] in + Main.hs. */ + if (RtsFlags.GcFlags.giveStats == NO_GC_STATS) { + RtsFlags.GcFlags.giveStats = COLLECT_GC_STATS; + } +} + +void +defaultsHook (void) +{ +#if __GLASGOW_HASKELL__ >= 707 && __GLASGOW_HASKELL__ < 802 + // This helps particularly with large compiles, but didn't work + // very well with earlier GHCs because it caused large amounts of + // fragmentation. See rts/sm/BlockAlloc.c:allocLargeChunk(). + RtsFlags.GcFlags.heapSizeSuggestionAuto = rtsTrue; +#else + RtsFlags.GcFlags.heapSizeSuggestion = 6*1024*1024 / BLOCK_SIZE; +#endif + + RtsFlags.GcFlags.maxStkSize = 512*1024*1024 / sizeof(W_); + + initGCStatistics(); + + // See #3408: the default idle GC time of 0.3s is too short on + // Windows where we receive console events once per second or so. +#if __GLASGOW_HASKELL__ >= 703 + RtsFlags.GcFlags.idleGCDelayTime = SecondsToTime(5); +#else + RtsFlags.GcFlags.idleGCDelayTime = 5*1000; +#endif +} + +void +StackOverflowHook (StgWord stack_size) /* in bytes */ +{ + fprintf(stderr, "GHC stack-space overflow: current limit is %zu bytes.\nUse the `-K' option to increase it.\n", (size_t)stack_size); +} diff --git a/package.yaml b/package.yaml index 6e027df..ebab640 100644 --- a/package.yaml +++ b/package.yaml @@ -24,22 +24,55 @@ ghc-options: - -fno-warn-name-shadowing dependencies: +- array >= 0.5 - base >= 4.7 && < 5 -- pipes >= 4 && < 5 +- bytestring >= 0.10 +- containers >= 0.6 +- deepseq >= 1.4 +- directory >= 1.3 +- filepath >= 1.4 +- ghc >= 8.6.5 && < 9 +- ghc-boot >= 8.6.5 && < 9 +- ghc-prim >= 0.5 +- ghci >= 8.6.5 && < 9 +- haskeline >= 0.7 - mmorph >= 1 && < 2 +- mtl >= 2 && < 3 +- pipes >= 4 && < 5 +- pretty >= 1.1 && < 1.2 +- prettyprinter >= 1 && < 2 +- process >= 1.6 +- refinery - semigroupoids >= 5 && < 6 - template-haskell >= 2 && < 3 -- megaparsec >= 6 && < 7 -- containers >= 0.5 && < 0.6 - text >= 1 && < 2 -- prettyprinter >= 1 && < 2 -- pretty >= 1.1 && < 1.2 -- mtl >= 2 && < 3 -- ghc >= 8.4.3 && < 9 +- th-abstraction >= 0.2 +- time >= 1.8 +- transformers >= 0.5 +- unix >= 2.7 library: source-dirs: src +executables: + tactic-haskell: + main: app/Main.hs + cpp-options: + -DGHCI + cc-options: + -fPIC + c-sources: + cbits/hschooks.c + include-dirs: + cbits/ + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - tactic-haskell + + tests: tactic-haskell-test: main: Spec.hs diff --git a/samples/Sample.hs b/samples/Sample.hs deleted file mode 100644 index 221910d..0000000 --- a/samples/Sample.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -ddump-splices #-} -module Sample where - - -import Data.Function -import Language.Haskell.Tactic - -data Nat = Z | S Nat - deriving (Show) - -data List a = Nil | Cons a (List a) - deriving (Show) - -tactic "pair" [t| forall a b. a -> b -> (a,b) |] $ do - forall - intros_ - split - assumption - -tactic "foo" [t| forall a b c d. a -> (a -> b) -> (b -> c) -> (a, d -> c)|] $ do - auto 5 - -tactic "&" [t| forall a b. a -> (a -> b) -> b |] $ do - forall - intros ["x", "f"] - apply "f" - exact "x" - -tactic "if_" [t| forall a. a -> a -> Bool -> a |] $ do - forall - intros ["f", "t", "b"] - induction "b" <@> [exact "f", exact "t"] - --- No typeclass support yet for `apply` -add :: Int -> Int -> Int -add = (+) - -tactic "sum'" [t| List Int -> Int |] $ do - intro "x" - induction "x" <@> - [ exact (0 :: Integer) - , do - apply 'add <@> [exact "ind", exact "ind1"] - ] - -tactic "plus" [t| Nat -> Nat -> Nat |] $ do - intros ["n", "m"] - induction "n" <@> - [ exact "m" - , do - apply 'S - exact "ind" - ] - -tactic "trick" [t| forall a b c. Either a b -> (a -> c) -> (b -> c) -> c |] $ - auto 5 - -tactic "myFold" [t| forall a b. (a -> b -> b) -> b -> [a] -> b |] $ do - auto 5 - --- myFold' :: (a -> b -> b) -> b -> List a -> b --- myFold' f b as = fix (\ffix x -> case x of Nil -> b; Cons ind ind1 -> f ind (ffix ind1)) as diff --git a/src/Data/Traversable/Extensions.hs b/src/Data/Traversable/Extensions.hs deleted file mode 100644 index 7efcf68..0000000 --- a/src/Data/Traversable/Extensions.hs +++ /dev/null @@ -1,48 +0,0 @@ -module Data.Traversable.Extensions - ( - module T - , mapAccumLM - , mapAccumRM - ) where - -import Data.Traversable as T - -import Control.Applicative (liftA2) - -newtype StateLT s m a = StateLT { runStateLT :: s -> m (s,a) } - -instance (Functor m) => Functor (StateLT s m) where - fmap f (StateLT k) = StateLT $ \s -> fmap (\(s',a) -> (s', f a)) $ k s - -instance Monad m => Applicative (StateLT s m) where - pure a = StateLT $ \s -> return (s, a) - StateLT kf <*> StateLT kv = StateLT $ \s -> do - (s', f) <- kf s - (s'', v) <- kv s' - return (s'', f v) - liftA2 f (StateLT kx) (StateLT ky) = StateLT $ \s -> do - (s', x) <- kx s - (s'', y) <- ky s' - return (s'', f x y) - -mapAccumLM :: (Monad m, Traversable t) => (a -> b -> m (a,c)) -> a -> t b -> m (a, t c) -mapAccumLM f s t = runStateLT (traverse (StateLT . flip f) t) s - -newtype StateRT s m a = StateRT { runStateRT :: s -> m (s,a) } - -instance (Functor m) => Functor (StateRT s m) where - fmap f (StateRT k) = StateRT $ \s -> fmap (\(s',a) -> (s', f a)) $ k s - -instance Monad m => Applicative (StateRT s m) where - pure a = StateRT $ \s -> return (s, a) - StateRT kf <*> StateRT kv = StateRT $ \s -> do - (s', v) <- kv s - (s'', f) <- kf s' - return (s'', f v) - liftA2 f (StateRT kx) (StateRT ky) = StateRT $ \s -> do - (s', y) <- ky s - (s'', x) <- kx s' - return (s'', f x y) - -mapAccumRM :: (Monad m, Traversable t) => (a -> b -> m (a,c)) -> a -> t b -> m (a, t c) -mapAccumRM f s t = runStateRT (traverse (StateRT . flip f) t) s diff --git a/src/GHCi/InteractiveTactic.hs b/src/GHCi/InteractiveTactic.hs new file mode 100644 index 0000000..45fc18f --- /dev/null +++ b/src/GHCi/InteractiveTactic.hs @@ -0,0 +1,91 @@ + +-- | +-- Module : GHCi.InteractiveTactic +-- Copyright : (c) Reed Mullanix 2019 +-- License : BSD-style +-- Maintainer : reedmullanix@gmail.com +-- +{-# LANGUAGE PartialTypeSignatures #-} +module GHCi.InteractiveTactic +( hscTactic +) where + +import Data.Data + +import Control.Exception +import Control.Monad +import Control.Monad.IO.Class + +import Bag +import DynFlags +import Lexer +import FastString +import Outputable +import ErrUtils +import IOEnv +import HscMain +import HsDumpAst +import HscTypes +import GHC +import Parser +import TcRnDriver +import TcHsType +import RnUtils +import StringBuffer +import SrcLoc + +import Language.Haskell.Tactic.Patterns +import Language.Haskell.Tactic +-- -------------------------------------------------------------------- +-- Error handling, stolen from internals of HscMain +throwErrors :: ErrorMessages -> Hsc a +throwErrors = liftIO . throwIO . mkSrcErr + +handleWarnings :: Hsc () +handleWarnings = do + dflags <- getDynFlags + w <- getWarnings + liftIO $ printOrThrowWarnings dflags w + clearWarnings + +getWarnings :: Hsc WarningMessages +getWarnings = Hsc $ \_ w -> return (w, w) + +clearWarnings :: Hsc () +clearWarnings = Hsc $ \_ _ -> return ((), emptyBag) + +logWarnings :: WarningMessages -> Hsc () +logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w) + +logWarningsReportErrors :: Messages -> Hsc () +logWarningsReportErrors (warns,errs) = do + logWarnings warns + when (not $ isEmptyBag errs) $ throwErrors errs + + +-- -------------------------------------------------------------------- +hscParseType :: String -> Hsc (LHsType GhcPs) +hscParseType str = do + dflags <- getDynFlags + let buf = stringToStringBuffer str + loc = mkRealSrcLoc (fsLit "") 1 1 + case unP parseType (mkPState dflags buf loc) of + PFailed warnFn span err -> do + logWarningsReportErrors (warnFn dflags) + handleWarnings + let msg = mkPlainErrMsg dflags span err + throwErrors $ unitBag msg + POk pst ty -> do + logWarningsReportErrors (getMessages pst dflags) + liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parsed" (ppr ty) + liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser AST" $ showAstData NoBlankSrcSpan ty + return $ ty + +hscTactic :: HscEnv -> Tactic () -> String -> IO (Maybe Expr) +hscTactic hsc_env0 tac str = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + psTy <- hscParseType str + (ty, _kind) <- ioMsgMaybe $ tcRnType hsc_env True psTy + (msgs, ext) <- ioMsgMaybe $ runTcInteractive hsc_env $ runTactic ty tac + logWarningsReportErrors msgs + return ext \ No newline at end of file diff --git a/src/GHCi/Leak.hs b/src/GHCi/Leak.hs new file mode 100644 index 0000000..3f64b5d --- /dev/null +++ b/src/GHCi/Leak.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE RecordWildCards, LambdaCase #-} +module GHCi.Leak + ( LeakIndicators + , getLeakIndicators + , checkLeakIndicators + ) where + +import Control.Monad +import GHC +import Outputable +import HscTypes +import UniqDFM +import System.Mem +import System.Mem.Weak + +-- Checking for space leaks in GHCi. See #15111, and the +-- -fghci-leak-check flag. + +data LeakIndicators = LeakIndicators [LeakModIndicators] + +data LeakModIndicators = LeakModIndicators + { leakMod :: Weak HomeModInfo + , leakIface :: Weak ModIface + , leakDetails :: Weak ModDetails + , leakLinkable :: Maybe (Weak Linkable) + } + +-- | Grab weak references to some of the data structures representing +-- the currently loaded modules. +getLeakIndicators :: HscEnv -> IO LeakIndicators +getLeakIndicators HscEnv{..} = + fmap LeakIndicators $ + forM (eltsUDFM hsc_HPT) $ \hmi@HomeModInfo{..} -> do + leakMod <- mkWeakPtr hmi Nothing + leakIface <- mkWeakPtr hm_iface Nothing + leakDetails <- mkWeakPtr hm_details Nothing + leakLinkable <- mapM (`mkWeakPtr` Nothing) hm_linkable + return $ LeakModIndicators{..} + +-- | Look at the LeakIndicators collected by an earlier call to +-- `getLeakIndicators`, and print messasges if any of them are still +-- alive. +checkLeakIndicators :: DynFlags -> LeakIndicators -> IO () +checkLeakIndicators dflags (LeakIndicators leakmods) = do + performGC + forM_ leakmods $ \LeakModIndicators{..} -> do + deRefWeak leakMod >>= \case + Nothing -> return () + Just hmi -> + report ("HomeModInfo for " ++ + showSDoc dflags (ppr (mi_module (hm_iface hmi)))) (Just hmi) + deRefWeak leakIface >>= report "ModIface" + deRefWeak leakDetails >>= report "ModDetails" + forM_ leakLinkable $ \l -> deRefWeak l >>= report "Linkable" + where + report :: String -> Maybe a -> IO () + report _ Nothing = return () + report msg (Just _) = + putStrLn ("-fghci-leak-check: " ++ msg ++ " is still alive!") diff --git a/src/GHCi/UI.hs b/src/GHCi/UI.hs new file mode 100644 index 0000000..23b3581 --- /dev/null +++ b/src/GHCi/UI.hs @@ -0,0 +1,3896 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS -fno-cse #-} +-- -fno-cse is needed for GLOBAL_VAR's to behave properly + +----------------------------------------------------------------------------- +-- +-- GHC Interactive User Interface +-- +-- (c) The GHC Team 2005-2006 +-- +----------------------------------------------------------------------------- + +module GHCi.UI ( + interactiveUI, + GhciSettings(..), + defaultGhciSettings, + ghciCommands, + ghciWelcomeMsg + ) where + +#include "HsVersions.h" + +-- GHCi +import qualified GHCi.UI.Monad as GhciMonad ( args, runStmt, runDecls ) +import GHCi.UI.Monad hiding ( args, runStmt, runDecls ) +import GHCi.UI.Tags +import GHCi.UI.Info +import GHCi.InteractiveTactic +import Debugger + +-- The GHC interface +import GHCi +import GHCi.RemoteTypes +import GHCi.BreakArray +import DynFlags +import ErrUtils hiding (traceCmd) +import Finder +import GhcMonad ( modifySession, withSession ) +import qualified GHC +import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..), + TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc, + GetDocsFailure(..), + getModuleGraph, handleSourceError ) +import HsImpExp +import HsSyn +import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC, + setInteractivePrintName, hsc_dflags, msObjFilePath ) +import Module +import Name +import Packages ( trusted, getPackageDetails, getInstalledPackageDetails, + listVisibleModuleNames, pprFlag ) +import IfaceSyn ( showToHeader ) +import PprTyThing +import PrelNames +import RdrName ( getGRE_NameQualifier_maybes, getRdrName ) +import SrcLoc +import qualified Lexer + +import StringBuffer +import Outputable hiding ( printForUser, printForUserPartWay ) + +import DynamicLoading ( initializePlugins ) + +-- Other random utilities +import BasicTypes hiding ( isTopLevel ) +import Config +import Digraph +import Encoding +import FastString +import Linker +import Maybes ( orElse, expectJust ) +import NameSet +import Panic hiding ( showException ) +import Util +import qualified GHC.LanguageExtensions as LangExt + +-- Haskell Libraries +import System.Console.Haskeline as Haskeline + +import Control.Applicative hiding (empty) +import Control.DeepSeq (deepseq) +import Control.Monad as Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except + +import Data.Array +import qualified Data.ByteString.Char8 as BS +import Data.Char +import Data.Function +import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef ) +import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub, + partition, sort, sortBy ) +import qualified Data.Set as S +import Data.Maybe +import Data.Map (Map) +import qualified Data.Map as M +import Data.Time.LocalTime ( getZonedTime ) +import Data.Time.Format ( formatTime, defaultTimeLocale ) +import Data.Version ( showVersion ) +import Prelude hiding ((<>)) + +import Exception hiding (catch) +import Foreign hiding (void) +import GHC.Stack hiding (SrcLoc(..)) + +import System.Directory +import System.Environment +import System.Exit ( exitWith, ExitCode(..) ) +import System.FilePath +import System.Info +import System.IO +import System.IO.Error +import System.IO.Unsafe ( unsafePerformIO ) +import System.Process +import Text.Printf +import Text.Read ( readMaybe ) +import Text.Read.Lex (isSymbolChar) + +import Unsafe.Coerce + +#if !defined(mingw32_HOST_OS) +import System.Posix hiding ( getEnv ) +#else +import qualified System.Win32 +#endif + +import GHC.IO.Exception ( IOErrorType(InvalidArgument) ) +import GHC.IO.Handle ( hFlushAll ) +import GHC.TopHandler ( topHandler ) + +import GHCi.Leak + +import Language.Haskell.Tactic + +----------------------------------------------------------------------------- + +data GhciSettings = GhciSettings { + availableCommands :: [Command], + shortHelpText :: String, + fullHelpText :: String, + defPrompt :: PromptFunction, + defPromptCont :: PromptFunction + } + +defaultGhciSettings :: GhciSettings +defaultGhciSettings = + GhciSettings { + availableCommands = ghciCommands, + shortHelpText = defShortHelpText, + defPrompt = default_prompt, + defPromptCont = default_prompt_cont, + fullHelpText = defFullHelpText + } + +ghciWelcomeMsg :: String +ghciWelcomeMsg = "tactic-haskell, version 0.01" ++ "(GHC " ++ cProjectVersion ++ ")" + +ghciCommands :: [Command] +ghciCommands = map mkCmd [ + -- Hugs users are accustomed to :e, so make sure it doesn't overlap + ("?", keepGoing help, noCompletion), + ("add", keepGoingPaths addModule, completeFilename), + ("abandon", keepGoing abandonCmd, noCompletion), + ("auto", keepGoing' (tacticCmd (auto 5)), completeIdentifier), + ("break", keepGoing breakCmd, completeIdentifier), + ("back", keepGoing backCmd, noCompletion), + ("browse", keepGoing' (browseCmd False), completeModule), + ("browse!", keepGoing' (browseCmd True), completeModule), + ("cd", keepGoing' changeDirectory, completeFilename), + ("check", keepGoing' checkModule, completeHomeModule), + ("continue", keepGoing continueCmd, noCompletion), + ("cmd", keepGoing cmdCmd, completeExpression), + ("ctags", keepGoing createCTagsWithLineNumbersCmd, completeFilename), + ("ctags!", keepGoing createCTagsWithRegExesCmd, completeFilename), + ("def", keepGoing (defineMacro False), completeExpression), + ("def!", keepGoing (defineMacro True), completeExpression), + ("delete", keepGoing deleteCmd, noCompletion), + ("doc", keepGoing' docCmd, completeIdentifier), + ("edit", keepGoing' editFile, completeFilename), + ("etags", keepGoing createETagsFileCmd, completeFilename), + ("force", keepGoing forceCmd, completeExpression), + ("forward", keepGoing forwardCmd, noCompletion), + ("help", keepGoing help, noCompletion), + ("history", keepGoing historyCmd, noCompletion), + ("info", keepGoing' (info False), completeIdentifier), + ("info!", keepGoing' (info True), completeIdentifier), + ("issafe", keepGoing' isSafeCmd, completeModule), + ("kind", keepGoing' (kindOfType False), completeIdentifier), + ("kind!", keepGoing' (kindOfType True), completeIdentifier), + ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile), + ("load!", keepGoingPaths loadModuleDefer, completeHomeModuleOrFile), + ("list", keepGoing' listCmd, noCompletion), + ("module", keepGoing moduleCmd, completeSetModule), + ("main", keepGoing runMain, completeFilename), + ("print", keepGoing printCmd, completeExpression), + ("quit", quit, noCompletion), + ("reload", keepGoing' reloadModule, noCompletion), + ("reload!", keepGoing' reloadModuleDefer, noCompletion), + ("run", keepGoing runRun, completeFilename), + ("script", keepGoing' scriptCmd, completeFilename), + ("set", keepGoing setCmd, completeSetOptions), + ("seti", keepGoing setiCmd, completeSeti), + ("show", keepGoing showCmd, completeShowOptions), + ("showi", keepGoing showiCmd, completeShowiOptions), + ("sprint", keepGoing sprintCmd, completeExpression), + ("step", keepGoing stepCmd, completeIdentifier), + ("steplocal", keepGoing stepLocalCmd, completeIdentifier), + ("stepmodule",keepGoing stepModuleCmd, completeIdentifier), + ("type", keepGoing' typeOfExpr, completeExpression), + ("trace", keepGoing traceCmd, completeExpression), + ("unadd", keepGoingPaths unAddModule, completeFilename), + ("undef", keepGoing undefineMacro, completeMacro), + ("unset", keepGoing unsetOptions, completeSetOptions), + ("where", keepGoing whereCmd, noCompletion) + ] ++ map mkCmdHidden [ -- hidden commands + ("all-types", keepGoing' allTypesCmd), + ("complete", keepGoing completeCmd), + ("loc-at", keepGoing' locAtCmd), + ("type-at", keepGoing' typeAtCmd), + ("uses", keepGoing' usesCmd) + ] + where + mkCmd (n,a,c) = Command { cmdName = n + , cmdAction = a + , cmdHidden = False + , cmdCompletionFunc = c + } + + mkCmdHidden (n,a) = Command { cmdName = n + , cmdAction = a + , cmdHidden = True + , cmdCompletionFunc = noCompletion + } + +-- We initialize readline (in the interactiveUI function) to use +-- word_break_chars as the default set of completion word break characters. +-- This can be overridden for a particular command (for example, filename +-- expansion shouldn't consider '/' to be a word break) by setting the third +-- entry in the Command tuple above. +-- +-- NOTE: in order for us to override the default correctly, any custom entry +-- must be a SUBSET of word_break_chars. +word_break_chars :: String +word_break_chars = spaces ++ specials ++ symbols + +symbols, specials, spaces :: String +symbols = "!#$%&*+/<=>?@\\^|-~" +specials = "(),;[]`{}" +spaces = " \t\n" + +flagWordBreakChars :: String +flagWordBreakChars = " \t\n" + + +keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool) +keepGoing a str = keepGoing' (lift . a) str + +keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool +keepGoing' a str = a str >> return False + +keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool) +keepGoingPaths a str + = do case toArgs str of + Left err -> liftIO $ hPutStrLn stderr err + Right args -> a args + return False + +defShortHelpText :: String +defShortHelpText = "use :? for help.\n" + +defFullHelpText :: String +defFullHelpText = + " Commands available from the prompt:\n" ++ + "\n" ++ + " evaluate/run \n" ++ + " : repeat last command\n" ++ + " :{\\n ..lines.. \\n:}\\n multiline command\n" ++ + " :add [*] ... add module(s) to the current target set\n" ++ + " :browse[!] [[*]] display the names defined by module \n" ++ + " (!: more details; *: all top-level names)\n" ++ + " :cd change directory to \n" ++ + " :cmd run the commands returned by ::IO String\n" ++ + " :complete [] list completions for partial input string\n" ++ + " :ctags[!] [] create tags file for Vi (default: \"tags\")\n" ++ + " (!: use regex instead of line number)\n" ++ + " :def define command : (later defined command has\n" ++ + " precedence, :: is always a builtin command)\n" ++ + " :doc display docs for the given name (experimental)\n" ++ + " :edit edit file\n" ++ + " :edit edit last module\n" ++ + " :etags [] create tags file for Emacs (default: \"TAGS\")\n" ++ + " :help, :? display this list of commands\n" ++ + " :info[!] [ ...] display information about the given names\n" ++ + " (!: do not filter instances)\n" ++ + " :issafe [] display safe haskell information of module \n" ++ + " :kind[!] show the kind of \n" ++ + " (!: also print the normalised type)\n" ++ + " :load[!] [*] ... load module(s) and their dependents\n" ++ + " (!: defer type errors)\n" ++ + " :main [ ...] run the main function with the given arguments\n" ++ + " :module [+/-] [*] ... set the context for expression evaluation\n" ++ + " :quit exit GHCi\n" ++ + " :reload[!] reload the current module set\n" ++ + " (!: defer type errors)\n" ++ + " :run function [ ...] run the function with the given arguments\n" ++ + " :script run the script \n" ++ + " :type show the type of \n" ++ + " :type +d show the type of , defaulting type variables\n" ++ + " :type +v show the type of , with its specified tyvars\n" ++ + " :unadd ... remove module(s) from the current target set\n" ++ + " :undef undefine user-defined command :\n" ++ + " :! run the shell command \n" ++ + "\n" ++ + " -- Commands for debugging:\n" ++ + "\n" ++ + " :abandon at a breakpoint, abandon current computation\n" ++ + " :back [] go back in the history N steps (after :trace)\n" ++ + " :break [] [] set a breakpoint at the specified location\n" ++ + " :break set a breakpoint on the specified function\n" ++ + " :continue resume after a breakpoint\n" ++ + " :delete delete the specified breakpoint\n" ++ + " :delete * delete all breakpoints\n" ++ + " :force print , forcing unevaluated parts\n" ++ + " :forward [] go forward in the history N step s(after :back)\n" ++ + " :history [] after :trace, show the execution history\n" ++ + " :list show the source code around current breakpoint\n" ++ + " :list show the source code for \n" ++ + " :list [] show the source code around line number \n" ++ + " :print [ ...] show a value without forcing its computation\n" ++ + " :sprint [ ...] simplified version of :print\n" ++ + " :step single-step after stopping at a breakpoint\n"++ + " :step single-step into \n"++ + " :steplocal single-step within the current top-level binding\n"++ + " :stepmodule single-step restricted to the current module\n"++ + " :trace trace after stopping at a breakpoint\n"++ + " :trace evaluate with tracing on (see :history)\n"++ + + "\n" ++ + " -- Commands for changing settings:\n" ++ + "\n" ++ + " :set