compiler/hsSyn/HsImpExp.hs

@@ -13,6 +13,7 @@ module HsImpExp where
 import Module           ( ModuleName )
 import HsDoc            ( HsDocString )
 import OccName          ( HasOccName(..), isTcOcc, isSymOcc )
+import BasicTypes       ( SourceText )
 
 import Outputable
 import FastString
@@ -34,11 +35,14 @@ type LImportDecl name = Located (ImportDecl name)
         -- ^ When in a list this may have
         --
         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi'
-        --
+
+        -- For details on above see note [Api annotations] in ApiAnnotation
 
 -- | A single Haskell @import@ declaration.
 data ImportDecl name
   = ImportDecl {
+      ideclSourceSrc :: Maybe SourceText,
+                                 -- Note [Pragma source text] in BasicTypes
       ideclName      :: Located ModuleName, -- ^ Module name.
       ideclPkgQual   :: Maybe FastString,  -- ^ Package qualifier.
       ideclSource    :: Bool,              -- ^ True <=> {-\# SOURCE \#-} import
@@ -64,10 +68,12 @@ data ImportDecl name
      --    'ApiAnnotation.AnnClose' attached
      --     to location in ideclHiding
 
+     -- For details on above see note [Api annotations] in ApiAnnotation
        deriving (Data, Typeable)
 
 simpleImportDecl :: ModuleName -> ImportDecl name
 simpleImportDecl mn = ImportDecl {
+      ideclSourceSrc = Nothing,
       ideclName      = noLoc mn,
       ideclPkgQual   = Nothing,
       ideclSource    = False,
@@ -124,31 +130,42 @@ type LIE name = Located (IE name)
         -- ^ When in a list this may have
         --
         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma'
-        --
+
+        -- For details on above see note [Api annotations] in ApiAnnotation
 
 -- | Imported or exported entity.
 data IE name
   = IEVar       (Located name)
         -- ^ - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnPattern',
         --             'ApiAnnotation.AnnType'
-  | IEThingAbs           name      -- ^ Class/Type (can't tell)
+
+        -- For details on above see note [Api annotations] in ApiAnnotation
+  | IEThingAbs  (Located name)     -- ^ Class/Type (can't tell)
         --  - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnPattern',
         --             'ApiAnnotation.AnnType','ApiAnnotation.AnnVal'
+
+        -- For details on above see note [Api annotations] in ApiAnnotation
   | IEThingAll  (Located name)     -- ^ Class/Type plus all methods/constructors
         --
         -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen',
         --       'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose',
         --                                 'ApiAnnotation.AnnType'
 
+        -- For details on above see note [Api annotations] in ApiAnnotation
+
   | IEThingWith (Located name) [Located name]
                  -- ^ Class/Type plus some methods/constructors
         -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen',
         --                                   'ApiAnnotation.AnnClose',
         --                                   'ApiAnnotation.AnnComma',
         --                                   'ApiAnnotation.AnnType'
+
+        -- For details on above see note [Api annotations] in ApiAnnotation
   | IEModuleContents  (Located ModuleName) -- ^ (Export Only)
         --
         -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnModule'
+
+        -- For details on above see note [Api annotations] in ApiAnnotation
   | IEGroup             Int HsDocString  -- ^ Doc section heading
   | IEDoc               HsDocString      -- ^ Some documentation
   | IEDocNamed          String           -- ^ Reference to named doc
@@ -156,14 +173,14 @@ data IE name
 
 ieName :: IE name -> name
 ieName (IEVar (L _ n))         = n
-ieName (IEThingAbs  n)         = n
+ieName (IEThingAbs  (L _ n))   = n
 ieName (IEThingWith (L _ n) _) = n
 ieName (IEThingAll  (L _ n))   = n
 ieName _ = panic "ieName failed pattern match!"
 
 ieNames :: IE a -> [a]
 ieNames (IEVar       (L _ n)   ) = [n]
-ieNames (IEThingAbs       n    ) = [n]
+ieNames (IEThingAbs  (L _ n)   ) = [n]
 ieNames (IEThingAll  (L _ n)   ) = [n]
 ieNames (IEThingWith (L _ n) ns) = n : map unLoc ns
 ieNames (IEModuleContents _    ) = []
@@ -180,7 +197,7 @@ pprImpExp name = type_pref <+> pprPrefixOcc name
 
 instance (HasOccName name, OutputableBndr name) => Outputable (IE name) where
     ppr (IEVar          var)    = pprPrefixOcc (unLoc var)
-    ppr (IEThingAbs     thing)  = pprImpExp thing
+    ppr (IEThingAbs     thing)  = pprImpExp (unLoc thing)
     ppr (IEThingAll      thing) = hcat [pprImpExp (unLoc thing), text "(..)"]
     ppr (IEThingWith thing withs)
         = pprImpExp (unLoc thing) <> parens (fsep (punctuate comma

compiler/hsSyn/HsLit.hs

@@ -19,12 +19,11 @@ module HsLit where
 #include "HsVersions.h"
 
 import {-# SOURCE #-} HsExpr( SyntaxExpr, pprExpr )
-import BasicTypes ( FractionalLit(..) )
+import BasicTypes ( FractionalLit(..),SourceText )
 import Type       ( Type )
 import Outputable
 import FastString
 import PlaceHolder ( PostTc,PostRn,DataId )
-import Lexer       ( SourceText )
 
 import Data.ByteString (ByteString)
 import Data.Data hiding ( Fixity )
@@ -37,7 +36,8 @@ import Data.Data hiding ( Fixity )
 ************************************************************************
 -}
 
--- Note [literal source text] for SourceText fields in the following
+-- Note [Literal source text] in BasicTypes for SourceText fields in
+-- the following
 data HsLit
   = HsChar          SourceText Char        -- Character
   | HsCharPrim      SourceText Char        -- Unboxed character
@@ -84,7 +84,8 @@ data HsOverLit id       -- An overloaded literal
   deriving (Typeable)
 deriving instance (DataId id) => Data (HsOverLit id)
 
--- Note [literal source text] for SourceText fields in the following
+-- Note [Literal source text] in BasicTypes for SourceText fields in
+-- the following
 data OverLitVal
   = HsIntegral   !SourceText !Integer    -- Integer-looking literals;
   | HsFractional !FractionalLit          -- Frac-looking literals
@@ -95,36 +96,6 @@ overLitType :: HsOverLit a -> PostTc a Type
 overLitType = ol_type
 
 {-
-Note [literal source text]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-The lexer/parser converts literals from their original source text
-versions to an appropriate internal representation. This is a problem
-for tools doing source to source conversions, so the original source
-text is stored in literals where this can occur.
-
-Motivating examples for HsLit
-
-  HsChar          '\n', '\x20`
-  HsCharPrim      '\x41`#
-  HsString        "\x20\x41" == " A"
-  HsStringPrim    "\x20"#
-  HsInt           001
-  HsIntPrim       002#
-  HsWordPrim      003##
-  HsInt64Prim     004##
-  HsWord64Prim    005##
-  HsInteger       006
-
-For OverLitVal
-
-  HsIntegral      003,0x001
-  HsIsString      "\x41nd"
-
-
-
-
-
 Note [ol_rebindable]
 ~~~~~~~~~~~~~~~~~~~~
 The ol_rebindable field is True if this literal is actually

compiler/hsSyn/HsPat.hs

@@ -59,6 +59,8 @@ type OutPat id = LPat id        -- No 'In' constructors
 type LPat id = Located (Pat id)
 
 -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang'
+
+-- For details on above see note [Api annotations] in ApiAnnotation
 data Pat id
   =     ------------ Simple patterns ---------------
     WildPat     (PostTc id Type)        -- Wild card
@@ -67,10 +69,25 @@ data Pat id
 
   | VarPat      id                      -- Variable
   | LazyPat     (LPat id)               -- Lazy pattern
+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde'
+
+    -- For details on above see note [Api annotations] in ApiAnnotation
+
   | AsPat       (Located id) (LPat id)  -- As pattern
+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt'
+
+    -- For details on above see note [Api annotations] in ApiAnnotation
+
   | ParPat      (LPat id)               -- Parenthesised pattern
                                         -- See Note [Parens in HsSyn] in HsExpr
+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
+    --                                    'ApiAnnotation.AnnClose' @')'@
+
+    -- For details on above see note [Api annotations] in ApiAnnotation
   | BangPat     (LPat id)               -- Bang pattern
+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang'
+
+    -- For details on above see note [Api annotations] in ApiAnnotation
 
         ------------ Lists, tuples, arrays ---------------
   | ListPat     [LPat id]                            -- Syntactic list
@@ -79,6 +96,10 @@ data Pat id
                    -- For OverloadedLists a Just (ty,fn) gives
                    -- overall type of the pattern, and the toList
                    -- function to convert the scrutinee to a list value
+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@,
+    --                                    'ApiAnnotation.AnnClose' @']'@
+
+    -- For details on above see note [Api annotations] in ApiAnnotation
 
   | TuplePat    [LPat id]        -- Tuple sub-patterns
                 Boxity           -- UnitPat is TuplePat []
@@ -99,10 +120,17 @@ data Pat id
         -- of the tuple is of type 'a' not Int.  See selectMatchVar
         -- (June 14: I'm not sure this comment is right; the sub-patterns
         --           will be wrapped in CoPats, no?)
+    -- ^ - 'ApiAnnotation.AnnKeywordId' :
+    --            'ApiAnnotation.AnnOpen' @'('@ or @'(#'@,
+    --            'ApiAnnotation.AnnClose' @')'@ or  @'#)'@
 
+    -- For details on above see note [Api annotations] in ApiAnnotation
   | PArrPat     [LPat id]               -- Syntactic parallel array
                 (PostTc id Type)        -- The type of the elements
+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@,
+    --                                    'ApiAnnotation.AnnClose' @':]'@
 
+    -- For details on above see note [Api annotations] in ApiAnnotation
         ------------ Constructor patterns ---------------
   | ConPatIn    (Located id)
                 (HsConPatDetails id)
@@ -124,6 +152,9 @@ data Pat id
     }
 
         ------------ View patterns ---------------
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
   | ViewPat       (LHsExpr id)
                   (LPat id)
                   (PostTc id Type)  -- The overall type of the pattern
@@ -131,6 +162,10 @@ data Pat id
                                     -- for hsPatType.
 
         ------------ Pattern splices ---------------
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@
+  --        'ApiAnnotation.AnnClose' @')'@
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
   | SplicePat       (HsSplice id)
 
         ------------ Quasiquoted patterns ---------------
@@ -143,17 +178,23 @@ data Pat id
 
   | NPat                -- Used for all overloaded literals,
                         -- including overloaded strings with -XOverloadedStrings
-                    (HsOverLit id)              -- ALWAYS positive
+                    (Located (HsOverLit id))    -- ALWAYS positive
                     (Maybe (SyntaxExpr id))     -- Just (Name of 'negate') for negative
                                                 -- patterns, Nothing otherwise
                     (SyntaxExpr id)             -- Equality checker, of type t->t->Bool
 
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
   | NPlusKPat       (Located id)        -- n+k pattern
-                    (HsOverLit id)      -- It'll always be an HsIntegral
+                    (Located (HsOverLit id)) -- It'll always be an HsIntegral
                     (SyntaxExpr id)     -- (>=) function, of type t->t->Bool
                     (SyntaxExpr id)     -- Name of '-' (see RnEnv.lookupSyntaxName)
 
         ------------ Pattern type signatures ---------------
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
   | SigPatIn        (LPat id)                  -- Pattern with a type signature
                     (HsWithBndrs id (LHsType id)) -- Signature can bind both
                                                   -- kind and type vars
@@ -214,6 +255,8 @@ data HsRecFields id arg         -- A bunch of record fields
 
 type LHsRecField id arg = Located (HsRecField id arg)
 -- |  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual',
+
+-- For details on above see note [Api annotations] in ApiAnnotation
 data HsRecField id arg = HsRecField {
         hsRecFieldId  :: Located id,
         hsRecFieldArg :: arg,           -- Filled in by renamer

compiler/hsSyn/HsSyn.hs

@@ -40,7 +40,7 @@ import HsImpExp
 import HsLit
 import PlaceHolder
 import HsPat
-import HsTypes
+import HsTypes  hiding  ( mkHsForAllTy )
 import BasicTypes       ( Fixity, WarningTxt )
 import HsUtils
 import HsDoc
@@ -73,7 +73,8 @@ data HsModule name
         --
         --  - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen'
         --                                   ,'ApiAnnotation.AnnClose'
-        --
+
+        -- For details on above see note [Api annotations] in ApiAnnotation
       hsmodImports :: [LImportDecl name],
         -- ^ We snaffle interesting stuff out of the imported interfaces early
         -- on, adding that info to TyDecls/etc; so this list is often empty,
@@ -86,12 +87,15 @@ data HsModule name
         --  - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen'
         --                                   ,'ApiAnnotation.AnnClose'
         --
+
+        -- For details on above see note [Api annotations] in ApiAnnotation
       hsmodHaddockModHeader :: Maybe LHsDocString
         -- ^ Haddock module info and description, unparsed
         --
         --  - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen'
         --                                   ,'ApiAnnotation.AnnClose'
-        --
+
+        -- For details on above see note [Api annotations] in ApiAnnotation
    }
      -- ^ 'ApiAnnotation.AnnKeywordId's
      --
@@ -100,7 +104,8 @@ data HsModule name
      --  - 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnSemi',
      --    'ApiAnnotation.AnnClose' for explicit braces and semi around
      --    hsmodImports,hsmodDecls if this style is used.
-     --
+
+     -- For details on above see note [Api annotations] in ApiAnnotation
       deriving (Typeable)
 deriving instance (DataId name) => Data (HsModule name)
 

compiler/hsSyn/HsTypes.hs

@@ -14,6 +14,7 @@ HsTypes: Abstract syntax: user-defined types
 {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
                                       -- in module PlaceHolder
 {-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE CPP #-}
 
 module HsTypes (
         HsType(..), LHsType, HsKind, LHsKind,
@@ -28,13 +29,16 @@ module HsTypes (
         HsTyLit(..),
         HsIPName(..), hsIPNameFS,
 
-        LBangType, BangType, HsBang(..),
+        LBangType, BangType, HsBang(..), HsSrcBang, HsImplBang,
         getBangType, getBangStrictness,
 
         ConDeclField(..), LConDeclField, pprConDeclFields,
 
         mkHsQTvs, hsQTvBndrs, isHsKindedTyVar, hsTvbAllKinded,
         mkExplicitHsForAllTy, mkImplicitHsForAllTy, mkQualifiedHsForAllTy,
+        mkHsForAllTy,
+        flattenTopLevelLHsForAllTy,flattenTopLevelHsForAllTy,
+        flattenHsForAllTyKeepAnns,
         hsExplicitTvs,
         hsTyVarName, mkHsWithBndrs, hsLKiTyVarNames,
         hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
@@ -55,7 +59,7 @@ import PlaceHolder ( PostTc,PostRn,DataId,PlaceHolder(..) )
 
 import Name( Name )
 import RdrName( RdrName )
-import DataCon( HsBang(..) )
+import DataCon( HsBang(..), HsSrcBang, HsImplBang )
 import TysPrim( funTyConName )
 import Type
 import HsDoc
@@ -64,10 +68,14 @@ import SrcLoc
 import StaticFlags
 import Outputable
 import FastString
+import Lexer ( AddAnn, mkParensApiAnn )
 import Maybes( isJust )
 
 import Data.Data hiding ( Fixity )
 import Data.Maybe ( fromMaybe )
+#if __GLASGOW_HASKELL__ < 709
+import Data.Monoid hiding ((<>))
+#endif
 
 {-
 ************************************************************************
@@ -106,7 +114,7 @@ getBangType :: LHsType a -> LHsType a
 getBangType (L _ (HsBangTy _ ty)) = ty
 getBangType ty                    = ty
 
-getBangStrictness :: LHsType a -> HsBang
+getBangStrictness :: LHsType a -> HsSrcBang
 getBangStrictness (L _ (HsBangTy s _)) = s
 getBangStrictness _                    = HsNoBang
 
@@ -132,14 +140,22 @@ See also Note [Kind and type-variable binders] in RnTypes
 -}
 
 type LHsContext name = Located (HsContext name)
+      -- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnUnit'
+
+      -- For details on above see note [Api annotations] in ApiAnnotation
 
 type HsContext name = [LHsType name]
 
 type LHsType name = Located (HsType name)
       -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when
       --   in a list
+
+      -- For details on above see note [Api annotations] in ApiAnnotation
 type HsKind name = HsType name
 type LHsKind name = Located (HsKind name)
+      -- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
+
+      -- For details on above see note [Api annotations] in ApiAnnotation
 
 type LHsTyVarBndr name = Located (HsTyVarBndr name)
 
@@ -164,6 +180,20 @@ emptyHsQTvs =  HsQTvs { hsq_kvs = [], hsq_tvs = [] }
 hsQTvBndrs :: LHsTyVarBndrs name -> [LHsTyVarBndr name]
 hsQTvBndrs = hsq_tvs
 
+instance Monoid (LHsTyVarBndrs name) where
+  mempty = emptyHsQTvs
+  mappend (HsQTvs kvs1 tvs1) (HsQTvs kvs2 tvs2)
+    = HsQTvs (kvs1 ++ kvs2) (tvs1 ++ tvs2)
+
+------------------------------------------------
+--            HsWithBndrs
+-- Used to quantify the binders of a type in cases
+-- when a HsForAll isn't appropriate:
+--    * Patterns in a type/data family instance (HsTyPats)
+--    * Type of a rule binder (RuleBndr)
+--    * Pattern type signatures (SigPatIn)
+-- In the last of these, wildcards can happen, so we must accommodate them
+
 data HsWithBndrs name thing
   = HsWB { hswb_cts :: thing             -- Main payload (type or list of types)
          , hswb_kvs :: PostRn name [Name] -- Kind vars
@@ -201,11 +231,13 @@ data HsTyVarBndr name
          name
 
   | KindedTyVar
-         name
+         (Located name)
          (LHsKind name)  -- The user-supplied kind signature
         -- ^
         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
         --          'ApiAnnotation.AnnDcolon', 'ApiAnnotation.AnnClose'
+
+        -- For details on above see note [Api annotations] in ApiAnnotation
   deriving (Typeable)
 deriving instance (DataId name) => Data (HsTyVarBndr name)
 
@@ -218,10 +250,6 @@ isHsKindedTyVar (KindedTyVar {}) = True
 hsTvbAllKinded :: LHsTyVarBndrs name -> Bool
 hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvBndrs
 
--- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon',
---            'ApiAnnotation.AnnTilde','ApiAnnotation.AnnRarrow',
---            'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
---            'ApiAnnotation.AnnComma'
 data HsType name
   = HsForAllTy  HsExplicitFlag          -- Renamer leaves this flag unchanged, to record the way
                                         -- the user wrote it originally, so that the printer can
@@ -237,73 +265,167 @@ data HsType name
                 (LHsType name)
       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForall',
       --         'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow'
+
+      -- For details on above see note [Api annotations] in ApiAnnotation
+
   | HsTyVar             name            -- Type variable, type constructor, or data constructor
                                         -- see Note [Promotions (HsTyVar)]
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : None
+
+      -- For details on above see note [Api annotations] in ApiAnnotation
 
   | HsAppTy             (LHsType name)
                         (LHsType name)
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : None
+
+      -- For details on above see note [Api annotations] in ApiAnnotation
 
   | HsFunTy             (LHsType name)   -- function type
                         (LHsType name)
       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow',
 
+      -- For details on above see note [Api annotations] in ApiAnnotation
+
   | HsListTy            (LHsType name)  -- Element type
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@,
+      --         'ApiAnnotation.AnnClose' @']'@
+
+      -- For details on above see note [Api annotations] in ApiAnnotation
 
   | HsPArrTy            (LHsType name)  -- Elem. type of parallel array: [:t:]
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@,
+      --         'ApiAnnotation.AnnClose' @':]'@
+
+      -- For details on above see note [Api annotations] in ApiAnnotation
 
   | HsTupleTy           HsTupleSort
                         [LHsType name]  -- Element types (length gives arity)
+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(' or '(#'@,
+    --         'ApiAnnotation.AnnClose' @')' or '#)'@
+
+    -- For details on above see note [Api annotations] in ApiAnnotation
 
   | HsOpTy              (LHsType name) (LHsTyOp name) (LHsType name)
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : None
+
+      -- For details on above see note [Api annotations] in ApiAnnotation
 
   | HsParTy             (LHsType name)   -- See Note [Parens in HsSyn] in HsExpr
         -- Parenthesis preserved for the precedence re-arrangement in RnTypes
         -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c!
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
+      --         'ApiAnnotation.AnnClose' @')'@
+
+      -- For details on above see note [Api annotations] in ApiAnnotation
 
   | HsIParamTy          HsIPName         -- (?x :: ty)
                         (LHsType name)   -- Implicit parameters as they occur in contexts
+      -- ^
+      -- > (?x :: ty)
+      --
+      -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
+
+      -- For details on above see note [Api annotations] in ApiAnnotation
 
   | HsEqTy              (LHsType name)   -- ty1 ~ ty2
                         (LHsType name)   -- Always allowed even without TypeOperators, and has special kinding rule
+      -- ^
+      -- > ty1 ~ ty2
+      --
+      -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde'
+
+      -- For details on above see note [Api annotations] in ApiAnnotation
 
   | HsKindSig           (LHsType name)  -- (ty :: kind)
                         (LHsKind name)  -- A type with a kind signature
+      -- ^
+      -- > (ty :: kind)
+      --
+      -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
+      --         'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose' @')'@
+
+      -- For details on above see note [Api annotations] in ApiAnnotation
 
   | HsQuasiQuoteTy      (HsQuasiQuote name)
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : None
+
+      -- For details on above see note [Api annotations] in ApiAnnotation
 
   | HsSpliceTy          (HsSplice name)
                         (PostTc name Kind)
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@,
+      --         'ApiAnnotation.AnnClose' @')'@
+
+      -- For details on above see note [Api annotations] in ApiAnnotation
 
   | HsDocTy             (LHsType name) LHsDocString -- A documented type
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : None
+
+      -- For details on above see note [Api annotations] in ApiAnnotation
+
+  | HsBangTy    HsSrcBang (LHsType name)   -- Bang-style type annotations
+      -- ^ - 'ApiAnnotation.AnnKeywordId' :
+      --         'ApiAnnotation.AnnOpen' @'{-\# UNPACK' or '{-\# NOUNPACK'@,
+      --         'ApiAnnotation.AnnClose' @'#-}'@
+      --         'ApiAnnotation.AnnBang' @\'!\'@
+
+      -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsBangTy    HsBang (LHsType name)   -- Bang-style type annotations
   | HsRecTy     [LConDeclField name]    -- Only in data type declarations
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@,
+      --         'ApiAnnotation.AnnClose' @'}'@
+
+      -- For details on above see note [Api annotations] in ApiAnnotation
 
   | HsCoreTy Type       -- An escape hatch for tunnelling a *closed*
                         -- Core Type through HsSyn.
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : None
+
+      -- For details on above see note [Api annotations] in ApiAnnotation
 
   | HsExplicitListTy       -- A promoted explicit list
         (PostTc name Kind) -- See Note [Promoted lists and tuples]
         [LHsType name]
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'["@,
+      --         'ApiAnnotation.AnnClose' @']'@
+
+      -- For details on above see note [Api annotations] in ApiAnnotation
 
   | HsExplicitTupleTy      -- A promoted explicit tuple
         [PostTc name Kind] -- See Note [Promoted lists and tuples]
         [LHsType name]
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'("@,
+      --         'ApiAnnotation.AnnClose' @')'@
+
+      -- For details on above see note [Api annotations] in ApiAnnotation
 
   | HsTyLit HsTyLit      -- A promoted numeric literal.
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : None
+
+      -- For details on above see note [Api annotations] in ApiAnnotation
 
   | HsWrapTy HsTyWrapper (HsType name)  -- only in typechecker output
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : None
+
+      -- For details on above see note [Api annotations] in ApiAnnotation
 
   | HsWildcardTy           -- A type wildcard
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : None
+
+      -- For details on above see note [Api annotations] in ApiAnnotation
 
   | HsNamedWildcardTy name -- A named wildcard
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : None
+
+      -- For details on above see note [Api annotations] in ApiAnnotation
   deriving (Typeable)
 deriving instance (DataId name) => Data (HsType name)
 
-
+-- Note [Literal source text] in BasicTypes for SourceText fields in
+-- the following
 data HsTyLit
-  = HsNumTy Integer
-  | HsStrTy FastString
+  = HsNumTy SourceText Integer
+  | HsStrTy SourceText FastString
     deriving (Data, Typeable)
 
 data HsTyWrapper
@@ -424,35 +546,49 @@ data HsExplicitFlag = Qualified | Implicit | Explicit deriving (Data, Typeable)
 type LConDeclField name = Located (ConDeclField name)
       -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when
       --   in a list
+
+      -- For details on above see note [Api annotations] in ApiAnnotation
 data ConDeclField name  -- Record fields have Haddoc docs on them
   = ConDeclField { cd_fld_names :: [Located name],
                    cd_fld_type  :: LBangType name,
                    cd_fld_doc   :: Maybe LHsDocString }
       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
+
+      -- For details on above see note [Api annotations] in ApiAnnotation
   deriving (Typeable)
 deriving instance (DataId name) => Data (ConDeclField name)
 
 -----------------------
--- Combine adjacent for-alls.
--- The following awkward situation can happen otherwise:
---      f :: forall a. ((Num a) => Int)
--- might generate HsForAll (Just [a]) [] (HsForAll Nothing [Num a] t)
--- Then a isn't discovered as ambiguous, and we abstract the AbsBinds wrt []
--- but the export list abstracts f wrt [a].  Disaster.
---
--- A valid type must have one for-all at the top of the type, or of the fn arg types
-
-mkImplicitHsForAllTy  ::                           LHsContext RdrName -> LHsType RdrName -> HsType RdrName
+-- A valid type must have a for-all at the top of the type, or of the fn arg
+-- types
+
+mkImplicitHsForAllTy  ::                                                 LHsType RdrName -> HsType RdrName
 mkExplicitHsForAllTy  :: [LHsTyVarBndr RdrName] -> LHsContext RdrName -> LHsType RdrName -> HsType RdrName
 mkQualifiedHsForAllTy ::                           LHsContext RdrName -> LHsType RdrName -> HsType RdrName
-mkImplicitHsForAllTy      ctxt ty = mkHsForAllTy Implicit  []  ctxt ty
+
+-- | mkImplicitHsForAllTy is called when we encounter
+--    f :: type
+-- Wrap around a HsForallTy if one is not there already.
+mkImplicitHsForAllTy (L _ (HsForAllTy exp extra tvs cxt ty))
+  = HsForAllTy exp' extra tvs cxt ty
+  where
+    exp' = case exp of
+             Qualified -> Implicit
+                          -- Qualified is used only for a nested forall,
+                          -- this is now top level
+             _         -> exp
+mkImplicitHsForAllTy ty = mkHsForAllTy Implicit  [] (noLoc []) ty
+
 mkExplicitHsForAllTy  tvs ctxt ty = mkHsForAllTy Explicit  tvs ctxt ty
 mkQualifiedHsForAllTy     ctxt ty = mkHsForAllTy Qualified []  ctxt ty
 
+-- |Smart constructor for HsForAllTy, which populates the extra-constraints
+-- field if a wildcard is present in the context.
 mkHsForAllTy :: HsExplicitFlag -> [LHsTyVarBndr RdrName] -> LHsContext RdrName -> LHsType RdrName -> HsType RdrName
--- Smart constructor for HsForAllTy
-mkHsForAllTy exp tvs (L _ []) ty = mk_forall_ty exp tvs ty
-mkHsForAllTy exp tvs ctxt     ty = HsForAllTy exp extra (mkHsQTvs tvs) cleanCtxt ty
+mkHsForAllTy exp tvs (L l []) ty
+  = HsForAllTy exp Nothing (mkHsQTvs tvs) (L l []) ty
+mkHsForAllTy exp tvs ctxt     ty
+  = HsForAllTy exp extra   (mkHsQTvs tvs) cleanCtxt        ty
   where -- Separate the extra-constraints wildcard when present
         (cleanCtxt, extra)
           | (L l HsWildcardTy) <- ignoreParens (last (unLoc ctxt)) = (init `fmap` ctxt, Just l)
@@ -461,14 +597,41 @@ mkHsForAllTy exp tvs ctxt     ty = HsForAllTy exp extra (mkHsQTvs tvs) cleanCtxt
         ignoreParens ty                 = ty
 
 
+-- |When a sigtype is parsed, the type found is wrapped in an Implicit
+-- HsForAllTy via mkImplicitHsForAllTy, to ensure that a signature always has a
+-- forall at the outer level. For Api Annotations this nested structure is
+-- important to ensure that all `forall` and `.` locations are retained.  From
+-- the renamer onwards this structure is flattened, to ease the renaming and
+-- type checking process.
+flattenTopLevelLHsForAllTy :: LHsType name -> LHsType name
+flattenTopLevelLHsForAllTy (L l ty) = L l (flattenTopLevelHsForAllTy ty)
+
+flattenTopLevelHsForAllTy :: HsType name -> HsType name
+flattenTopLevelHsForAllTy (HsForAllTy exp extra tvs (L l []) ty)
+  = snd $ mk_forall_ty [] l exp extra tvs ty
+flattenTopLevelHsForAllTy ty = ty
+
+flattenHsForAllTyKeepAnns :: HsType name -> ([AddAnn],HsType name)
+flattenHsForAllTyKeepAnns (HsForAllTy exp extra tvs (L l []) ty)
+  = mk_forall_ty [] l exp extra tvs ty
+flattenHsForAllTyKeepAnns ty = ([],ty)
+
 -- mk_forall_ty makes a pure for-all type (no context)
-mk_forall_ty :: HsExplicitFlag -> [LHsTyVarBndr RdrName] -> LHsType RdrName -> HsType RdrName
-mk_forall_ty exp1 tvs1 (L _ (HsForAllTy exp2 extra qtvs2 ctxt ty))
-  = addExtra $ mkHsForAllTy (exp1 `plus` exp2) (tvs1 ++ hsq_tvs qtvs2) ctxt ty
-  where addExtra (HsForAllTy exp _ qtvs ctxt ty) = HsForAllTy exp extra qtvs ctxt ty
-        addExtra ty = ty -- Impossible, as mkHsForAllTy always returns a HsForAllTy
-mk_forall_ty exp  tvs  (L _ (HsParTy ty)) = mk_forall_ty exp tvs ty
-mk_forall_ty exp  tvs  ty                 = HsForAllTy exp Nothing (mkHsQTvs tvs) (noLoc []) ty
+mk_forall_ty :: [AddAnn] -> SrcSpan -> HsExplicitFlag -> Maybe SrcSpan
+             -> LHsTyVarBndrs name
+             -> LHsType name -> ([AddAnn],HsType name)
+mk_forall_ty ann _ exp1 extra1 tvs1 (L _ (HsForAllTy exp2 extra qtvs2 ctxt ty))
+  = (ann,HsForAllTy (exp1 `plus` exp2) (mergeExtra extra1 extra)
+                    (tvs1 `mappend` qtvs2) ctxt ty)
+  where
+        -- Bias the merging of extra's to the top level, so that a single
+        -- wildcard context will prevail
+        mergeExtra (Just s) _ = Just s
+        mergeExtra _        e = e
+mk_forall_ty ann l exp  extra tvs  (L lp (HsParTy ty))
+  = mk_forall_ty (ann ++ mkParensApiAnn lp) l exp extra tvs ty
+mk_forall_ty ann l exp extra tvs  ty
+  = (ann,HsForAllTy exp extra tvs (L l []) ty)
         -- Even if tvs is empty, we still make a HsForAll!
         -- In the Implicit case, this signals the place to do implicit quantification
         -- In the Explicit case, it prevents implicit quantification
@@ -481,6 +644,7 @@ Explicit  `plus` _         = Explicit
 _         `plus` Explicit  = Explicit
 _         `plus` _         = Implicit
 
+---------------------
 hsExplicitTvs :: LHsType Name -> [Name]
 -- The explicitly-given forall'd type variables of a HsType
 hsExplicitTvs (L _ (HsForAllTy Explicit _ tvs _ _)) = hsLKiTyVarNames tvs
@@ -488,8 +652,8 @@ hsExplicitTvs _                                     = []
 
 ---------------------
 hsTyVarName :: HsTyVarBndr name -> name
-hsTyVarName (UserTyVar n)     = n
-hsTyVarName (KindedTyVar n _) = n
+hsTyVarName (UserTyVar n)           = n
+hsTyVarName (KindedTyVar (L _ n) _) = n
 
 hsLTyVarName :: LHsTyVarBndr name -> name
 hsLTyVarName = hsTyVarName . unLoc
@@ -796,5 +960,5 @@ ppr_fun_ty ctxt_prec ty1 ty2
 
 --------------------------
 ppr_tylit :: HsTyLit -> SDoc
-ppr_tylit (HsNumTy i) = integer i
-ppr_tylit (HsStrTy s) = text (show s)
+ppr_tylit (HsNumTy _ i) = integer i
+ppr_tylit (HsStrTy _ s) = text (show s)

compiler/hsSyn/HsUtils.hs

@@ -61,12 +61,13 @@ module HsUtils(
 
   -- Collecting binders
   collectLocalBinders, collectHsValBinders, collectHsBindListBinders,
+  collectHsIdBinders,
   collectHsBindsBinders, collectHsBindBinders, collectMethodBinders,
   collectPatBinders, collectPatsBinders,
   collectLStmtsBinders, collectStmtsBinders,
   collectLStmtBinders, collectStmtBinders,
 
-  hsLTyClDeclBinders, hsTyClDeclsBinders,
+  hsLTyClDeclBinders, hsTyClForeignBinders, hsPatSynBinders,
   hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,
 
   -- Collecting implicit binders
@@ -121,7 +122,7 @@ mkHsPar e = L (getLoc e) (HsPar e)
 mkSimpleMatch :: [LPat id] -> Located (body id) -> LMatch id (Located (body id))
 mkSimpleMatch pats rhs
   = L loc $
-    Match pats Nothing (unguardedGRHSs rhs)
+    Match Nothing pats Nothing (unguardedGRHSs rhs)
   where
     loc = case pats of
                 []      -> getLoc rhs
@@ -201,8 +202,8 @@ mkHsDo         :: HsStmtContext Name -> [ExprLStmt RdrName] -> HsExpr RdrName
 mkHsComp       :: HsStmtContext Name -> [ExprLStmt RdrName] -> LHsExpr RdrName
                -> HsExpr RdrName
 
-mkNPat      :: HsOverLit id -> Maybe (SyntaxExpr id) -> Pat id
-mkNPlusKPat :: Located id -> HsOverLit id -> Pat id
+mkNPat      :: Located (HsOverLit id) -> Maybe (SyntaxExpr id) -> Pat id
+mkNPlusKPat :: Located id -> Located (HsOverLit id) -> Pat id
 
 mkLastStmt :: Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR))
 mkBodyStmt :: Located (bodyR RdrName)
@@ -459,10 +460,11 @@ toHsType ty
     to_hs_type (FunTy arg res) = ASSERT( not (isConstraintKind (typeKind arg)) )
                                  nlHsFunTy (toHsType arg) (toHsType res)
     to_hs_type t@(ForAllTy {}) = pprPanic "toHsType" (ppr t)
-    to_hs_type (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy n)
-    to_hs_type (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy s)
+    to_hs_type (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy "" n)
+    to_hs_type (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy "" s)
 
-    mk_hs_tvb tv = noLoc $ KindedTyVar (getRdrName tv) (toHsKind (tyVarKind tv))
+    mk_hs_tvb tv = noLoc $ KindedTyVar (noLoc (getRdrName tv))
+                                       (toHsKind (tyVarKind tv))
 
 toHsKind :: Kind -> LHsKind RdrName
 toHsKind = toHsType
@@ -502,9 +504,10 @@ mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
 mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
                        | otherwise           = CoPat co_fn p ty
 
+-- input coercion is Nominal
 mkHsWrapPatCo :: TcCoercion -> Pat id -> Type -> Pat id
 mkHsWrapPatCo co pat ty | isTcReflCo co = pat
-                        | otherwise     = CoPat (mkWpCast co) pat ty
+                        | otherwise     = CoPat (mkWpCast (mkTcSubCo co)) pat ty
 
 mkHsDictLet :: TcEvBinds -> LHsExpr Id -> LHsExpr Id
 mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr
@@ -563,7 +566,7 @@ mk_easy_FunBind loc fun pats expr
 ------------
 mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id (LHsExpr id)
 mkMatch pats expr binds
-  = noLoc (Match (map paren pats) Nothing
+  = noLoc (Match Nothing (map paren pats) Nothing
                  (GRHSs (unguardedRHS noSrcSpan expr) binds))
   where
     paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp)
@@ -596,39 +599,48 @@ So these functions should not be applied to (HsSyn RdrName)
 
 ----------------- Bindings --------------------------
 collectLocalBinders :: HsLocalBindsLR idL idR -> [idL]
-collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds
-collectLocalBinders (HsIPBinds _)   = []
-collectLocalBinders EmptyLocalBinds = []
+collectLocalBinders (HsValBinds binds) = collectHsIdBinders binds
+                                         -- No pattern synonyms here
+collectLocalBinders (HsIPBinds _)      = []
+collectLocalBinders EmptyLocalBinds    = []
 
-collectHsValBinders :: HsValBindsLR idL idR -> [idL]
-collectHsValBinders (ValBindsIn  binds _) = collectHsBindsBinders binds
-collectHsValBinders (ValBindsOut binds _) = foldr collect_one [] binds
-  where
-   collect_one (_,binds) acc = collect_binds binds acc
+collectHsIdBinders, collectHsValBinders :: HsValBindsLR idL idR -> [idL]
+-- Collect Id binders only, or Ids + pattern synonmys, respectively
+collectHsIdBinders  = collect_hs_val_binders True
+collectHsValBinders = collect_hs_val_binders False
 
 collectHsBindBinders :: HsBindLR idL idR -> [idL]
-collectHsBindBinders b = collect_bind b []
-
-collect_bind :: HsBindLR idL idR -> [idL] -> [idL]
-collect_bind (PatBind { pat_lhs = p })    acc = collect_lpat p acc
-collect_bind (FunBind { fun_id = L _ f }) acc = f : acc
-collect_bind (VarBind { var_id = f })     acc = f : acc
-collect_bind (AbsBinds { abs_exports = dbinds, abs_binds = _binds }) acc
-  = map abe_poly dbinds ++ acc
-        -- ++ foldr collect_bind acc binds
-        -- I don't think we want the binders from the nested binds
-        -- The only time we collect binders from a typechecked
-        -- binding (hence see AbsBinds) is in zonking in TcHsSyn
-collect_bind (PatSynBind (PSB { psb_id = L _ ps })) acc = ps : acc
+-- Collect both Ids and pattern-synonym binders
+collectHsBindBinders b = collect_bind False b []
 
 collectHsBindsBinders :: LHsBindsLR idL idR -> [idL]
-collectHsBindsBinders binds = collect_binds binds []
+collectHsBindsBinders binds = collect_binds False binds []
 
 collectHsBindListBinders :: [LHsBindLR idL idR] -> [idL]
-collectHsBindListBinders = foldr (collect_bind . unLoc) []
-
-collect_binds :: LHsBindsLR idL idR -> [idL] -> [idL]
-collect_binds binds acc = foldrBag (collect_bind . unLoc) acc binds
+-- Same as collectHsBindsBinders, but works over a list of bindings
+collectHsBindListBinders = foldr (collect_bind False . unLoc) []
+
+collect_hs_val_binders :: Bool -> HsValBindsLR idL idR -> [idL]
+collect_hs_val_binders ps (ValBindsIn  binds _) = collect_binds     ps binds []
+collect_hs_val_binders ps (ValBindsOut binds _) = collect_out_binds ps binds
+
+collect_out_binds :: Bool -> [(RecFlag, LHsBinds id)] -> [id]
+collect_out_binds ps = foldr (collect_binds ps . snd) []
+
+collect_binds :: Bool -> LHsBindsLR idL idR -> [idL] -> [idL]
+-- Collect Ids, or Ids + patter synonyms, depending on boolean flag
+collect_binds ps binds acc = foldrBag (collect_bind ps . unLoc) acc binds
+
+collect_bind :: Bool -> HsBindLR idL idR -> [idL] -> [idL]
+collect_bind _ (PatBind { pat_lhs = p })           acc = collect_lpat p acc
+collect_bind _ (FunBind { fun_id = L _ f })        acc = f : acc
+collect_bind _ (VarBind { var_id = f })            acc = f : acc
+collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc
+        -- I don't think we want the binders from the abe_binds
+        -- The only time we collect binders from a typechecked
+        -- binding (hence see AbsBinds) is in zonking in TcHsSyn
+collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc =
+    if omitPatSyn then acc else ps : acc
 
 collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName]
 -- Used exclusively for the bindings of an instance decl which are all FunBinds
@@ -728,21 +740,18 @@ So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound.
 hsGroupBinders :: HsGroup Name -> [Name]
 hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
                           hs_instds = inst_decls, hs_fords = foreign_decls })
--- Collect the binders of a Group
   =  collectHsValBinders val_decls
-  ++ hsTyClDeclsBinders tycl_decls inst_decls
-  ++ hsForeignDeclsBinders foreign_decls
-
-hsForeignDeclsBinders :: [LForeignDecl Name] -> [Name]
-hsForeignDeclsBinders foreign_decls
-  = [n | L _ (ForeignImport (L _ n) _ _ _) <- foreign_decls]
+  ++ hsTyClForeignBinders tycl_decls inst_decls foreign_decls
 
-hsTyClDeclsBinders :: [TyClGroup Name] -> [Located (InstDecl Name)] -> [Name]
+hsTyClForeignBinders :: [TyClGroup Name] -> [LInstDecl Name]
+                     -> [LForeignDecl Name] -> [Name]
 -- We need to look at instance declarations too,
 -- because their associated types may bind data constructors
-hsTyClDeclsBinders tycl_decls inst_decls
-  = map unLoc (concatMap (concatMap hsLTyClDeclBinders . group_tyclds) tycl_decls ++
-               concatMap (hsInstDeclBinders . unLoc) inst_decls)
+hsTyClForeignBinders tycl_decls inst_decls foreign_decls
+  = map unLoc $
+    hsForeignDeclsBinders foreign_decls ++
+    concatMap (concatMap hsLTyClDeclBinders . group_tyclds) tycl_decls ++
+    concatMap hsLInstDeclBinders inst_decls
 
 -------------------
 hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name]
@@ -751,11 +760,8 @@ hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name]
 -- mentioned in multiple constructors, the SrcLoc will be from the first
 -- occurrence.  We use the equality to filter out duplicate field names.
 --
--- Each returned (Located name) is wrapped in a @SrcSpan@ of the whole
--- /declaration/, not just the name itself (which is how it appears in
--- the syntax tree).  This SrcSpan (for the entire declaration) is used
--- as the SrcSpan for the Name that is finally produced, and hence for
--- error messages.  (See Trac #8607.)
+-- Each returned (Located name) has a SrcSpan for the /whole/ declaration.
+-- See Note [SrcSpan for binders]
 
 hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl { fdLName = L _ name } }))
   = [L loc name]
@@ -769,11 +775,33 @@ hsLTyClDeclBinders (L loc (DataDecl    { tcdLName = L _ name, tcdDataDefn = defn
   = L loc name : hsDataDefnBinders defn
 
 -------------------
-hsInstDeclBinders :: Eq name => InstDecl name -> [Located name]
-hsInstDeclBinders (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } })
+hsForeignDeclsBinders :: [LForeignDecl name] -> [Located name]
+-- See Note [SrcSpan for binders]
+hsForeignDeclsBinders foreign_decls
+  = [ L decl_loc n
+    | L decl_loc (ForeignImport (L _ n) _ _ _) <- foreign_decls]
+
+-------------------
+hsPatSynBinders :: LHsBindsLR idL idR -> [Located idL]
+-- Collect pattern-synonym binders only, not Ids
+-- See Note [SrcSpan for binders]
+hsPatSynBinders binds = foldrBag addPatSynBndr [] binds
+
+addPatSynBndr :: LHsBindLR idL idR -> [Located idL] -> [Located idL]
+-- See Note [SrcSpan for binders]
+addPatSynBndr bind pss
+  | L bind_loc (PatSynBind (PSB { psb_id = L _ n })) <- bind
+  = L bind_loc n : pss
+  | otherwise
+  = pss
+
+-------------------
+hsLInstDeclBinders :: Eq name => LInstDecl name -> [Located name]
+hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } }))
   = concatMap (hsDataFamInstBinders . unLoc) dfis
-hsInstDeclBinders (DataFamInstD { dfid_inst = fi }) = hsDataFamInstBinders fi
-hsInstDeclBinders (TyFamInstD {}) = []
+hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi }))
+  = hsDataFamInstBinders fi
+hsLInstDeclBinders (L _ (TyFamInstD {})) = []
 
 -------------------
 -- the SrcLoc returned are for the whole declarations, not just the names
