Use HsTyPats in associated type family defaults
[ghc.git] / ghc / Main.hs
index 83d5238..f5836f5 100644 (file)
@@ -25,13 +25,13 @@ import HscMain          ( newHscEnv )
 import DriverPipeline   ( oneShot, compileFile )
 import DriverMkDepend   ( doMkDependHS )
 import DriverBkp   ( doBackpack )
-#ifdef GHCI
+#if defined(GHCI)
 import GHCi.UI          ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings )
 #endif
 
 -- Frontend plugins
-#ifdef GHCI
-import DynamicLoading   ( loadFrontendPlugin )
+#if defined(GHCI)
+import DynamicLoading   ( loadFrontendPlugin, initializePlugins  )
 import Plugins
 #else
 import DynamicLoading   ( pluginError )
@@ -40,14 +40,14 @@ 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 StaticFlags
-import DynFlags
+import DynFlags hiding (WarnReason(..))
 import ErrUtils
 import FastString
 import Outputable
@@ -74,6 +74,7 @@ import Control.Monad
 import Data.Char
 import Data.List
 import Data.Maybe
+import Prelude
 
 -----------------------------------------------------------------------------
 -- ToDo:
@@ -93,18 +94,7 @@ main = do
    hSetBuffering stdout LineBuffering
    hSetBuffering stderr LineBuffering
 
-   -- Handle GHC-specific character encoding flags, allowing us to control how
-   -- GHC produces output regardless of OS.
-   env <- getEnvironment
-   case lookup "GHC_CHARENC" env of
-    Just "UTF-8" -> do
-     hSetEncoding stdout utf8
-     hSetEncoding stderr utf8
-    _ -> do
-     -- Avoid GHC erroring out when trying to display unhandled characters
-     hSetTranslit stdout
-     hSetTranslit stderr
-
+   configureHandleEncoding
    GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
     -- 1. extract the -B flag from the args
     argv0 <- getArgs
@@ -113,13 +103,10 @@ main = do
         mbMinusB | null minusB_args = Nothing
                  | otherwise = Just (drop 2 (last minusB_args))
 
-    let argv1' = map (mkGeneralLocated "on the commandline") argv1
-    (argv2, staticFlagWarnings) <- parseStaticFlags argv1'
+    let argv2 = map (mkGeneralLocated "on the commandline") argv1
 
     -- 2. Parse the "mode" flags (--make, --interactive etc.)