@@ -805,12 +833,23 @@ hsConDeclsBinders cons = go id cons
              -- avoid circumventing detection of duplicate fields (#9156)
              L loc (ConDecl { con_names = names, con_details = RecCon flds }) ->
                (map (L loc . unLoc) names) ++ r' ++ go remSeen' rs
-                  where r' = remSeen (concatMap (cd_fld_names . unLoc) flds)
+                  where r' = remSeen (concatMap (cd_fld_names . unLoc)
+                                                (unLoc flds))
                         remSeen' = foldr (.) remSeen [deleteBy ((==) `on` unLoc) v | v <- r']
              L loc (ConDecl { con_names = names }) ->
                 (map (L loc . unLoc) names) ++ go remSeen rs
 
 {-
+
+Note [SrcSpan for binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+When extracting the (Located RdrNme) for a binder, at least for the
+main name (the TyCon of a type declaration etc), we want to give it
+the @SrcSpan@ of the whole /declaration/, not just the name itself
+(which is how it appears in the syntax tree).  This SrcSpan (for the
+entire declaration) is used as the SrcSpan for the Name that is
+finally produced, and hence for error messages.  (See Trac #8607.)
+
 Note [Binders in family instances]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 In a type or data family instance declaration, the type

compiler/iface/IfaceSyn.hs

@@ -205,7 +205,8 @@ data IfaceConDecl
 
 type IfaceEqSpec = [(IfLclName,IfaceType)]
 
-data IfaceBang
+data IfaceBang  -- This corresponds to an HsImplBang; that is, the final
+                -- implementation decision about the data constructor arg
   = IfNoBang | IfStrict | IfUnpack | IfUnpackCo IfaceCoercion
 
 data IfaceClsInst

compiler/iface/LoadIface.hs

@@ -320,17 +320,15 @@ loadModuleInterfaces doc mods
     load mod = loadSysInterface (doc <+> parens (ppr mod)) mod
 
 -- | Loads the interface for a given Name.
+-- Should only be called for an imported name;
+-- otherwise loadSysInterface may not find the interface
 loadInterfaceForName :: SDoc -> Name -> TcRn ModIface
 loadInterfaceForName doc name
-  = do {
-    when debugIsOn $ do
-        -- Should not be called with a name from the module being compiled
-        { this_mod <- getModule
-        ; MASSERT2( not (nameIsLocalOrFrom this_mod name), ppr name <+> parens doc )
-        }
-  ; ASSERT2( isExternalName name, ppr name )
-    initIfaceTcRn $ loadSysInterface doc (nameModule name)
-  }
+  = do { when debugIsOn $  -- Check pre-condition
+         do { this_mod <- getModule
+            ; MASSERT2( not (nameIsLocalOrFrom this_mod name), ppr name <+> parens doc ) }
+      ; ASSERT2( isExternalName name, ppr name )
+        initIfaceTcRn $ loadSysInterface doc (nameModule name) }
 
 -- | Loads the interface for a given Module.
 loadInterfaceForModule :: SDoc -> Module -> TcRn ModIface

compiler/iface/MkIface.hs

@@ -1684,7 +1684,7 @@ tyConToIfaceDecl env tycon
                     ifConArgTys  = map (tidyToIfaceType con_env2) arg_tys,
                     ifConFields  = map getOccName
                                        (dataConFieldLabels data_con),
-                    ifConStricts = map (toIfaceBang con_env2) (dataConRepBangs data_con) }
+                    ifConStricts = map (toIfaceBang con_env2) (dataConImplBangs data_con) }
         where
           (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con
 
@@ -1701,12 +1701,12 @@ tyConToIfaceDecl env tycon
           (con_env2, ex_tvs') = tidyTyVarBndrs con_env1 ex_tvs
           to_eq_spec (tv,ty)  = (toIfaceTyVar (tidyTyVar con_env2 tv), tidyToIfaceType con_env2 ty)
 
-toIfaceBang :: TidyEnv -> HsBang -> IfaceBang
+toIfaceBang :: TidyEnv -> HsImplBang -> IfaceBang
 toIfaceBang _    HsNoBang            = IfNoBang
 toIfaceBang _   (HsUnpack Nothing)   = IfUnpack
 toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (toIfaceCoercion (tidyCo env co))
 toIfaceBang _   HsStrict             = IfStrict
-toIfaceBang _   (HsUserBang {})      = panic "toIfaceBang"
+toIfaceBang _   (HsSrcBang {})       = panic "toIfaceBang"
 
 classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl)
 classToIfaceDecl env clas
@@ -1729,7 +1729,7 @@ classToIfaceDecl env clas
 
     toIfaceAT :: ClassATItem -> IfaceAT
     toIfaceAT (ATI tc def)
-      = IfaceAT if_decl (fmap (tidyToIfaceType env2) def)
+      = IfaceAT if_decl (fmap (tidyToIfaceType env2 . fst) def)
       where
         (env2, if_decl) = tyConToIfaceDecl env1 tc
 

compiler/iface/TcIface.hs

@@ -413,7 +413,7 @@ tc_iface_decl _parent ignore_prags
                       Just def -> forkM (mk_at_doc tc)                 $
                                   extendIfaceTyVarEnv (tyConTyVars tc) $
                                   do { tc_def <- tcIfaceType def
-                                     ; return (Just tc_def) }
+                                     ; return (Just (tc_def, noSrcSpan)) }
                   -- Must be done lazily in case the RHS of the defaults mention
                   -- the type constructor being defined here
                   -- e.g.   type AT a; type AT b = AT [b]   Trac #8002
@@ -532,7 +532,10 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
 
         ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr name))
                        name is_infix