-    (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2
-
-    let flagWarnings = staticFlagWarnings ++ modeFlagWarnings
+    (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
@@ -153,7 +140,7 @@ main = do
                 Right postLoadMode ->
                     main' postLoadMode dflags argv3 flagWarnings
 
-main' :: PostLoadMode -> DynFlags -> [Located String] -> [Located String]
+main' :: PostLoadMode -> DynFlags -> [Located String] -> [Warn]
       -> Ghc ()
 main' postLoadMode dflags0 args flagWarnings = do
   -- set the default GhcMode, HscTarget and GhcLink.  The HscTarget
@@ -166,7 +153,7 @@ main' postLoadMode dflags0 args flagWarnings = do
                DoInteractive   -> (CompManager, HscInterpreted, LinkInMemory)
                DoEval _        -> (CompManager, HscInterpreted, LinkInMemory)
                DoMake          -> (CompManager, dflt_target,    LinkBinary)
-               DoBackpack _    -> (CompManager, dflt_target,    LinkBinary)
+               DoBackpack      -> (CompManager, dflt_target,    LinkBinary)
                DoMkDependHS    -> (MkDepend,    dflt_target,    LinkBinary)
                DoAbiHash       -> (OneShot,     dflt_target,    LinkBinary)
                _               -> (OneShot,     dflt_target,    LinkBinary)
@@ -183,10 +170,16 @@ main' postLoadMode dflags0 args flagWarnings = do
       -- 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
-      dflags2  | DoInteractive <- postLoadMode = imp_qual_enabled
-               | DoEval _      <- postLoadMode = imp_qual_enabled
+      -- 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 imp_qual_enabled = dflags1 `gopt_set` Opt_ImplicitImportQualified
+        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
@@ -220,9 +213,23 @@ main' postLoadMode dflags0 args flagWarnings = do
 
   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
+     -- away. Note the asymmetry of FilePath.normalise:
+     --    Linux:   p/q -> p/q; p\q -> p\q
+     --    Windows: p/q -> p\q; p\q -> p\q
+     -- #12674: Filenames starting with a hypen get normalised from ./-foo.hs
+     -- to -foo.hs. We have to re-prepend the current directory.
+    normalise_hyp fp
+        | strt_dot_sl && "-" `isPrefixOf` nfp = cur_dir ++ nfp
+        | otherwise                           = nfp
+        where
+#if defined(mingw32_HOST_OS)
+          strt_dot_sl = "./" `isPrefixOf` fp || ".\\" `isPrefixOf` fp
+#else
+          strt_dot_sl = "./" `isPrefixOf` fp
+#endif
+          cur_dir = '.' : [pathSeparator]
+          nfp = normalise fp
+    normal_fileish_paths = map (normalise_hyp . unLoc) fileish_args
     (srcs, objs)         = partition_args normal_fileish_paths [] []
 
     dflags5 = dflags4 { ldInputs = map (FileOption "") objs
@@ -239,10 +246,6 @@ main' postLoadMode dflags0 args flagWarnings = do
       | v >= 5 -> liftIO $ dumpPackages dflags6
       | otherwise -> return ()
 
-  when (verbosity dflags6 >= 3) $ do
-        liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags)
-
-
   liftIO $ initUniqSupply (initialUnique dflags6) (uniqueIncrement dflags6)
         ---------------- Final sanity checking -----------
   liftIO $ checkOptions postLoadMode dflags6 srcs objs
@@ -256,20 +259,26 @@ main' postLoadMode dflags0 args flagWarnings = do
        DoMake                 -> doMake srcs
        DoMkDependHS           -> doMkDependHS (map fst srcs)
        StopBefore p           -> liftIO (oneShot hsc_env p srcs)
-       DoInteractive          -> ghciUI srcs Nothing
-       DoEval exprs           -> ghciUI srcs $ Just $ reverse exprs
+       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 b           -> doBackpack b
+       DoBackpack             -> doBackpack (map fst srcs)
 
   liftIO $ dumpFinalStats dflags6
 
-ghciUI :: [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc ()
-#ifndef GHCI
-ghciUI _ _ = throwGhcException (CmdLineError "not built for interactive use")
+ghciUI :: HscEnv -> DynFlags -> [(FilePath, Maybe Phase)] -> Maybe [String]
+       -> Ghc ()
+#if !defined(GHCI)
+ghciUI _ _ _ _ =
+  throwGhcException (CmdLineError "not built for interactive use")
 #else
-ghciUI     = interactiveUI defaultGhciSettings
+ghciUI hsc_env dflags0 srcs maybe_expr = do
+  dflags1 <- liftIO (initializePlugins hsc_env dflags0)
+  _ <- GHC.setSessionDynFlags dflags1
+  interactiveUI defaultGhciSettings srcs maybe_expr
 #endif
 
 -- -----------------------------------------------------------------------------
@@ -463,7 +472,7 @@ data PostLoadMode
   | StopBefore Phase        -- ghc -E | -C | -S
                             -- StopBefore StopLn is the default
   | DoMake                  -- ghc --make
-  | DoBackpack String       -- ghc --backpack foo.bkp
+  | DoBackpack              -- ghc --backpack foo.bkp
   | DoInteractive           -- ghc --interactive
   | DoEval [String]         -- ghc -e foo -e bar => DoEval ["bar", "foo"]
   | DoAbiHash               -- ghc --abi-hash
@@ -490,8 +499,8 @@ doEvalMode str = mkPostLoadMode (DoEval [str])
 doFrontendMode :: String -> Mode
 doFrontendMode str = mkPostLoadMode (DoFrontend (mkModuleName str))
 
-doBackpackMode :: String -> Mode
-doBackpackMode str = mkPostLoadMode (DoBackpack str)
+doBackpackMode :: Mode
+doBackpackMode = mkPostLoadMode DoBackpack
 
 mkPostLoadMode :: PostLoadMode -> Mode
 mkPostLoadMode = Right . Right
@@ -512,7 +521,7 @@ isDoEvalMode :: Mode -> Bool
 isDoEvalMode (Right (Right (DoEval _))) = True
 isDoEvalMode _ = False
 
-#ifdef GHCI
+#if defined(GHCI)
 isInteractiveMode :: PostLoadMode -> Bool
 isInteractiveMode DoInteractive = True
 isInteractiveMode _             = False
@@ -551,7 +560,7 @@ isCompManagerMode _             = False
 parseModeFlags :: [Located String]
                -> IO (Mode,
                       [Located String],
-                      [Located String])
+                      [Warn])
 parseModeFlags args = do
   let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =
           runCmdLine (processArgs mode_flags args)
@@ -562,7 +571,7 @@ parseModeFlags args = do
 
   -- See Note [Handling errors when parsing commandline flags]
   unless (null errs1 && null errs2) $ throwGhcException $ errorsToGhcException $
-      map (("on the commandline", )) $ map unLoc errs1 ++ errs2
+      map (("on the commandline", )) $ map (unLoc . errMsg) errs1 ++ errs2
 
   return (mode, flags' ++ leftover, warns)
 
@@ -622,7 +631,7 @@ mode_flags =
   , defFlag "C"            (PassFlag (setMode (stopBeforeMode HCc)))
   , defFlag "S"            (PassFlag (setMode (stopBeforeMode (As False))))
   , defFlag "-make"        (PassFlag (setMode doMakeMode))
-  , defFlag "-backpack"    (SepArg   (\s -> setMode (doBackpackMode s) "-backpack"))
+  , defFlag "-backpack"    (PassFlag (setMode doBackpackMode))
   , defFlag "-interactive" (PassFlag (setMode doInteractiveMode))
   , defFlag "-abi-hash"    (PassFlag (setMode doAbiHashMode))
   , defFlag "e"            (SepArg   (\s -> setMode (doEvalMode s) "-e"))
@@ -743,7 +752,7 @@ showBanner :: PostLoadMode -> DynFlags -> IO ()
 showBanner _postLoadMode dflags = do
    let verb = verbosity dflags
 
-#ifdef GHCI
+#if defined(GHCI)
    -- Show the GHCi banner
    when (isInteractiveMode _postLoadMode && verb >= 1) $ putStrLn ghciWelcomeMsg
 #endif
@@ -775,17 +784,9 @@ showOptions isInteractive = putStr (unlines availableOptions)
     where
       availableOptions = concat [
         flagsForCompletion isInteractive,
-        map ('-':) (concat [
-            getFlagNames mode_flags
-          , (filterUnwantedStatic . getFlagNames $ flagsStatic)
-          , flagsStaticNames
-          ])
+        map ('-':) (getFlagNames mode_flags)
         ]
       getFlagNames opts         = map flagName opts
-      -- this is a hack to get rid of two unwanted entries that get listed
-      -- as static flags. Hopefully this hack will disappear one day together
-      -- with static flags
-      filterUnwantedStatic      = filter (`notElem`["f", "fno-"])
 
 showGhcUsage :: DynFlags -> IO ()
 showGhcUsage = showUsage False
@@ -810,33 +811,29 @@ dumpFinalStats 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)
-                         ])
+  segments <- getFastStringTable
+  let buckets = concat segments
+      bucketsPerSegment = map length segments
+      entriesPerBucket = map length buckets
+      entries = sum entriesPerBucket
+      hasZ = sum $ map (length . filter hasZEncoding) buckets
+      msg = text "FastString stats:" $$ nest 4 (vcat
+        [ text "segments:         " <+> int (length segments)
+        , text "buckets:          " <+> int (sum bucketsPerSegment)
+        , text "entries:          " <+> int entries
+        , text "largest segment:  " <+> int (maximum bucketsPerSegment)
+        , text "smallest segment: " <+> int (minimum bucketsPerSegment)
+        , text "longest bucket:   " <+> int (maximum entriesPerBucket)
+        , text "has z-encoding:   " <+> (hasZ `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 will is not counted as "z-encoded".  Only strings whose
+        -- 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) <> 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
+   x `pcntOf` y = int ((x * 100) `quot` y) Outputable.<> char '%'
 
 showPackages, dumpPackages, dumpPackagesSimple :: DynFlags -> IO ()
 showPackages       dflags = putStrLn (showSDoc dflags (pprPackages dflags))
@@ -847,13 +844,14 @@ dumpPackagesSimple dflags = putMsg dflags (pprPackagesSimple dflags)
 -- Frontend plugin support
 
 doFrontend :: ModuleName -> [(String, Maybe Phase)] -> Ghc ()
-#ifndef GHCI
+#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 (frontendPluginOpts (hsc_dflags hsc_env)) srcs
+    frontend frontend_plugin
+      (reverse $ frontendPluginOpts (hsc_dflags hsc_env)) srcs
 #endif
 
 -- -----------------------------------------------------------------------------
@@ -874,7 +872,7 @@ 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,
+-- The resulting hash is the MD5 of the GHC version used (#5328,
 -- see 'hiVersion') and of the existing ABI hash from each module (see
 -- 'mi_mod_hash').
 abiHash :: [String] -- ^ List of module names
@@ -915,9 +913,18 @@ unknownFlagsErr fs = throwGhcException $ UsageError $ concatMap oneError fs
   where
     oneError f =
         "unrecognised flag: " ++ f ++ "\n" ++
-        (case fuzzyMatch f (nub allNonDeprecatedFlags) of
+        (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]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -939,5 +946,18 @@ people since we're linking GHC dynamically, but most things themselves
 link statically.
 -}
 
+-- If GHC_LOADED_INTO_GHCI is not set when GHC is loaded into GHCi, then
+-- running it causes an error like this:
+--
+-- Loading temp shared object failed:
+-- /tmp/ghc13836_0/libghc_1872.so: undefined symbol: initGCStatistics
+--
+-- Skipping the foreign call fixes this problem, and the outer GHCi
+-- should have already made this call anyway.
+#if defined(GHC_LOADED_INTO_GHCI)
+initGCStatistics :: IO ()
+initGCStatistics = return ()
+#else
 foreign import ccall safe "initGCStatistics"
   initGCStatistics :: IO ()
+#endif