-                       stricts lbl_names
+                       stricts     -- Pass the HsImplBangs (i.e. final decisions
+                                   -- to buildDataCon; it'll use these to guide
+                                   -- the construction of a worker
+                       lbl_names
                        tc_tyvars ex_tyvars
                        eq_spec theta
                        arg_tys orig_res_ty tycon
@@ -540,6 +543,7 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
         ; return con }
     mk_doc con_name = ptext (sLit "Constructor") <+> ppr con_name
 
+    tc_strict :: IfaceBang -> IfL HsImplBang
     tc_strict IfNoBang = return HsNoBang
     tc_strict IfStrict = return HsStrict
     tc_strict IfUnpack = return (HsUnpack Nothing)

compiler/llvmGen/LlvmCodeGen/Ppr.hs

@@ -52,7 +52,7 @@ moduleLayout = sdocWithPlatform $ \platform ->
         $+$ text "target triple = \"x86_64-linux-gnu\""
     Platform { platformArch = ArchARM {}, platformOS = OSLinux } ->
         text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\""
-        $+$ text "target triple = \"arm-unknown-linux-gnueabi\""
+        $+$ text "target triple = \"armv6-unknown-linux-gnueabihf\""
     Platform { platformArch = ArchARM {}, platformOS = OSAndroid } ->
         text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\""
         $+$ text "target triple = \"arm-unknown-linux-androideabi\""
@@ -68,9 +68,19 @@ moduleLayout = sdocWithPlatform $ \platform ->
     Platform { platformArch = ArchARM64, platformOS = OSiOS } ->
         text "target datalayout = \"e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:128:128-a0:0:64-n32:64-S128\""
         $+$ text "target triple = \"arm64-apple-ios7.0.0\""
+    Platform { platformArch = ArchARM64, platformOS = OSLinux } ->
+        text "target datalayout = \"e-m:e-i64:64-i128:128-n32:64-S128\""
+        $+$ text "target triple = \"aarch64-unknown-linux-gnu\""
     _ ->
-        -- FIX: Other targets
-        empty
+        if platformIsCrossCompiling platform
+            then panic "LlvmCodeGen.Ppr: Cross compiling without valid target info."
+            else empty
+        -- If you see the above panic, GHC is missing the required target datalayout
+        -- and triple information. You can obtain this info by compiling a simple
+        -- 'hello world' C program with the clang C compiler eg:
+        --     clang hello.c -emit-llvm -o hello.ll
+        -- and the first two lines of hello.ll should provide the 'target datalayout'
+        -- and 'target triple' lines required.
 
 
 -- | Pretty print LLVM data code

compiler/main/CmdLineParser.hs

@@ -18,7 +18,7 @@ module CmdLineParser
       Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag,
       errorsToGhcException,
 
-      EwM, addErr, addWarn, getArg, getCurLoc, liftEwM, deprecate
+      EwM, runEwM, addErr, addWarn, getArg, getCurLoc, liftEwM, deprecate
     ) where
 
 #include "HsVersions.h"
@@ -108,6 +108,9 @@ instance Monad m => Monad (EwM m) where
                                       unEwM (k r) l e' w')
     return v = EwM (\_ e w -> return (e, w, v))
 
+runEwM :: EwM m a -> m (Errs, Warns, a)
+runEwM action = unEwM action (panic "processArgs: no arg yet") emptyBag emptyBag
+
 setArg :: Monad m => Located String -> EwM m () -> EwM m ()
 setArg l (EwM f) = EwM (\_ es ws -> f l es ws)
 
@@ -170,8 +173,7 @@ processArgs :: Monad m
                    [Located String],  -- errors
                    [Located String] ) -- warnings
 processArgs spec args = do
-    (errs, warns, spare) <- unEwM action (panic "processArgs: no arg yet")
-                                  emptyBag emptyBag
+    (errs, warns, spare) <- runEwM action
     return (spare, bagToList errs, bagToList warns)
   where
     action = process args []
@@ -293,8 +295,26 @@ missingArgErr f = Left ("missing argument for flag: " ++ f)
 -- Utils
 --------------------------------------------------------
 
-errorsToGhcException :: [Located String] -> GhcException
+
+-- See Note [Handling errors when parsing flags]
+errorsToGhcException :: [(String,    -- Location
+                          String)]   -- Error
+                     -> GhcException
 errorsToGhcException errs =
-    UsageError $
-        intercalate "\n" [ showUserSpan True l ++ ": " ++ e | L l e <- errs ]
+    UsageError $ intercalate "\n" $ [ l ++ ": " ++ e | (l, e) <- errs ]
+
+{- Note [Handling errors when parsing commandline flags]
+
+Parsing of static and mode flags happens before any session is started, i.e.,
+before the first call to 'GHC.withGhc'. Therefore, to report errors for
+invalid usage of these two types of flags, we can not call any function that
+needs DynFlags, as there are no DynFlags available yet (unsafeGlobalDynFlags
+is not set either). So we always print "on the commandline" as the location,
+which is true except for Api users, which is probably ok.
+
+When reporting errors for invalid usage of dynamic flags we /can/ make use of
+DynFlags, and we do so explicitly in DynFlags.parseDynamicFlagsFull.
 
+Before, we called unsafeGlobalDynFlags when an invalid (combination of)
+flag(s) was given on the commandline, resulting in panics (#9963).
+-}

compiler/main/DriverPipeline.hs

@@ -30,7 +30,7 @@ module DriverPipeline (
    runPhase, exeFileName,
    mkExtraObjToLinkIntoBinary, mkNoteObjsToLinkIntoBinary,
    maybeCreateManifest, runPhase_MoveBinary,
-   linkingNeeded, checkLinkInfo
+   linkingNeeded, checkLinkInfo, writeInterfaceOnlyMode
   ) where
 
 #include "HsVersions.h"
@@ -171,7 +171,7 @@ compileOne' m_tc_result mHscMessage
    -- -fforce-recomp should also work with --make
    let force_recomp = gopt Opt_ForceRecomp dflags
        source_modified
-         | force_recomp || isNothing maybe_old_linkable = SourceModified
+         | force_recomp = SourceModified
          | otherwise = source_modified0
        object_filename = ml_obj_file location
 
@@ -252,7 +252,18 @@ compileOne' m_tc_result mHscMessage
                        do (iface, changed, details) <-
                                     hscSimpleIface hsc_env tc_result mb_old_hash
                           hscWriteIface dflags iface changed summary
-                          compileEmptyStub dflags hsc_env basename location
+
+                          -- #10660: Use the pipeline instead of calling
+                          -- compileEmptyStub directly, so -dynamic-too gets
+                          -- handled properly
+                          let mod_name = ms_mod_name summary
+                          _ <- runPipeline StopLn hsc_env
+                                            (output_fn,
+                                             Just (HscOut src_flavour mod_name HscUpdateSig))
+                                            (Just basename)
+                                            Persistent
+                                            (Just location)
+                                            Nothing
 
                           -- Same as Hs
                           o_time <- getModificationUTCTime object_filename
@@ -935,6 +946,11 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0
         location <- getLocation src_flavour mod_name
 
         let o_file = ml_obj_file location -- The real object file
+            hi_file = ml_hi_file location
+            dest_file | writeInterfaceOnlyMode dflags
+                            = hi_file
+                      | otherwise
+                            = o_file
 
   -- Figure out if the source has changed, for recompilation avoidance.
   --
@@ -952,10 +968,10 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0
                 --      (b) we aren't going all the way to .o file (e.g. ghc -S)
              then return SourceModified
                 -- Otherwise look at file modification dates
-             else do o_file_exists <- doesFileExist o_file
-                     if not o_file_exists
+             else do dest_file_exists <- doesFileExist dest_file
+                     if not dest_file_exists
                         then return SourceModified       -- Need to recompile
-                        else do t2 <- getModificationUTCTime o_file
+                        else do t2 <- getModificationUTCTime dest_file
                                 if t2 > src_timestamp
                                   then return SourceUnmodified
                                   else return SourceModified
@@ -975,6 +991,7 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0
                                         ms_location  = location,
                                         ms_hs_date   = src_timestamp,
                                         ms_obj_date  = Nothing,
+                                        ms_iface_date   = Nothing,
                                         ms_textual_imps = imps,
                                         ms_srcimps      = src_imps }
 
@@ -1617,12 +1634,14 @@ mkExtraObj dflags extn xs
       oFile <- newTempName dflags "o"
       writeFile cFile xs
       let rtsDetails = getPackageDetails dflags rtsPackageKey
+          pic_c_flags = picCCOpts dflags
       SysTools.runCc dflags
                      ([Option        "-c",
                        FileOption "" cFile,
                        Option        "-o",
                        FileOption "" oFile]
-                      ++ map (FileOption "-I") (includeDirs rtsDetails))
+                      ++ map (FileOption "-I") (includeDirs rtsDetails)
+                      ++ map Option pic_c_flags)
       return oFile
 
 -- When linking a binary, we need to create a C main() function that
@@ -1884,32 +1903,9 @@ linkBinary' staticLink dflags o_files dep_packages = do
                                                               -- This option must be placed before the library
                                                               -- that defines the symbol."
 
-    pkg_framework_path_opts <-
-        if platformUsesFrameworks platform
-        then do pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages
-                return $ map ("-F" ++) pkg_framework_paths
-        else return []
-
-    framework_path_opts <-
-        if platformUsesFrameworks platform
-        then do let framework_paths = frameworkPaths dflags
-                return $ map ("-F" ++) framework_paths
-        else return []
-
-    pkg_framework_opts <-
-        if platformUsesFrameworks platform
-        then do pkg_frameworks <- getPackageFrameworks dflags dep_packages
-                return $ concat [ ["-framework", fw] | fw <- pkg_frameworks ]
-        else return []
-
-    framework_opts <-
-        if platformUsesFrameworks platform
-        then do let frameworks = cmdlineFrameworks dflags
-                -- reverse because they're added in reverse order from
-                -- the cmd line:
-                return $ concat [ ["-framework", fw]
-                                | fw <- reverse frameworks ]
-        else return []
+    -- frameworks
+    pkg_framework_opts <- getPkgFrameworkOpts dflags platform dep_packages
+    let framework_opts = getFrameworkOpts dflags platform
 
         -- probably _stub.o files
     let extra_ld_inputs = ldInputs dflags
@@ -1998,12 +1994,10 @@ linkBinary' staticLink dflags o_files dep_packages = do
                       ++ extra_ld_inputs
                       ++ map SysTools.Option (
                          rc_objs
-                      ++ framework_path_opts
                       ++ framework_opts
                       ++ pkg_lib_path_opts
                       ++ extraLinkObj:noteLinkObjs
                       ++ pkg_link_opts
-                      ++ pkg_framework_path_opts
                       ++ pkg_framework_opts
                       ++ debug_opts
                       ++ thread_opts
@@ -2248,6 +2242,11 @@ joinObjectFiles dflags o_files output_fn = do
 -- -----------------------------------------------------------------------------
 -- Misc.
 
+writeInterfaceOnlyMode :: DynFlags -> Bool
+writeInterfaceOnlyMode dflags =
+ gopt Opt_WriteInterface dflags &&
+ HscNothing == hscTarget dflags
+
 -- | What phase to run after one of the backend code generators has run
 hscPostBackendPhase :: DynFlags -> HscSource -> HscTarget -> Phase
 hscPostBackendPhase _ HsBootFile _    =  StopLn

compiler/main/DynFlags.hs

@@ -52,6 +52,7 @@ module DynFlags (
         dynFlagDependencies,
         tablesNextToCode, mkTablesNextToCode,
         SigOf(..), getSigOf,
+        makeDynFlagsConsistent,
 
         Way(..), mkBuildTag, wayRTSOnly, addWay', updateWays,
         wayGeneralFlags, wayUnsetGeneralFlags,
@@ -67,6 +68,7 @@ module DynFlags (
         Settings(..),
         targetPlatform, programName, projectVersion,
         ghcUsagePath, ghciUsagePath, topDir, tmpDir, rawSettings,
+        versionedAppDir,
         extraGccViaCFlags, systemPackageConfig,
         pgm_L, pgm_P, pgm_F, pgm_c, pgm_s, pgm_a, pgm_l, pgm_dll, pgm_T,
         pgm_sysman, pgm_windres, pgm_libtool, pgm_lo, pgm_lc,
@@ -91,6 +93,7 @@ module DynFlags (
         updOptLevel,
         setTmpDir,
         setPackageKey,
+        interpretPackageEnv,
 
         -- ** Parsing DynFlags
         parseDynamicFlagsCmdLine,
@@ -162,7 +165,7 @@ import CmdLineParser
 import Constants
 import Panic
 import Util
-import Maybes           ( orElse )
+import Maybes
 import MonadUtils
 import qualified Pretty
 import SrcLoc
@@ -176,7 +179,9 @@ import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessage )
 
 import System.IO.Unsafe ( unsafePerformIO )
 import Data.IORef
+import Control.Arrow ((&&&))
 import Control.Monad
+import Control.Exception (throwIO)
 
 import Data.Bits
 import Data.Char
@@ -184,11 +189,12 @@ import Data.Int
 import Data.List
 import Data.Map (Map)
 import qualified Data.Map as Map
-import Data.Maybe
 import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.Word
 import System.FilePath
+import System.Directory
+import System.Environment (getEnv)
 import System.IO
 import System.IO.Error
 import Text.ParserCombinators.ReadP hiding (char)
@@ -287,6 +293,7 @@ data DumpFlag
    | Opt_D_dump_if_trace
    | Opt_D_dump_vt_trace
    | Opt_D_dump_splices
+   | Opt_D_th_dec_file
    | Opt_D_dump_BCOs
    | Opt_D_dump_vect
    | Opt_D_dump_ticked
@@ -512,6 +519,7 @@ data WarningFlag =
    | Opt_WarnPartialTypeSignatures
    | Opt_WarnMissingExportedSigs
    | Opt_WarnUntickedPromotedConstructors
+   | Opt_WarnDerivingTypeable
    deriving (Eq, Show, Enum)
 
 data Language = Haskell98 | Haskell2010
@@ -630,7 +638,7 @@ data ExtensionFlag
    | Opt_EmptyCase
    | Opt_PatternSynonyms
    | Opt_PartialTypeSignatures
-   | Opt_NamedWildcards
+   | Opt_NamedWildCards
    | Opt_StaticPointers
    deriving (Eq, Enum, Show)
 
@@ -766,6 +774,8 @@ data DynFlags = DynFlags {
 
   packageFlags          :: [PackageFlag],
         -- ^ The @-package@ and @-hide-package@ flags from the command-line
+  packageEnv            :: Maybe FilePath,
+        -- ^ Filepath to the package environment file (if overriding default)
 
   -- Package state
   -- NB. do not modify this field, it is calculated by
@@ -1011,6 +1021,14 @@ opt_lo dflags = sOpt_lo (settings dflags)
 opt_lc                :: DynFlags -> [String]
 opt_lc dflags = sOpt_lc (settings dflags)
 
+-- | The directory for this version of ghc in the user's app directory
+-- (typically something like @~/.ghc/x86_64-linux-7.6.3@)
+--
+versionedAppDir :: DynFlags -> IO FilePath
+versionedAppDir dflags = do
+  appdir <- getAppUserDataDirectory (programName dflags)
+  return $ appdir </> (TARGET_ARCH ++ '-':TARGET_OS ++ '-':projectVersion dflags)
+
 -- | The target code type of the compilation (if any).
 --
 -- Whenever you change the target, also make sure to set 'ghcLink' to
@@ -1468,6 +1486,7 @@ defaultDynFlags mySettings =
 
         extraPkgConfs           = id,
         packageFlags            = [],
+        packageEnv              = Nothing,
         pkgDatabase             = Nothing,
         pkgState                = panic "no package state yet: call GHC.setSessionDynFlags",
         ways                    = defaultWays mySettings,
@@ -1684,6 +1703,7 @@ dopt f dflags = (fromEnum f `IntSet.member` dumpFlags dflags)
           enableIfVerbose Opt_D_verbose_core2core           = False
           enableIfVerbose Opt_D_verbose_stg2stg             = False
           enableIfVerbose Opt_D_dump_splices                = False
+          enableIfVerbose Opt_D_th_dec_file                 = False
           enableIfVerbose Opt_D_dump_rule_firings           = False
           enableIfVerbose Opt_D_dump_rule_rewrites          = False
           enableIfVerbose Opt_D_dump_simpl_trace            = False
@@ -2069,8 +2089,10 @@ parseDynamicFlagsFull :: MonadIO m
 parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
   let ((leftover, errs, warns), dflags1)
           = runCmdLine (processArgs activeFlags args) dflags0
-  when (not (null errs)) $ liftIO $
-      throwGhcExceptionIO $ errorsToGhcException errs
+
+  -- See Note [Handling errors when parsing commandline flags]
+  unless (null errs) $ liftIO $ throwGhcExceptionIO $
+      errorsToGhcException . map (showPpr dflags0 . getLoc &&& unLoc) $ errs
 
   -- check for disabled flags in safe haskell
   let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1
@@ -2476,6 +2498,8 @@ dynamic_flags = [
                                             setDumpFlag' Opt_D_dump_cs_trace))
   , defGhcFlag "ddump-vt-trace"          (setDumpFlag Opt_D_dump_vt_trace)
   , defGhcFlag "ddump-splices"           (setDumpFlag Opt_D_dump_splices)
+  , defGhcFlag "dth-dec-file"            (setDumpFlag Opt_D_th_dec_file)
+
   , defGhcFlag "ddump-rn-stats"          (setDumpFlag Opt_D_dump_rn_stats)
   , defGhcFlag "ddump-opt-cmm"           (setDumpFlag Opt_D_dump_opt_cmm)
   , defGhcFlag "ddump-simpl-stats"       (setDumpFlag Opt_D_dump_simpl_stats)
@@ -2709,15 +2733,14 @@ package_flags = [
       (NoArg $ do removeUserPkgConf
                   deprecate "Use -no-user-package-db instead")
 
-  , defGhcFlag "package-name"      (HasArg $ \name -> do
-                                      upd (setPackageKey name)
-                                      deprecate "Use -this-package-key instead")
+  , defGhcFlag "package-name"       (hasArg setPackageKey)
   , defGhcFlag "this-package-key"   (hasArg setPackageKey)
   , defFlag "package-id"            (HasArg exposePackageId)
   , defFlag "package"               (HasArg exposePackage)
   , defFlag "package-key"           (HasArg exposePackageKey)
   , defFlag "hide-package"          (HasArg hidePackage)
   , defFlag "hide-all-packages"     (NoArg (setGeneralFlag Opt_HideAllPackages))
+  , defFlag "package-env"           (HasArg setPackageEnv)
   , defFlag "ignore-package"        (HasArg ignorePackage)
   , defFlag "syslib"
       (HasArg (\s -> do exposePackage s
@@ -2727,6 +2750,8 @@ package_flags = [
   , defFlag "trust"                 (HasArg trustPackage)
   , defFlag "distrust"              (HasArg distrustPackage)
   ]
+  where
+    setPackageEnv env = upd $ \s -> s { packageEnv = Just env }
 
 -- | Make a list of flags for shell completion.
 -- Filter all available flags into two groups, for interactive GHC vs all other.
@@ -2820,6 +2845,7 @@ fWarningFlags = [
   flagSpec "warn-auto-orphans"                Opt_WarnAutoOrphans,
   flagSpec "warn-deprecations"                Opt_WarnWarningsDeprecations,
   flagSpec "warn-deprecated-flags"            Opt_WarnDeprecatedFlags,
+  flagSpec "warn-deriving-typeable"           Opt_WarnDerivingTypeable,
   flagSpec "warn-dodgy-exports"               Opt_WarnDodgyExports,
   flagSpec "warn-dodgy-foreign-imports"       Opt_WarnDodgyForeignImports,
   flagSpec "warn-dodgy-imports"               Opt_WarnDodgyImports,
@@ -3107,7 +3133,7 @@ xFlags = [
   flagSpec "MultiWayIf"                       Opt_MultiWayIf,
   flagSpec "NPlusKPatterns"                   Opt_NPlusKPatterns,
   flagSpec "NamedFieldPuns"                   Opt_RecordPuns,
-  flagSpec "NamedWildcards"                   Opt_NamedWildcards,
+  flagSpec "NamedWildCards"                   Opt_NamedWildCards,
   flagSpec "NegativeLiterals"                 Opt_NegativeLiterals,
   flagSpec "NondecreasingIndentation"         Opt_NondecreasingIndentation,
   flagSpec' "NullaryTypeClasses"              Opt_NullaryTypeClasses
@@ -3192,6 +3218,12 @@ default_PIC :: Platform -> [GeneralFlag]
 default_PIC platform =
   case (platformOS platform, platformArch platform) of
     (OSDarwin, ArchX86_64) -> [Opt_PIC]
+    (OSOpenBSD, ArchX86_64) -> [Opt_PIC] -- Due to PIE support in
+                                         -- OpenBSD since 5.3 release
+                                         -- (1 May 2013) we need to
+                                         -- always generate PIC. See
+                                         -- #10597 for more
+                                         -- information.
     _                      -> []
 
 impliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)]
@@ -3693,6 +3725,102 @@ exposePackage' p dflags
 setPackageKey :: String -> DynFlags -> DynFlags
 setPackageKey p s =  s{ thisPackage = stringToPackageKey p }
 
+-- -----------------------------------------------------------------------------
+-- | Find the package environment (if one exists)
+--
+-- We interpret the package environment as a set of package flags; to be
+-- specific, if we find a package environment
+--
+-- > id1
+-- > id2
+-- > ..
+-- > idn
+--
+-- we interpret this as
+--
+-- > [ -hide-all-packages
+-- > , -package-id id1
+-- > , -package-id id2
+-- > , ..
+-- > , -package-id idn
+-- > ]
+interpretPackageEnv :: DynFlags -> IO DynFlags
+interpretPackageEnv dflags = do
+    mPkgEnv <- runMaybeT $ msum $ [
+                   getCmdLineArg >>= \env -> msum [
+                       loadEnvFile  env
+                     , loadEnvName  env
+                     , cmdLineError env
+                     ]
+                 , getEnvVar >>= \env -> msum [
+                       loadEnvFile env
+                     , loadEnvName env
+                     , envError    env
+                     ]
+                 , loadEnvFile localEnvFile
+                 , loadEnvName defaultEnvName
+                 ]
+    case mPkgEnv of
+      Nothing ->
+        -- No environment found. Leave DynFlags unchanged.
+        return dflags
+      Just ids -> do
+        let setFlags :: DynP ()
+            setFlags = do
+              setGeneralFlag Opt_HideAllPackages
+              mapM_ exposePackageId (lines ids)
+
+            (_, dflags') = runCmdLine (runEwM setFlags) dflags
+
+        return dflags'
+  where
+    -- Loading environments (by name or by location)
+
+    namedEnvPath :: String -> MaybeT IO FilePath
+    namedEnvPath name = do
+     appdir <- liftMaybeT $ versionedAppDir dflags
+     return $ appdir </> "environments" </> name
+
+    loadEnvName :: String -> MaybeT IO String
+    loadEnvName name = loadEnvFile =<< namedEnvPath name
+
+    loadEnvFile :: String -> MaybeT IO String
+    loadEnvFile path = do
+      guard =<< liftMaybeT (doesFileExist path)
+      liftMaybeT $ readFile path
+
+    -- Various ways to define which environment to use
+
+    getCmdLineArg :: MaybeT IO String
+    getCmdLineArg = MaybeT $ return $ packageEnv dflags
+
+    getEnvVar :: MaybeT IO String
+    getEnvVar = do
+      mvar <- liftMaybeT $ try $ getEnv "GHC_ENVIRONMENT"
+      case mvar of
+        Right var -> return var
+        Left err  -> if isDoesNotExistError err then mzero
+                                                else liftMaybeT $ throwIO err
+
+    defaultEnvName :: String
+    defaultEnvName = "default"
+
+    localEnvFile :: FilePath
+    localEnvFile = "./.ghc.environment"
+
+    -- Error reporting
+
+    cmdLineError :: String -> MaybeT IO a
+    cmdLineError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $
+      "Package environment " ++ show env ++ " not found"
+
+    envError :: String -> MaybeT IO a
+    envError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $
+         "Package environment "
+      ++ show env
+      ++ " (specified in GHC_ENVIRIONMENT) not found"
+
+
 -- If we're linking a binary, then only targets that produce object
 -- code are allowed (requests for other target types are ignored).
 setTarget :: HscTarget -> DynP ()
@@ -3719,13 +3847,14 @@ setObjTarget l = updM set
      | otherwise = return dflags
 
 setOptLevel :: Int -> DynFlags -> DynP DynFlags
-setOptLevel n dflags
+setOptLevel n dflags = return (updOptLevel n dflags)
+
+checkOptLevel :: Int -> DynFlags -> Either String DynFlags
+checkOptLevel n dflags
    | hscTarget dflags == HscInterpreted && n > 0
-        = do addWarn "-O conflicts with --interactive; -O ignored."
-             return dflags
+     = Left "-O conflicts with --interactive; -O ignored."
    | otherwise
-        = return (updOptLevel n dflags)
-
+     = Right dflags
 
 -- -Odph is equivalent to
 --
@@ -3981,10 +4110,13 @@ tARGET_MAX_WORD dflags
       8 -> toInteger (maxBound :: Word64)
       w -> panic ("tARGET_MAX_WORD: Unknown platformWordSize: " ++ show w)
 
+-- | Resolve any internal inconsistencies in a set of 'DynFlags'.
+-- Returns the consistent 'DynFlags' as well as a list of warnings
+-- to report to the user.
+makeDynFlagsConsistent :: DynFlags -> (DynFlags, [Located String])
 -- Whenever makeDynFlagsConsistent does anything, it starts over, to
 -- ensure that a later change doesn't invalidate an earlier check.
 -- Be careful not to introduce potential loops!
-makeDynFlagsConsistent :: DynFlags -> (DynFlags, [Located String])
 makeDynFlagsConsistent dflags
  -- Disable -dynamic-too on Windows (#8228, #7134, #5987)
  | os == OSMinGW32 && gopt Opt_BuildDynamicToo dflags
@@ -4023,6 +4155,8 @@ makeDynFlagsConsistent dflags
    not (gopt Opt_PIC dflags)
     = loop (gopt_set dflags Opt_PIC)
            "Enabling -fPIC as it is always on for this platform"
+ | Left err <- checkOptLevel (optLevel dflags) dflags
+    = loop (updOptLevel 0 dflags) err
  | otherwise = (dflags, [])
     where loc = mkGeneralSrcSpan (fsLit "when making flags consistent")
           loop updated_dflags warning
@@ -4032,6 +4166,33 @@ makeDynFlagsConsistent dflags
           arch = platformArch platform
           os   = platformOS   platform
 
+{-
+Note [DynFlags consistency]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+There are a number of number of DynFlags configurations which either
+do not make sense or lead to unimplemented or buggy codepaths in the
+compiler. makeDynFlagsConsistent is responsible for verifying the validity
+of a set of DynFlags, fixing any issues, and reporting them back to the
+caller.
+
+GHCi and -O
+---------------
+
+When using optimization, the compiler can introduce several things
+(such as unboxed tuples) into the intermediate code, which GHCi later
+chokes on since the bytecode interpreter can't handle this (and while
+this is arguably a bug these aren't handled, there are no plans to fix
+it.)
+
+While the driver pipeline always checks for this particular erroneous
+combination when parsing flags, we also need to check when we update
+the flags; this is because API clients may parse flags but update the
+DynFlags afterwords, before finally running code inside a session (see
+T10052 and #10052).
+
+-}
+
 --------------------------------------------------------------------------
 -- Do not use unsafeGlobalDynFlags!
 --
@@ -4039,7 +4200,8 @@ makeDynFlagsConsistent dflags
 -- to show SDocs when tracing, but we don't always have DynFlags
 -- available.
 --
--- Do not use it if you can help it. You may get the wrong value!
+-- Do not use it if you can help it. You may get the wrong value, or this
+-- panic!
 
 GLOBAL_VAR(v_unsafeGlobalDynFlags, panic "v_unsafeGlobalDynFlags: not initialised", DynFlags)
 

compiler/main/ErrUtils.hs

@@ -29,7 +29,7 @@ module ErrUtils (
         --  * Messages during compilation
         putMsg, printInfoForUser, printOutputForUser,
         logInfo, logOutput,
-        errorMsg,
+        errorMsg, warningMsg,
         fatalErrorMsg, fatalErrorMsg', fatalErrorMsg'',
         compilationProgressMsg,
         showPass,
@@ -291,6 +291,13 @@ dumpSDoc dflags print_unqual flag hdr doc
                             writeIORef gdref (Set.insert fileName gd)
                         createDirectoryIfMissing True (takeDirectory fileName)
                         handle <- openFile fileName mode
+
+                        -- We do not want the dump file to be affected by
+                        -- environment variables, but instead to always use
+                        -- UTF8. See:
+                        -- https://ghc.haskell.org/trac/ghc/ticket/10762
+                        hSetEncoding handle utf8
+
                         doc' <- if null hdr
                                 then return doc
                                 else do t <- getCurrentTime
@@ -314,7 +321,7 @@ dumpSDoc dflags print_unqual flag hdr doc
 chooseDumpFile :: DynFlags -> DumpFlag -> Maybe String
 chooseDumpFile dflags flag
 
-        | gopt Opt_DumpToFile dflags
+        | gopt Opt_DumpToFile dflags || flag == Opt_D_th_dec_file
         , Just prefix <- getPrefix
         = Just $ setDir (prefix ++ (beautifyDumpName flag))
 
@@ -338,6 +345,7 @@ chooseDumpFile dflags flag
 
 -- | Build a nice file name from name of a GeneralFlag constructor
 beautifyDumpName :: DumpFlag -> String
+beautifyDumpName Opt_D_th_dec_file = "th.hs"
 beautifyDumpName flag
  = let str = show flag
        suff = case stripPrefix "Opt_D_" str of
@@ -364,6 +372,10 @@ errorMsg :: DynFlags -> MsgDoc -> IO ()
 errorMsg dflags msg
    = log_action dflags dflags SevError noSrcSpan (defaultErrStyle dflags) msg
 
+warningMsg :: DynFlags -> MsgDoc -> IO ()
+warningMsg dflags msg
+   = log_action dflags dflags SevWarning noSrcSpan (defaultErrStyle dflags) msg
+
 fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
 fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) dflags msg
 

compiler/main/Finder.hs

@@ -590,8 +590,8 @@ cantFindErr cannot_find _ dflags mod_name find_result
     more_info
       = case find_result of
             NoPackage pkg
-                -> ptext (sLit "no package matching") <+> quotes (ppr pkg) <+>
-                   ptext (sLit "was found")
+                -> ptext (sLit "no package key matching") <+> quotes (ppr pkg) <+>
+                   ptext (sLit "was found") $$ looks_like_srcpkgid pkg
 
             NotFound { fr_paths = files, fr_pkg = mb_pkg
                      , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens
@@ -652,6 +652,18 @@ cantFindErr cannot_find _ dflags mod_name find_result
               ptext (sLit "to the build-depends in your .cabal file.")
      | otherwise = Outputable.empty
 
+    looks_like_srcpkgid :: PackageKey -> SDoc
+    looks_like_srcpkgid pk
+     -- Unsafely coerce a package key FastString into a source package ID
+     -- FastString and see if it means anything.
+     | (pkg:pkgs) <- searchPackageId dflags (SourcePackageId (packageKeyFS pk))
+     = parens (text "This package key looks like the source package ID;" $$
+       text "the real package key is" <+> quotes (ftext (packageKeyFS (packageKey pkg))) $$
+       (if null pkgs then Outputable.empty
+        else text "and" <+> int (length pkgs) <+> text "other candidates"))
+     -- Todo: also check if it looks like a package name!
+     | otherwise = Outputable.empty
+
     mod_hidden pkg =
         ptext (sLit "it is a hidden module in the package") <+> quotes (ppr pkg)
 

compiler/main/GHC.hs

@@ -172,7 +172,7 @@ module GHC (
         DataCon,
         dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
         dataConIsInfix, isVanillaDataCon, dataConUserType,
-        dataConStrictMarks,  
+        dataConSrcBangs,
         StrictnessMark(..), isMarkedStrict,
 
         -- ** Classes
@@ -245,7 +245,8 @@ module GHC (
 
         -- * API Annotations
         ApiAnns,AnnKeywordId(..),AnnotationComment(..),
-        getAnnotation, getAnnotationComments,
+        getAnnotation, getAndRemoveAnnotation,
+        getAnnotationComments, getAndRemoveAnnotationComments,
 
         -- * Miscellaneous
         --sessionHscEnv,
@@ -543,17 +544,19 @@ checkBrokenTablesNextToCode' dflags
 --
 setSessionDynFlags :: GhcMonad m => DynFlags -> m [PackageKey]
 setSessionDynFlags dflags = do
-  (dflags', preload) <- liftIO $ initPackages dflags
-  modifySession $ \h -> h{ hsc_dflags = dflags'
-                         , hsc_IC = (hsc_IC h){ ic_dflags = dflags' } }
+  dflags' <- checkNewDynFlags dflags
+  (dflags'', preload) <- liftIO $ initPackages dflags'
+  modifySession $ \h -> h{ hsc_dflags = dflags''
+                         , hsc_IC = (hsc_IC h){ ic_dflags = dflags'' } }
   invalidateModSummaryCache
   return preload
 
 -- | Sets the program 'DynFlags'.
 setProgramDynFlags :: GhcMonad m => DynFlags -> m [PackageKey]
 setProgramDynFlags dflags = do
-  (dflags', preload) <- liftIO $ initPackages dflags
-  modifySession $ \h -> h{ hsc_dflags = dflags' }
+  dflags' <- checkNewDynFlags dflags
+  (dflags'', preload) <- liftIO $ initPackages dflags'
+  modifySession $ \h -> h{ hsc_dflags = dflags'' }
   invalidateModSummaryCache
   return preload
 
@@ -592,7 +595,8 @@ getProgramDynFlags = getSessionDynFlags
 -- 'pkgState' into the interactive @DynFlags@.
 setInteractiveDynFlags :: GhcMonad m => DynFlags -> m ()
 setInteractiveDynFlags dflags = do
-  modifySession $ \h -> h{ hsc_IC = (hsc_IC h) { ic_dflags = dflags }}
+  dflags' <- checkNewDynFlags dflags
+  modifySession $ \h -> h{ hsc_IC = (hsc_IC h) { ic_dflags = dflags' }}
 
 -- | Get the 'DynFlags' used to evaluate interactive expressions.
 getInteractiveDynFlags :: GhcMonad m => m DynFlags
@@ -604,6 +608,15 @@ parseDynamicFlags :: MonadIO m =>
                   -> m (DynFlags, [Located String], [Located String])
 parseDynamicFlags = parseDynamicFlagsCmdLine
 
+-- | Checks the set of new DynFlags for possibly erroneous option
+-- combinations when invoking 'setSessionDynFlags' and friends, and if
+-- found, returns a fixed copy (if possible).
+checkNewDynFlags :: MonadIO m => DynFlags -> m DynFlags
+checkNewDynFlags dflags = do
+  -- See Note [DynFlags consistency]
+  let (dflags', warnings) = makeDynFlagsConsistent dflags
+  liftIO $ handleFlagWarnings dflags warnings
+  return dflags'
 
 -- %************************************************************************
 -- %*                                                                      *

compiler/main/GhcMake.hs

@@ -427,14 +427,22 @@ guessOutputFile = modifySession $ \env ->
             ml_hs_file (ms_location ms)
         name = fmap dropExtension mainModuleSrcPath
 
+        name_exe = do
 #if defined(mingw32_HOST_OS)
-        -- we must add the .exe extention unconditionally here, otherwise
-        -- when name has an extension of its own, the .exe extension will
-        -- not be added by DriverPipeline.exeFileName.  See #2248
-        name_exe = fmap (<.> "exe") name
+          -- we must add the .exe extention unconditionally here, otherwise
+          -- when name has an extension of its own, the .exe extension will
+          -- not be added by DriverPipeline.exeFileName.  See #2248
+          name' <- fmap (<.> "exe") name
 #else
-        name_exe = name
+          name' <- name
 #endif
+          mainModuleSrcPath' <- mainModuleSrcPath
+          -- #9930: don't clobber input files (unless they ask for it)
+          if name' == mainModuleSrcPath'
+            then throwGhcException . UsageError $
+                 "default output name would overwrite the input file; " ++
+                 "must specify -o explicitly"
+            else Just name'
     in
     case outputFile dflags of
         Just _ -> env
@@ -1136,6 +1144,15 @@ upsweep old_hpt stable_mods cleanup sccs = do
 
                 upsweep' old_hpt1 done' mods (mod_index+1) nmods
 
+maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime)
+maybeGetIfaceDate dflags location
+ | writeInterfaceOnlyMode dflags
+    -- Minor optimization: it should be harmless to check the hi file location
+    -- always, but it's better to avoid hitting the filesystem if possible.
+    = modificationTimeIfExists (ml_hi_file location)
+ | otherwise
+    = return Nothing
+
 -- | Compile a single module.  Always produce a Linkable for it if
 -- successful.  If no compilation happened, return the old Linkable.
 upsweep_mod :: HscEnv
@@ -1150,6 +1167,7 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
             this_mod_name = ms_mod_name summary
             this_mod    = ms_mod summary
             mb_obj_date = ms_obj_date summary
+            mb_if_date  = ms_iface_date summary
             obj_fn      = ml_obj_file (ms_location summary)
             hs_date     = ms_hs_date summary
 
@@ -1287,11 +1305,26 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
                           linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date
                           compile_it_discard_iface (Just linkable) SourceUnmodified
 
+          -- See Note [Recompilation checking when typechecking only]
+          | writeInterfaceOnlyMode dflags,
+            Just if_date <- mb_if_date,
+            if_date >= hs_date -> do
+                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+                           (text "skipping tc'd mod:" <+> ppr this_mod_name)
+                compile_it Nothing SourceUnmodified
+
          _otherwise -> do
                 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
                            (text "compiling mod:" <+> ppr this_mod_name)
                 compile_it Nothing SourceModified
 
+-- Note [Recompilation checking when typechecking only]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- If we are compiling with -fno-code -fwrite-interface, there won't
+-- be any object code that we can compare against, nor should there
+-- be: we're *just* generating interface files.  In this case, we
+-- want to check if the interface file is new, in lieu of the object
+-- file.  See also Trac #9243.
 
 
 -- Filter modules in the HPT
@@ -1691,6 +1724,7 @@ summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
    | Just old_summary <- findSummaryBySourceFile old_summaries file
    = do
         let location = ms_location old_summary
+            dflags = hsc_dflags hsc_env
 
         src_timestamp <- get_src_timestamp
                 -- The file exists; we checked in getRootSummary above.
@@ -1707,7 +1741,9 @@ summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
                         || obj_allowed -- bug #1205
                         then liftIO $ getObjTimestamp location NotBoot
                         else return Nothing
-                  return old_summary{ ms_obj_date = obj_timestamp }
+                  hi_timestamp <- maybeGetIfaceDate dflags location
+                  return old_summary{ ms_obj_date = obj_timestamp
+                                    , ms_iface_date = hi_timestamp }
            else
                 new_summary src_timestamp
 
@@ -1745,6 +1781,8 @@ summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
                 then liftIO $ modificationTimeIfExists (ml_obj_file location)
                 else return Nothing
 
+        hi_timestamp <- maybeGetIfaceDate dflags location
+
         return (ModSummary { ms_mod = mod, ms_hsc_src = hsc_src,
                              ms_location = location,
                              ms_hspp_file = hspp_fn,
@@ -1752,6 +1790,7 @@ summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
                              ms_hspp_buf  = Just buf,
                              ms_srcimps = srcimps, ms_textual_imps = the_imps,
                              ms_hs_date = src_timestamp,
+                             ms_iface_date = hi_timestamp,
                              ms_obj_date = obj_timestamp })
 
 findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary
@@ -1808,7 +1847,9 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
                        || obj_allowed -- bug #1205
                        then getObjTimestamp location is_boot
                        else return Nothing
-                return (Just (Right old_summary{ ms_obj_date = obj_timestamp }))
+                hi_timestamp <- maybeGetIfaceDate dflags location
+                return (Just (Right old_summary{ ms_obj_date = obj_timestamp
+                                               , ms_iface_date = hi_timestamp}))
         | otherwise =
                 -- source changed: re-summarise.
                 new_summary location (ms_mod old_summary) src_fn src_timestamp
@@ -1880,6 +1921,8 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
               then getObjTimestamp location is_boot
               else return Nothing
 
+        hi_timestamp <- maybeGetIfaceDate dflags location
+
         return (Just (Right (ModSummary { ms_mod       = mod,
                               ms_hsc_src   = hsc_src,
                               ms_location  = location,
@@ -1889,6 +1932,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
                               ms_srcimps      = srcimps,
                               ms_textual_imps = the_imps,
                               ms_hs_date   = src_timestamp,
+                              ms_iface_date = hi_timestamp,
                               ms_obj_date  = obj_timestamp })))
 
 

compiler/main/HeaderInfo.hs

@@ -110,7 +110,8 @@ mkPrelImports this_mod loc implicit_prelude import_decls
 
       preludeImportDecl :: LImportDecl RdrName
       preludeImportDecl
-        = L loc $ ImportDecl { ideclName      = L loc pRELUDE_NAME,
+        = L loc $ ImportDecl { ideclSourceSrc = Nothing,
+                               ideclName      = L loc pRELUDE_NAME,
                                ideclPkgQual   = Nothing,
                                ideclSource    = False,
                                ideclSafe      = False,  -- Not a safe import

compiler/main/HscMain.hs

@@ -97,6 +97,7 @@ import CoreLint         ( lintInteractiveExpr )
 import DsMeta           ( templateHaskellNames )
 import VarEnv           ( emptyTidyEnv )
 import Panic
+import ConLike
 
 import GHC.Exts
 #endif
@@ -270,10 +271,11 @@ ioMsgMaybe' ioA = do
 -- | Lookup things in the compiler's environment
 
 #ifdef GHCI
-hscTcRnLookupRdrName :: HscEnv -> RdrName -> IO [Name]
-hscTcRnLookupRdrName hsc_env0 rdr_name = runInteractiveHsc hsc_env0 $ do
-   hsc_env <- getHscEnv
-   ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name
+hscTcRnLookupRdrName :: HscEnv -> Located RdrName -> IO [Name]
+hscTcRnLookupRdrName hsc_env0 rdr_name
+  = runInteractiveHsc hsc_env0 $
+    do { hsc_env <- getHscEnv
+       ; ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name }
 #endif
 
 hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
@@ -1083,7 +1085,11 @@ markUnsafeInfer tcg_env whyUnsafe = do
                             text str <+> text "is not allowed in Safe Haskell"]
         | otherwise = []
     badInsts insts = concat $ map badInst insts
-    badInst ins | overlapMode (is_flag ins) /= NoOverlap
+
+    checkOverlap (NoOverlap _) = False
+    checkOverlap _             = True
+
+    badInst ins | checkOverlap (overlapMode (is_flag ins))
                 = [mkLocMessage SevOutput (nameSrcSpan $ getName $ is_dfun ins) $
                       ppr (overlapMode $ is_flag ins) <+>
                       text "overlap mode isn't allowed in Safe Haskell"]
@@ -1505,6 +1511,7 @@ hscDeclsWithLocation hsc_env0 str source linenumber =
     liftIO $ linkDecls hsc_env src_span cbc
 
     let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg)
+        patsyns = mg_patsyns simpl_mg
 
         ext_ids = [ id | id <- bindersOfBinds core_binds
                        , isExternalName (idName id)
@@ -1515,11 +1522,11 @@ hscDeclsWithLocation hsc_env0 str source linenumber =
             -- The DFunIds are in 'cls_insts' (see Note [ic_tythings] in HscTypes
             -- Implicit Ids are implicit in tcs
 
-        tythings =  map AnId ext_ids ++ map ATyCon tcs
+        tythings =  map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns
 
     let icontext = hsc_IC hsc_env
         ictxt    = extendInteractiveContext icontext ext_ids tcs
-                                            cls_insts fam_insts defaults
+                                            cls_insts fam_insts defaults patsyns
     return (tythings, ictxt)
 
 hscImport :: HscEnv -> String -> IO (ImportDecl RdrName)