SCC analysis for instances as well as types/classes
authorSimon Peyton Jones <simonpj@microsoft.com>
Wed, 20 Apr 2016 11:56:40 +0000 (12:56 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Wed, 20 Apr 2016 13:28:34 +0000 (14:28 +0100)
This big patch is in pursuit of Trac #11348.

It is largely the work of Alex Veith (thank you!), with some
follow-up simplification and refactoring from Simon PJ.

The main payload is described in RnSource
  Note [Dependency analysis of type, class, and instance decls]
which is pretty detailed.

* There is a new data type HsDecls.TyClGroup, for a strongly
  connected component of type/class/instance/role decls.

  The hs_instds field of HsGroup disappears, in consequence

  This forces some knock-on changes, including a minor
  haddock submodule update

Smaller, weakly-related things

* I found that both the renamer and typechecker were building an
  identical env for RoleAnnots, so I put common code for
  RoleAnnotEnv in RnEnv.

* I found that tcInstDecls1 had very clumsy error handling, so I
  put it together into TcInstDcls.doClsInstErrorChecks

27 files changed:
compiler/deSugar/DsMeta.hs
compiler/hsSyn/HsDecls.hs
compiler/hsSyn/HsUtils.hs
compiler/parser/RdrHsSyn.hs
compiler/rename/RnEnv.hs
compiler/rename/RnNames.hs
compiler/rename/RnSource.hs
compiler/typecheck/TcDeriv.hs
compiler/typecheck/TcInstDcls.hs
compiler/typecheck/TcInstDcls.hs-boot [new file with mode: 0644]
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcTyClsDecls.hs
compiler/typecheck/TcTyDecls.hs
testsuite/tests/deriving/should_fail/T9687.stderr
testsuite/tests/driver/sigof02/Map.hsig
testsuite/tests/ghci/scripts/T4175.stdout
testsuite/tests/indexed-types/should_fail/T8550.stderr
testsuite/tests/polykinds/T8132.stderr
testsuite/tests/rename/should_compile/T4003A.hs-boot
testsuite/tests/roles/should_compile/T8958.stderr
testsuite/tests/th/T1835.stdout
testsuite/tests/typecheck/should_compile/T11348.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/all.T
testsuite/tests/typecheck/should_fail/T6018fail.stderr
testsuite/tests/typecheck/should_fail/tcfail211.stderr
utils/ghctags/Main.hs
utils/haddock

index 8f925d3..3e224a3 100644 (file)
@@ -110,7 +110,6 @@ repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
 repTopDs group@(HsGroup { hs_valds   = valds
                         , hs_splcds  = splcds
                         , hs_tyclds  = tyclds
-                        , hs_instds  = instds
                         , hs_derivds = derivds
                         , hs_fixds   = fixds
                         , hs_defds   = defds
@@ -121,7 +120,8 @@ repTopDs group@(HsGroup { hs_valds   = valds
                         , hs_vects   = vects
                         , hs_docs    = docs })
  = do { let { tv_bndrs = hsSigTvBinders valds
-            ; bndrs = tv_bndrs ++ hsGroupBinders group } ;
+            ; bndrs = tv_bndrs ++ hsGroupBinders group
+            ; instds = tyclds >>= group_instds } ;
         ss <- mkGenSyms bndrs ;
 
         -- Bind all the names mainly to avoid repeated use of explicit strings.
@@ -134,7 +134,7 @@ repTopDs group@(HsGroup { hs_valds   = valds
         decls <- addBinds ss (
                   do { val_ds   <- rep_val_binds valds
                      ; _        <- mapM no_splice splcds
-                     ; tycl_ds  <- mapM repTyClD (tyClGroupConcat tyclds)
+                     ; tycl_ds  <- mapM repTyClD (tyClGroupTyClDecls tyclds)
                      ; role_ds  <- mapM repRoleD (concatMap group_roles tyclds)
                      ; inst_ds  <- mapM repInstD instds
                      ; deriv_ds <- mapM repStandaloneDerivD derivds
index 82a78fe..dfcb6c1 100644 (file)
@@ -22,7 +22,8 @@ module HsDecls (
 
   -- ** Class or type declarations
   TyClDecl(..), LTyClDecl,
-  TyClGroup(..), tyClGroupConcat, mkTyClGroup,
+  TyClGroup(..), mkTyClGroup, emptyTyClGroup,
+  tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls,
   isClassDecl, isDataDecl, isSynDecl, tcdName,
   isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl,
   isOpenTypeFamilyInfo, isClosedTypeFamilyInfo,
@@ -79,7 +80,7 @@ module HsDecls (
   resultVariableName,
 
   -- * Grouping
-  HsGroup(..),  emptyRdrGroup, emptyRnGroup, appendGroups
+  HsGroup(..),  emptyRdrGroup, emptyRnGroup, appendGroups, hsGroupInstDecls
 
     ) where
 
@@ -166,14 +167,11 @@ data HsGroup id
         hs_splcds :: [LSpliceDecl id],
 
         hs_tyclds :: [TyClGroup id],
-                -- A list of mutually-recursive groups
-                -- No family-instances here; they are in hs_instds
+                -- A list of mutually-recursive groups;
+                -- This includes `InstDecl`s as well;
                 -- Parser generates a singleton list;
                 -- renamer does dependency analysis
 
-        hs_instds  :: [LInstDecl id],
-                -- Both class and family instance declarations in here
-
         hs_derivds :: [LDerivDecl id],
 
         hs_fixds  :: [LFixitySig id],
@@ -195,7 +193,10 @@ emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a
 emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }
 emptyRnGroup  = emptyGroup { hs_valds = emptyValBindsOut }
 
-emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [],
+hsGroupInstDecls :: HsGroup id -> [LInstDecl id]
+hsGroupInstDecls = (=<<) group_instds . hs_tyclds
+
+emptyGroup = HsGroup { hs_tyclds = [],
                        hs_derivds = [],
                        hs_fixds = [], hs_defds = [], hs_annds = [],
                        hs_fords = [], hs_warnds = [], hs_ruleds = [], hs_vects = [],
@@ -209,7 +210,6 @@ appendGroups
         hs_valds  = val_groups1,
         hs_splcds = spliceds1,
         hs_tyclds = tyclds1,
-        hs_instds = instds1,
         hs_derivds = derivds1,
         hs_fixds  = fixds1,
         hs_defds  = defds1,
@@ -223,7 +223,6 @@ appendGroups
         hs_valds  = val_groups2,
         hs_splcds = spliceds2,
         hs_tyclds = tyclds2,
-        hs_instds = instds2,
         hs_derivds = derivds2,
         hs_fixds  = fixds2,
         hs_defds  = defds2,
@@ -238,7 +237,6 @@ appendGroups
         hs_valds  = val_groups1 `plusHsValBinds` val_groups2,
         hs_splcds = spliceds1 ++ spliceds2,
         hs_tyclds = tyclds1 ++ tyclds2,
-        hs_instds = instds1 ++ instds2,
         hs_derivds = derivds1 ++ derivds2,
         hs_fixds  = fixds1 ++ fixds2,
         hs_annds  = annds1 ++ annds2,
@@ -268,7 +266,6 @@ instance OutputableBndr name => Outputable (HsDecl name) where
 instance OutputableBndr name => Outputable (HsGroup name) where
     ppr (HsGroup { hs_valds  = val_decls,
                    hs_tyclds = tycl_decls,
-                   hs_instds = inst_decls,
                    hs_derivds = deriv_decls,
                    hs_fixds  = fix_decls,
                    hs_warnds = deprec_decls,
@@ -285,8 +282,8 @@ instance OutputableBndr name => Outputable (HsGroup name) where
              if isEmptyValBinds val_decls
                 then Nothing
                 else Just (ppr val_decls),
-             ppr_ds (tyClGroupConcat tycl_decls),
-             ppr_ds inst_decls,
+             ppr_ds (tyClGroupTyClDecls tycl_decls),
+             ppr_ds (tyClGroupInstDecls tycl_decls),
              ppr_ds deriv_decls,
              ppr_ds foreign_decls]
         where
@@ -318,14 +315,12 @@ instance OutputableBndr name => Outputable (SpliceDecl name) where
 {-
 ************************************************************************
 *                                                                      *
-\subsection[SynDecl]{@data@, @newtype@ or @type@ (synonym) type declaration}
+            Type and class declarations
 *                                                                      *
 ************************************************************************
 
-                --------------------------------
-                        THE NAMING STORY
-                --------------------------------
-
+Note [The Naming story]
+~~~~~~~~~~~~~~~~~~~~~~~
 Here is the story about the implicit names that go with type, class,
 and instance decls.  It's a bit tricky, so pay attention!
 
@@ -530,22 +525,6 @@ data TyClDecl name
   deriving (Typeable)
 deriving instance (DataId id) => Data (TyClDecl id)
 
- -- This is used in TcTyClsDecls to represent
- -- strongly connected components of decls
- -- No familiy instances in here
- -- The role annotations must be grouped with their decls for the
- -- type-checker to infer roles correctly
-data TyClGroup name
-  = TyClGroup { group_tyclds :: [LTyClDecl name]
-              , group_roles  :: [LRoleAnnotDecl name] }
-    deriving (Typeable)
-deriving instance (DataId id) => Data (TyClGroup id)
-
-tyClGroupConcat :: [TyClGroup name] -> [LTyClDecl name]
-tyClGroupConcat = concatMap group_tyclds
-
-mkTyClGroup :: [LTyClDecl name] -> TyClGroup name
-mkTyClGroup decls = TyClGroup { group_tyclds = decls, group_roles = [] }
 
 -- Simple classifiers for TyClDecl
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -677,9 +656,14 @@ instance OutputableBndr name
                      <+> pprFundeps (map unLoc fds)
 
 instance OutputableBndr name => Outputable (TyClGroup name) where
-  ppr (TyClGroup { group_tyclds = tyclds, group_roles = roles })
+  ppr (TyClGroup { group_tyclds = tyclds
+                 , group_roles = roles
+                 , group_instds = instds
+                 }
+      )
     = ppr tyclds $$
-      ppr roles
+      ppr roles $$
+      ppr instds
 
 pp_vanilla_decl_head :: OutputableBndr name
    => Located name
@@ -698,73 +682,165 @@ pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } })
   = ppr nd
 
 
+{- Note [Complete user-supplied kind signatures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We kind-check declarations differently if they have a complete, user-supplied
+kind signature (CUSK). This is because we can safely generalise a CUSKed
+declaration before checking all of the others, supporting polymorphic recursion.
+See ghc.haskell.org/trac/ghc/wiki/GhcKinds/KindInference#Proposednewstrategy
+and #9200 for lots of discussion of how we got here.
+
+A declaration has a CUSK if we can know its complete kind without doing any
+inference, at all. Here are the rules:
+
+ - A class or datatype is said to have a CUSK if and only if all of its type
+variables are annotated. Its result kind is, by construction, Constraint or *
+respectively.
+
+ - A type synonym has a CUSK if and only if all of its type variables and its
+RHS are annotated with kinds.
+
+ - A closed type family is said to have a CUSK if and only if all of its type
+variables and its return type are annotated.
+
+ - An open type family always has a CUSK -- unannotated type variables (and
+return type) default to *.
+
+ - Additionally, if -XTypeInType is on, then a data definition with a top-level
+   :: must explicitly bind all kind variables to the right of the ::.
+   See test dependent/should_compile/KindLevels, which requires this case.
+   (Naturally, any kind variable mentioned before the :: should not be bound
+   after it.)
+-}
+
+
+{- *********************************************************************
+*                                                                      *
+                         TyClGroup
+        Strongly connected components of
+      type, class, instance, and role declarations
+*                                                                      *
+********************************************************************* -}
+
+{- Note [TyClGroups and dependency analysis]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A TyClGroup represents a strongly connected components of type/class/instance
+decls, together with the role annotations for the type/class declarations.
+
+The hs_tyclds :: [TyClGroup] field of a HsGroup is a dependency-order
+sequence of strongly-connected components.
+
+Invariants
+ * The type and class declarations, group_tyclds, may depend on each
+   other, or earlier TyClGroups, but not on later ones
+
+ * The role annotations, group_roles, are role-annotations for some or
+   all of the types and classes in group_tyclds (only).
+
+ * The instance declarations, group_instds, may (and usually will)
+   depend on group_tyclds, or on earlier TyClGroups, but not on later
+   ones.
+
+See Note [Dependency analsis of type, class, and instance decls]
+in RnSource for more info.
+-}
+
+data TyClGroup name  -- See Note [TyClGroups and dependency analysis]
+  = TyClGroup { group_tyclds :: [LTyClDecl name]
+              , group_roles  :: [LRoleAnnotDecl name]
+              , group_instds :: [LInstDecl name] }
+    deriving (Typeable)
+deriving instance (DataId id) => Data (TyClGroup id)
+
+emptyTyClGroup :: TyClGroup name
+emptyTyClGroup = TyClGroup [] [] []
+
+tyClGroupTyClDecls :: [TyClGroup name] -> [LTyClDecl name]
+tyClGroupTyClDecls = concatMap group_tyclds
+
+tyClGroupInstDecls :: [TyClGroup name] -> [LInstDecl name]
+tyClGroupInstDecls = concatMap group_instds
+
+tyClGroupRoleDecls :: [TyClGroup name] -> [LRoleAnnotDecl name]
+tyClGroupRoleDecls = concatMap group_roles
+
+mkTyClGroup :: [LTyClDecl name] -> [LInstDecl name] -> TyClGroup name
+mkTyClGroup decls instds = TyClGroup
+  { group_tyclds = decls
+  , group_roles = []
+  , group_instds = instds
+  }
+
+
+
 {- *********************************************************************
 *                                                                      *
                Data and type family declarations
 *                                                                      *
 ********************************************************************* -}
 
--- Note [FamilyResultSig]
--- ~~~~~~~~~~~~~~~~~~~~~~
---
--- This data type represents the return signature of a type family.  Possible
--- values are:
---
---  * NoSig - the user supplied no return signature:
---       type family Id a where ...
---
---  * KindSig - the user supplied the return kind:
---       type family Id a :: * where ...
---
---  * TyVarSig - user named the result with a type variable and possibly
---    provided a kind signature for that variable:
---       type family Id a = r where ...
---       type family Id a = (r :: *) where ...
---
---    Naming result of a type family is required if we want to provide
---    injectivity annotation for a type family:
---       type family Id a = r | r -> a where ...
---
--- See also: Note [Injectivity annotation]
+{- Note [FamilyResultSig]
+~~~~~~~~~~~~~~~~~~~~~~~~~
 
--- Note [Injectivity annotation]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- A user can declare a type family to be injective:
---
---    type family Id a = r | r -> a where ...
---
---  * The part after the "|" is called "injectivity annotation".
---  * "r -> a" part is called "injectivity condition"; at the moment terms
---    "injectivity annotation" and "injectivity condition" are synonymous
---    because we only allow a single injectivity condition.
---  * "r" is the "LHS of injectivity condition". LHS can only contain the
---    variable naming the result of a type family.
-
---  * "a" is the "RHS of injectivity condition". RHS contains space-separated
---    type and kind variables representing the arguments of a type
---    family. Variables can be omitted if a type family is not injective in
---    these arguments. Example:
---          type family Foo a b c = d | d -> a c where ...
---
--- Note that:
---  a) naming of type family result is required to provide injectivity
---     annotation
---  b) for associated types if the result was named then injectivity annotation
---     is mandatory. Otherwise result type variable is indistinguishable from
---     associated type default.
---
--- It is possible that in the future this syntax will be extended to support
--- more complicated injectivity annotations. For example we could declare that
--- if we know the result of Plus and one of its arguments we can determine the
--- other argument:
---
---    type family Plus a b = (r :: Nat) | r a -> b, r b -> a where ...
---
--- Here injectivity annotation would consist of two comma-separated injectivity
--- conditions.
---
--- See also Note [Injective type families] in TyCon
+This data type represents the return signature of a type family.  Possible
+values are:
+
+ * NoSig - the user supplied no return signature:
+      type family Id a where ...
+
+ * KindSig - the user supplied the return kind:
+      type family Id a :: * where ...
+
+ * TyVarSig - user named the result with a type variable and possibly
+   provided a kind signature for that variable:
+      type family Id a = r where ...
+      type family Id a = (r :: *) where ...
+
+   Naming result of a type family is required if we want to provide
+   injectivity annotation for a type family:
+      type family Id a = r | r -> a where ...
+
+See also: Note [Injectivity annotation]
+
+Note [Injectivity annotation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+A user can declare a type family to be injective:
+
+   type family Id a = r | r -> a where ...
+
+ * The part after the "|" is called "injectivity annotation".
+ * "r -> a" part is called "injectivity condition"; at the moment terms
+   "injectivity annotation" and "injectivity condition" are synonymous
+   because we only allow a single injectivity condition.
+ * "r" is the "LHS of injectivity condition". LHS can only contain the
+   variable naming the result of a type family.
+
+ * "a" is the "RHS of injectivity condition". RHS contains space-separated
+   type and kind variables representing the arguments of a type
+   family. Variables can be omitted if a type family is not injective in
+   these arguments. Example:
+         type family Foo a b c = d | d -> a c where ...
+
+Note that:
+ (a) naming of type family result is required to provide injectivity
+     annotation
+ (b) for associated types if the result was named then injectivity annotation
+     is mandatory. Otherwise result type variable is indistinguishable from
+     associated type default.
+
+It is possible that in the future this syntax will be extended to support
+more complicated injectivity annotations. For example we could declare that
+if we know the result of Plus and one of its arguments we can determine the
+other argument:
+
+   type family Plus a b = (r :: Nat) | r a -> b, r b -> a where ...
+
+Here injectivity annotation would consist of two comma-separated injectivity
+conditions.
+
+See also Note [Injective type families] in TyCon
+-}
 
 type LFamilyResultSig name = Located (FamilyResultSig name)
 data FamilyResultSig name = -- see Note [FamilyResultSig]
@@ -859,38 +935,6 @@ resultVariableName :: FamilyResultSig a -> Maybe a
 resultVariableName (TyVarSig sig) = Just $ hsLTyVarName sig
 resultVariableName _              = Nothing
 
-{-
-Note [Complete user-supplied kind signatures]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We kind-check declarations differently if they have a complete, user-supplied
-kind signature (CUSK). This is because we can safely generalise a CUSKed
-declaration before checking all of the others, supporting polymorphic recursion.
-See ghc.haskell.org/trac/ghc/wiki/GhcKinds/KindInference#Proposednewstrategy
-and #9200 for lots of discussion of how we got here.
-
-A declaration has a CUSK if we can know its complete kind without doing any
-inference, at all. Here are the rules:
-
- - A class or datatype is said to have a CUSK if and only if all of its type
-variables are annotated. Its result kind is, by construction, Constraint or *
-respectively.
-
- - A type synonym has a CUSK if and only if all of its type variables and its
-RHS are annotated with kinds.
-
- - A closed type family is said to have a CUSK if and only if all of its type
-variables and its return type are annotated.
-
- - An open type family always has a CUSK -- unannotated type variables (and
-return type) default to *.
-
- - Additionally, if -XTypeInType is on, then a data definition with a top-level
-   :: must explicitly bind all kind variables to the right of the ::.
-   See test dependent/should_compile/KindLevels, which requires this case.
-   (Naturally, any kind variable mentioned before the :: should not be bound
-   after it.)
--}
-
 instance (OutputableBndr name) => Outputable (FamilyDecl name) where
   ppr = pprFamilyDecl TopLevel
 
index 8ac7e24..35f146b 100644 (file)
@@ -80,6 +80,7 @@ module HsUtils(
 
   hsLTyClDeclBinders, hsTyClForeignBinders, hsPatSynBinders,
   hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,
+  hsDataDefnBinders,
 
   -- Collecting implicit binders
   lStmtsImplicits, hsValBindsImplicits, lPatImplicits
@@ -883,18 +884,21 @@ 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 })
+                          hs_fords = foreign_decls })
   =  collectHsValBinders val_decls
-  ++ hsTyClForeignBinders tycl_decls inst_decls foreign_decls
+  ++ hsTyClForeignBinders tycl_decls foreign_decls
 
-hsTyClForeignBinders :: [TyClGroup Name] -> [LInstDecl Name]
-                     -> [LForeignDecl Name] -> [Name]
+hsTyClForeignBinders :: [TyClGroup Name]
+                     -> [LForeignDecl Name]
+                     -> [Name]
 -- We need to look at instance declarations too,
 -- because their associated types may bind data constructors
-hsTyClForeignBinders tycl_decls inst_decls foreign_decls
-  = map unLoc (hsForeignDeclsBinders foreign_decls)
-    ++ getSelectorNames (foldMap (foldMap hsLTyClDeclBinders . group_tyclds) tycl_decls
-                        `mappend` foldMap hsLInstDeclBinders inst_decls)
+hsTyClForeignBinders tycl_decls foreign_decls
+  =    map unLoc (hsForeignDeclsBinders foreign_decls)
+    ++ getSelectorNames
+         (foldMap (foldMap hsLTyClDeclBinders . group_tyclds) tycl_decls
+         `mappend`
+         foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls)
   where
     getSelectorNames :: ([Located Name], [LFieldOcc Name]) -> [Name]
     getSelectorNames (ns, fs) = map unLoc ns ++ map (selectorFieldOcc.unLoc) fs
@@ -902,6 +906,7 @@ hsTyClForeignBinders tycl_decls inst_decls foreign_decls
 -------------------
 hsLTyClDeclBinders :: Located (TyClDecl name) -> ([Located name], [LFieldOcc name])
 -- ^ Returns all the /binding/ names of the decl.  The first one is
+
 -- guaranteed to be the name of the decl. The first component
 -- represents all binding names except record fields; the second
 -- represents field occurrences. For record fields mentioned in
index 8aeeb9d..28ee4f0 100644 (file)
@@ -118,7 +118,7 @@ import Data.Data       ( dataTypeOf, fromConstr, dataTypeConstrs )
 
 -- Similarly for mkConDecl, mkClassOpSig and default-method names.
 
---         *** See "THE NAMING STORY" in HsDecls ****
+--         *** See Note [The Naming story] in HsDecls ****
 
 mkTyClD :: LTyClDecl n -> LHsDecl n
 mkTyClD (L loc d) = L loc (TyClD d)
index 4c9940d..9f43169 100644 (file)
@@ -37,6 +37,10 @@ module RnEnv (
         bindLocatedLocalsFV, bindLocatedLocalsRn,
         extendTyVarEnvFVRn,
 
+        -- Role annotations
+        RoleAnnotEnv, emptyRoleAnnotEnv, mkRoleAnnotEnv,
+        lookupRoleAnnot, getRoleAnnots,
+
         checkDupRdrNames, checkShadowedRdrNames,
         checkDupNames, checkDupAndShadowedNames, dupNamesErr,
         checkTupSize,
@@ -1535,6 +1539,35 @@ lookupFieldFixityRn (Ambiguous   (L _ rdr) _) = get_ambiguous_fixity rdr
                                  2 (pprNameProvenance elt)
 
 
+{- *********************************************************************
+*                                                                      *
+                        Role annotations
+*                                                                      *
+********************************************************************* -}
+
+type RoleAnnotEnv = NameEnv (LRoleAnnotDecl Name)
+
+mkRoleAnnotEnv :: [LRoleAnnotDecl Name] -> RoleAnnotEnv
+mkRoleAnnotEnv role_annot_decls
+ = mkNameEnv [ (name, ra_decl)
+             | ra_decl <- role_annot_decls
+             , let name = roleAnnotDeclName (unLoc ra_decl)
+             , not (isUnboundName name) ]
+       -- Some of the role annots will be unbound;
+       -- we don't wish to include these
+
+emptyRoleAnnotEnv :: RoleAnnotEnv
+emptyRoleAnnotEnv = emptyNameEnv
+
+lookupRoleAnnot :: RoleAnnotEnv -> Name -> Maybe (LRoleAnnotDecl Name)
+lookupRoleAnnot = lookupNameEnv
+
+getRoleAnnots :: [Name] -> RoleAnnotEnv -> ([LRoleAnnotDecl Name], RoleAnnotEnv)
+getRoleAnnots bndrs role_env
+  = ( mapMaybe (lookupRoleAnnot role_env) bndrs
+    , delListFromNameEnv role_env bndrs )
+
+
 {-
 ************************************************************************
 *                                                                      *
index 0bc6386..24e6bca 100644 (file)
@@ -526,7 +526,7 @@ extendGlobalRdrEnvRn avails new_fixities
     getLocalDeclBindersd@ returns the names for an HsDecl
              It's used for source code.
 
-        *** See "THE NAMING STORY" in HsDecls ****
+        *** See Note [The Naming story] in HsDecls ****
 *                                                                      *
 ********************************************************************* -}
 
@@ -544,12 +544,13 @@ getLocalNonValBinders :: MiniFixityEnv -> HsGroup RdrName
 getLocalNonValBinders fixity_env
      (HsGroup { hs_valds  = binds,
                 hs_tyclds = tycl_decls,
-                hs_instds = inst_decls,
                 hs_fords  = foreign_decls })
   = do  { -- Process all type/class decls *except* family instances
+        ; let inst_decls = tycl_decls >>= group_instds
         ; overload_ok <- xoptM LangExt.DuplicateRecordFields
-        ; (tc_avails, tc_fldss) <- fmap unzip $ mapM (new_tc overload_ok)
-                                                     (tyClGroupConcat tycl_decls)
+        ; (tc_avails, tc_fldss)
+            <- fmap unzip $ mapM (new_tc overload_ok)
+                                 (tyClGroupTyClDecls tycl_decls)
         ; traceRn (text "getLocalNonValBinders 1" <+> ppr tc_avails)
         ; envs <- extendGlobalRdrEnvRn tc_avails fixity_env
         ; setEnvs envs $ do {
index af60b7c..1a39feb 100644 (file)
@@ -46,15 +46,15 @@ import BasicTypes       ( RuleName, pprRuleName )
 import FastString
 import SrcLoc
 import DynFlags
+import Util             ( debugIsOn, partitionWith )
 import HscTypes         ( HscEnv, hsc_dflags )
 import ListSetOps       ( findDupsEq, removeDups, equivClasses )
-import Digraph          ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices )
+import Digraph          ( SCC, flattenSCC, flattenSCCs, stronglyConnCompFromEdgedVertices )
 import qualified GHC.LanguageExtensions as LangExt
 
 import Control.Monad
 import Control.Arrow ( first )
-import Data.List ( sortBy )
-import Maybes( orElse, mapMaybe )
+import Data.List ( sortBy, mapAccumL )
 import qualified Data.Set as Set ( difference, fromList, toList, null )
 
 {-
@@ -81,7 +81,6 @@ rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
 rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
                             hs_splcds  = splice_decls,
                             hs_tyclds  = tycl_decls,
-                            hs_instds  = inst_decls,
                             hs_derivds = deriv_decls,
                             hs_fixds   = fix_decls,
                             hs_warnds  = warn_decls,
@@ -147,7 +146,7 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
    -- So we content ourselves with gathering uses only; that
    -- means we'll only report a declaration as unused if it isn't
    -- mentioned at all.  Ah well.
-   traceRn (text "Start rnTyClDecls") ;
+   traceRn (text "Start rnTyClDecls" <+> ppr tycl_decls) ;
    (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ;
 
    -- (F) Rename Value declarations right-hand sides
@@ -176,16 +175,15 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
 
    -- (H) Rename Everything else
 
-   (rn_inst_decls,    src_fvs2) <- rnList rnSrcInstDecl   inst_decls ;
-   (rn_rule_decls,    src_fvs3) <- setXOptM LangExt.ScopedTypeVariables $
+   (rn_rule_decls,    src_fvs2) <- setXOptM LangExt.ScopedTypeVariables $
                                    rnList rnHsRuleDecls rule_decls ;
                            -- Inside RULES, scoped type variables are on
-   (rn_vect_decls,    src_fvs4) <- rnList rnHsVectDecl    vect_decls ;
-   (rn_foreign_decls, src_fvs5) <- rnList rnHsForeignDecl foreign_decls ;
-   (rn_ann_decls,     src_fvs6) <- rnList rnAnnDecl       ann_decls ;
-   (rn_default_decls, src_fvs7) <- rnList rnDefaultDecl   default_decls ;
-   (rn_deriv_decls,   src_fvs8) <- rnList rnSrcDerivDecl  deriv_decls ;
-   (rn_splice_decls,  src_fvs9) <- rnList rnSpliceDecl    splice_decls ;
+   (rn_vect_decls,    src_fvs3) <- rnList rnHsVectDecl    vect_decls ;
+   (rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_decls ;
+   (rn_ann_decls,     src_fvs5) <- rnList rnAnnDecl       ann_decls ;
+   (rn_default_decls, src_fvs6) <- rnList rnDefaultDecl   default_decls ;
+   (rn_deriv_decls,   src_fvs7) <- rnList rnSrcDerivDecl  deriv_decls ;
+   (rn_splice_decls,  src_fvs8) <- rnList rnSpliceDecl    splice_decls ;
       -- Haddock docs; no free vars
    rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
 
@@ -194,7 +192,6 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
    let {rn_group = HsGroup { hs_valds   = rn_val_decls,
                              hs_splcds  = rn_splice_decls,
                              hs_tyclds  = rn_tycl_decls,
-                             hs_instds  = rn_inst_decls,
                              hs_derivds = rn_deriv_decls,
                              hs_fixds   = rn_fix_decls,
                              hs_warnds  = [], -- warns are returned in the tcg_env
@@ -206,11 +203,10 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
                              hs_vects  = rn_vect_decls,
                              hs_docs   = rn_docs } ;
 
-        tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_inst_decls rn_foreign_decls ;
+        tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_foreign_decls ;
         other_def  = (Just (mkNameSet tcf_bndrs), emptyNameSet) ;
-        other_fvs  = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4,
-                              src_fvs5, src_fvs6, src_fvs7, src_fvs8,
-                              src_fvs9] ;
+        other_fvs  = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, src_fvs5,
+                              src_fvs6, src_fvs7, src_fvs8] ;
                 -- It is tiresome to gather the binders from type and class decls
 
         src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ;
@@ -1135,12 +1131,11 @@ rnHsVectDecl (HsVectInstIn instTy)
 rnHsVectDecl (HsVectInstOut _)
   = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectInstOut'"
 
-{-
-*********************************************************
-*                                                      *
-\subsection{Type, class and iface sig declarations}
-*                                                      *
-*********************************************************
+{- **************************************************************
+         *                                                      *
+      Renaming type, class, instance and role declarations
+*                                                               *
+*****************************************************************
 
 @rnTyDecl@ uses the `global name function' to create a new type
 declaration in which local names have been replaced by their original
@@ -1155,9 +1150,216 @@ in order to get the set of tyvars used by it, make an assoc list,
 and then go over it again to rename the tyvars!
 However, we can also do some scoping checks at the same time.
 
+Note [Dependency analysis of type, class, and instance decls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A TyClGroup represents a strongly connected components of
+type/class/instance decls, together with the role annotations for the
+type/class declarations.  The renamer uses strongyly connected
+comoponent analysis to build these groups.  We do this for a number of
+reasons:
+
+* Improve kind error messages. Consider
+
+     data T f a = MkT f a
+     data S f a = MkS f (T f a)
+
+  This has a kind error, but the error message is better if you
+  check T first, (fixing its kind) and *then* S.  If you do kind
+  inference together, you might get an error reported in S, which
+  is jolly confusing.  See Trac #4875
+
+
+* Increase kind polymorphism.  See TcTyClsDecls
+  Note [Grouping of type and class declarations]
+
+Why do the instance declarations participate?  At least two reasons
+
+* Consider (Trac #11348)
+
+     type family F a
+     type instance F Int = Bool
+
+     data R = MkR (F Int)
+
+     type Foo = 'MkR 'True
+
+  For Foo to kind-check we need to know that (F Int) ~ Bool.  But we won't
+  know that unless we've looked at the type instance declaration for F
+  before kind-checking Foo.
+
+* Another example is this (Trac #3990).
+
+     data family Complex a
+     data instance Complex Double = CD {-# UNPACK #-} !Double
+                                       {-# UNPACK #-} !Double
+
+     data T = T {-# UNPACK #-} !(Complex Double)
+
+  Here, to generate the right kind of unpacked implementation for T,
+  we must have access to the 'data instance' declaration.
+
+* Things become more complicated when we introduce transitive
+  dependencies through imported definitions, like in this scenario:
+
+      A.hs
+        type family Closed (t :: Type) :: Type where
+          Closed t = Open t
+
+        type family Open (t :: Type) :: Type
+
+      B.hs
+        data Q where
+          Q :: Closed Bool -> Q
+
+        type instance Open Int = Bool
+
+        type S = 'Q 'True
+
+  Somehow, we must ensure that the instance Open Int = Bool is checked before
+  the type synonym S. While we know that S depends upon 'Q depends upon Closed,
+  we have no idea that Closed depends upon Open!
+
+  To accomodate for these situations, we ensure that an instance is checked
+  before every @TyClDecl@ on which it does not depend. That's to say, instances
+  are checked as early as possible in @tcTyAndClassDecls@.
+
+------------------------------------
+So much for WHY.  What about HOW?  It's pretty easy:
+
+(1) Rename the type/class, instance, and role declarations
+    individually
+
+(2) Do strongly-connected component analysis of the type/class decls,
+    We'll make a TyClGroup for each SCC
+
+    In this step we treat a reference to a (promoted) data constructor
+    K as a dependency on its parent type.  Thus
+        data T = K1 | K2
+        data S = MkS (Proxy 'K1)
+    Here S depends on 'K1 and hence on its parent T.
+
+    In this step we ignore instances; see
+    Note [No dependencies on data instances]
+
+(3) Attach roles to the appropriate SCC
+
+(4) Attach instances to the appropriate SCC.
+    We add an instance decl to SCC when:
+      all its free types/classes are bound in this SCC or earlier ones
+
+(5) We make an initial TyClGroup, with empty group_tyclds, for any
+    (orphan) instances that affect only imported types/classes
+
+Steps (3) and (4) are done by the (mapAccumL mk_group) call.
+
+Note [No dependencies on data instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this
+   data family D a
+   data instance D Int = D1
+   data S = MkS (Proxy 'D1)
+
+Here the declaration of S depends on the /data instance/ declaration
+for 'D Int'.  That makes things a lot more complicated, especially
+if the data instance is an assocaited type of an enclosing class instance.
+(And the class instance might have several assocatiated type instances
+with different dependency structure!)
+
+Ugh.  For now we simply don't allow promotion of data constructors for
+data instaces.  See Note [AFamDataCon: not promoting data family
+constructors] in TcEnv
+-}
+
+
+rnTyClDecls :: [TyClGroup RdrName]
+            -> RnM ([TyClGroup Name], FreeVars)
+-- Rename the declarations and do dependency analysis on them
+rnTyClDecls tycl_ds
+  = do { -- Rename the type/class, instance, and role declaraations
+         tycls_w_fvs <- mapM (wrapLocFstM rnTyClDecl)
+                             (tyClGroupTyClDecls tycl_ds)
+       ; let tc_names = mkNameSet (map (tcdName . unLoc . fst) tycls_w_fvs)
+
+       ; instds_w_fvs <- mapM (wrapLocFstM rnSrcInstDecl) (tyClGroupInstDecls tycl_ds)
+       ; role_annots  <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds)
+
+       ; tycls_w_fvs <- addBootDeps tycls_w_fvs
+                      -- TBD must add_boot_deps to instds_w_fvs?
+
+       -- Do SCC analysis on the type/class decls
+       ; rdr_env <- getGlobalRdrEnv
+       ; let tycl_sccs = depAnalTyClDecls rdr_env tycls_w_fvs
+             role_annot_env = mkRoleAnnotEnv role_annots
+
+             inst_ds_map = mkInstDeclFreeVarsMap rdr_env tc_names instds_w_fvs
+             (init_inst_ds, rest_inst_ds) = getInsts [] inst_ds_map
+
+             first_group
+               | null init_inst_ds = []
+               | otherwise = [TyClGroup { group_tyclds = []
+                                        , group_roles  = []
+                                        , group_instds = init_inst_ds }]
+
+             ((final_inst_ds, orphan_roles), groups)
+                = mapAccumL mk_group (rest_inst_ds, role_annot_env) tycl_sccs
+
+
+             all_fvs = plusFV (foldr (plusFV . snd) emptyFVs tycls_w_fvs)
+                              (foldr (plusFV . snd) emptyFVs instds_w_fvs)
+
+             all_groups = first_group ++ groups
+
+       ; ASSERT2( null final_inst_ds,  ppr instds_w_fvs $$ ppr inst_ds_map
+                                       $$ ppr (flattenSCCs tycl_sccs) $$ ppr final_inst_ds  )
+         mapM_ orphanRoleAnnotErr (nameEnvElts orphan_roles)
+
+       ; traceRn (text "rnTycl dependency analysis made groups" $$ ppr all_groups)
+       ; return (all_groups, all_fvs) }
+  where
+    mk_group :: (InstDeclFreeVarsMap, RoleAnnotEnv)
+             -> SCC (LTyClDecl Name)
+             -> ( (InstDeclFreeVarsMap, RoleAnnotEnv)
+                , TyClGroup Name )
+    mk_group (inst_map, role_env) scc
+      = ((inst_map', role_env'), group)
+      where
+        tycl_ds              = flattenSCC scc
+        bndrs                = map (tcdName . unLoc) tycl_ds
+        (inst_ds, inst_map') = getInsts      bndrs inst_map
+        (roles,   role_env') = getRoleAnnots bndrs role_env
+        group = TyClGroup { group_tyclds = tycl_ds
+                          , group_roles  = roles
+                          , group_instds = inst_ds }
+
+
+depAnalTyClDecls :: GlobalRdrEnv
+                 -> [(LTyClDecl Name, FreeVars)]
+                 -> [SCC (LTyClDecl Name)]
+-- See Note [Dependency analysis of type, class, and instance decls]
+depAnalTyClDecls rdr_env ds_w_fvs
+  = stronglyConnCompFromEdgedVertices edges
+  where
+    edges = [ (d, tcdName (unLoc d), map (getParent rdr_env) (nameSetElems fvs))
+            | (d, fvs) <- ds_w_fvs ]
+
+toParents :: GlobalRdrEnv -> NameSet -> NameSet
+toParents rdr_env ns
+  = foldNameSet add emptyNameSet ns
+  where
+    add n s = extendNameSet s (getParent rdr_env n)
+
+getParent :: GlobalRdrEnv -> Name -> Name
+getParent rdr_env n
+  = case lookupGRE_Name rdr_env n of
+      gre : _ -> case gre_par gre of
+                   ParentIs  { par_is = p } -> p
+                   FldParent { par_is = p } -> p
+                   _                        -> n
+      _ -> n
+
 
-Note [Extra dependencies from .hs-boot files]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Extra dependencies from .hs-boot files]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider the following case:
 
 A.hs-boot
@@ -1196,24 +1398,16 @@ that live on other packages. Since we don't have mutual dependencies across
 packages, it is safe not to add the dependencies on the .hs-boot stuff to A2.
 
 Hence function Name.thisPackageImport.
-
-See also Note [Grouping of type and class declarations] in TcTyClsDecls.
 -}
 
-
-rnTyClDecls :: [TyClGroup RdrName]
-            -> RnM ([TyClGroup Name], FreeVars)
--- Rename the declarations and do dependency analysis on them
-rnTyClDecls tycl_ds
-  = do { ds_w_fvs       <- mapM (wrapLocFstM rnTyClDecl) (tyClGroupConcat tycl_ds)
-       ; let decl_names = mkNameSet (map (tcdName . unLoc . fst) ds_w_fvs)
-       ; role_annot_env <- rnRoleAnnots decl_names (concatMap group_roles tycl_ds)
-       ; tcg_env        <- getGblEnv
+addBootDeps :: [(LTyClDecl Name, FreeVars)] -> RnM [(LTyClDecl Name, FreeVars)]
+-- See Note [Extra dependencies from .hs-boot files]
+addBootDeps ds_w_fvs
+  = do { tcg_env <- getGblEnv
        ; let this_mod  = tcg_mod tcg_env
              boot_info = tcg_self_boot tcg_env
 
              add_boot_deps :: [(LTyClDecl Name, FreeVars)] -> [(LTyClDecl Name, FreeVars)]
-             -- See Note [Extra dependencies from .hs-boot files]
              add_boot_deps ds_w_fvs
                = case boot_info of
                      SelfBoot { sb_tcs = tcs } | not (isEmptyNameSet tcs)
@@ -1228,33 +1422,141 @@ rnTyClDecls tycl_ds
              has_local_imports fvs
                  = foldNameSet ((||) . nameIsHomePackageImport this_mod)
                                False fvs
+       ; return (add_boot_deps ds_w_fvs) }
+
+
+
+{- ******************************************************
+*                                                       *
+       Role annotations
+*                                                       *
+****************************************************** -}
+
+-- | Renames role annotations, returning them as the values in a NameEnv
+-- and checks for duplicate role annotations.
+-- It is quite convenient to do both of these in the same place.
+-- See also Note [Role annotations in the renamer]
+rnRoleAnnots :: NameSet
+             -> [LRoleAnnotDecl RdrName]
+             -> RnM [LRoleAnnotDecl Name]
+rnRoleAnnots tc_names role_annots
+  = do {  -- Check for duplicates *before* renaming, to avoid
+          -- lumping together all the unboundNames
+         let (no_dups, dup_annots) = removeDups role_annots_cmp role_annots
+             role_annots_cmp (L _ annot1) (L _ annot2)
+               = roleAnnotDeclName annot1 `compare` roleAnnotDeclName annot2
+       ; mapM_ dupRoleAnnotErr dup_annots
+       ; mapM (wrapLocM rn_role_annot1) no_dups }
+  where
+    rn_role_annot1 (RoleAnnotDecl tycon roles)
+      = do {  -- the name is an *occurrence*, but look it up only in the
+              -- decls defined in this group (see #10263)
+             tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt tc_names)
+                                          (text "role annotation")
+                                          tycon
+           ; return $ RoleAnnotDecl tycon' roles }
+
+dupRoleAnnotErr :: [LRoleAnnotDecl RdrName] -> RnM ()
+dupRoleAnnotErr [] = panic "dupRoleAnnotErr"
+dupRoleAnnotErr list
+  = addErrAt loc $
+    hang (text "Duplicate role annotations for" <+>
+          quotes (ppr $ roleAnnotDeclName first_decl) <> colon)
+       2 (vcat $ map pp_role_annot sorted_list)
+    where
+      sorted_list = sortBy cmp_annot list
+      (L loc first_decl : _) = sorted_list
+
+      pp_role_annot (L loc decl) = hang (ppr decl)
+                                      4 (text "-- written at" <+> ppr loc)
+
+      cmp_annot (L loc1 _) (L loc2 _) = loc1 `compare` loc2
+
+orphanRoleAnnotErr :: LRoleAnnotDecl Name -> RnM ()
+orphanRoleAnnotErr (L loc decl)
+  = addErrAt loc $
+    hang (text "Role annotation for a type previously declared:")
+       2 (ppr decl) $$
+    parens (text "The role annotation must be given where" <+>
+            quotes (ppr $ roleAnnotDeclName decl) <+>
+            text "is declared.")
+
+
+{- Note [Role annotations in the renamer]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We must ensure that a type's role annotation is put in the same group as the
+proper type declaration. This is because role annotations are needed during
+type-checking when creating the type's TyCon. So, rnRoleAnnots builds a
+NameEnv (LRoleAnnotDecl Name) that maps a name to a role annotation for that
+type, if any. Then, this map can be used to add the role annotations to the
+groups after dependency analysis.
+
+This process checks for duplicate role annotations, where we must be careful
+to do the check *before* renaming to avoid calling all unbound names duplicates
+of one another.
 
-             ds_w_fvs' = add_boot_deps ds_w_fvs
-
-             sccs :: [SCC (LTyClDecl Name)]
-             sccs = depAnalTyClDecls ds_w_fvs'
-
-             all_fvs = foldr (plusFV . snd) emptyFVs ds_w_fvs'
-
-             raw_groups = map flattenSCC sccs
-             -- See Note [Role annotations in the renamer]
-             (groups, orphan_roles)
-               = foldr (\group (groups_acc, orphans_acc) ->
-                         let names = map (tcdName . unLoc) group
-                             roles = mapMaybe (lookupNameEnv orphans_acc) names
-                             orphans' = delListFromNameEnv orphans_acc names
-                              -- there doesn't seem to be an interface to
-                              -- do the above more efficiently
-                         in ( TyClGroup { group_tyclds = group
-                                        , group_roles  = roles } : groups_acc
-                            , orphans' )
-                       )
-                       ([], role_annot_env)
-                       raw_groups
-
-       ; mapM_ orphanRoleAnnotErr (nameEnvElts orphan_roles)
-       ; traceRn (text "rnTycl"  <+> (ppr ds_w_fvs $$ ppr sccs))
-       ; return (groups, all_fvs) }
+The renaming process, as usual, might identify and report errors for unbound
+names. We exclude the annotations for unbound names in the annotation
+environment to avoid spurious errors for orphaned annotations.
+
+We then (in rnTyClDecls) do a check for orphan role annotations (role
+annotations without an accompanying type decl). The check works by folding
+over components (of type [[Either (TyClDecl Name) (InstDecl Name)]]), selecting
+out the relevant role declarations for each group, as well as diminishing the
+annotation environment. After the fold is complete, anything left over in the
+name environment must be an orphan, and errors are generated.
+
+An earlier version of this algorithm short-cut the orphan check by renaming
+only with names declared in this module. But, this check is insufficient in
+the case of staged module compilation (Template Haskell, GHCi).
+See #8485. With the new lookup process (which includes types declared in other
+modules), we get better error messages, too.
+-}
+
+
+{- ******************************************************
+*                                                       *
+       Dependency info for instances
+*                                                       *
+****************************************************** -}
+
+----------------------------------------------------------
+-- | 'InstDeclFreeVarsMap is an association of an
+--   @InstDecl@ with @FreeVars@. The @FreeVars@ are
+--   the names that are
+--     a) free in the instance declaration
+--     b) bound by this group of type/class/instance decls
+type InstDeclFreeVarsMap = [(LInstDecl Name, FreeVars)]
+
+-- | Construct an @InstDeclFreeVarsMap@ by eliminating any @Name@s from the
+--   @FreeVars@ which are *not* the binders of a @TyClDecl@.
+mkInstDeclFreeVarsMap :: GlobalRdrEnv
+                      -> NameSet
+                      -> [(LInstDecl Name, FreeVars)]
+                      -> InstDeclFreeVarsMap
+mkInstDeclFreeVarsMap rdr_env tycl_bndrs inst_ds_fvs
+  = [ (inst_decl, toParents rdr_env fvs `intersectFVs` tycl_bndrs)
+    | (inst_decl, fvs) <- inst_ds_fvs ]
+
+-- | Get the @LInstDecl@s which have empty @FreeVars@ sets, and the
+--   @InstDeclFreeVarsMap@ with these entries removed.
+getInsts :: [Name] -> InstDeclFreeVarsMap -> ([LInstDecl Name], InstDeclFreeVarsMap)
+getInsts bndrs inst_decl_map
+  = partitionWith pick_me inst_decl_map
+  where
+    pick_me :: (LInstDecl Name, FreeVars)
+            -> Either (LInstDecl Name) (LInstDecl Name, FreeVars)
+    pick_me (decl, fvs)
+      | isEmptyNameSet depleted_fvs = Left decl
+      | otherwise                   = Right (decl, depleted_fvs)
+      where
+        depleted_fvs = delFVs bndrs fvs
+
+{- ******************************************************
+*                                                       *
+         Renaming a type or class declaration
+*                                                       *
+****************************************************** -}
 
 rnTyClDecl :: TyClDecl RdrName
            -> RnM (TyClDecl Name, FreeVars)
@@ -1365,61 +1667,6 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
 rnTySyn :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
 rnTySyn doc rhs = rnLHsType doc rhs
 
--- | Renames role annotations, returning them as the values in a NameEnv
--- and checks for duplicate role annotations.
--- It is quite convenient to do both of these in the same place.
--- See also Note [Role annotations in the renamer]
-rnRoleAnnots :: NameSet  -- ^ of the decls in this group
-             -> [LRoleAnnotDecl RdrName]
-             -> RnM (NameEnv (LRoleAnnotDecl Name))
-rnRoleAnnots decl_names role_annots
-  = do {  -- check for duplicates *before* renaming, to avoid lumping
-          -- together all the unboundNames
-         let (no_dups, dup_annots) = removeDups role_annots_cmp role_annots
-             role_annots_cmp (L _ annot1) (L _ annot2)
-               = roleAnnotDeclName annot1 `compare` roleAnnotDeclName annot2
-       ; mapM_ dupRoleAnnotErr dup_annots
-       ; role_annots' <- mapM (wrapLocM rn_role_annot1) no_dups
-          -- some of the role annots will be unbound; we don't wish
-          -- to include these
-       ; return $ mkNameEnv [ (name, ra)
-                            | ra <- role_annots'
-                            , let name = roleAnnotDeclName (unLoc ra)
-                            , not (isUnboundName name) ] }
-  where
-    rn_role_annot1 (RoleAnnotDecl tycon roles)
-      = do {  -- the name is an *occurrence*, but look it up only in the
-              -- decls defined in this group (see #10263)
-             tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt decl_names)
-                                          (text "role annotation")
-                                          tycon
-           ; return $ RoleAnnotDecl tycon' roles }
-
-dupRoleAnnotErr :: [LRoleAnnotDecl RdrName] -> RnM ()
-dupRoleAnnotErr [] = panic "dupRoleAnnotErr"
-dupRoleAnnotErr list
-  = addErrAt loc $
-    hang (text "Duplicate role annotations for" <+>
-          quotes (ppr $ roleAnnotDeclName first_decl) <> colon)
-       2 (vcat $ map pp_role_annot sorted_list)
-    where
-      sorted_list = sortBy cmp_annot list
-      (L loc first_decl : _) = sorted_list
-
-      pp_role_annot (L loc decl) = hang (ppr decl)
-                                      4 (text "-- written at" <+> ppr loc)
-
-      cmp_annot (L loc1 _) (L loc2 _) = loc1 `compare` loc2
-
-orphanRoleAnnotErr :: LRoleAnnotDecl Name -> RnM ()
-orphanRoleAnnotErr (L loc decl)
-  = addErrAt loc $
-    hang (text "Role annotation for a type previously declared:")
-       2 (ppr decl) $$
-    parens (text "The role annotation must be given where" <+>
-            quotes (ppr $ roleAnnotDeclName decl) <+>
-            text "is declared.")
-
 rnDataDefn :: HsDocContext -> HsDataDefn RdrName
            -> RnM ((HsDataDefn Name, NameSet), FreeVars)
                 -- the NameSet includes all Names free in the kind signature
@@ -1646,84 +1893,12 @@ to cause programs to break unnecessarily (notably HList).  So if there
 are no data constructors we allow h98_style = True
 -}
 
-depAnalTyClDecls :: [(LTyClDecl Name, FreeVars)] -> [SCC (LTyClDecl Name)]
--- See Note [Dependency analysis of type and class decls]
-depAnalTyClDecls ds_w_fvs
-  = stronglyConnCompFromEdgedVertices edges
-  where
-    edges = [ (d, tcdName (unLoc d), map get_parent (nameSetElems fvs))
-            | (d, fvs) <- ds_w_fvs ]
-
-    -- We also need to consider data constructor names since
-    -- they may appear in types because of promotion.
-    get_parent n = lookupNameEnv assoc_env n `orElse` n
-
-    assoc_env :: NameEnv Name   -- Maps a data constructor back
-                                -- to its parent type constructor
-    assoc_env = mkNameEnv $ concat assoc_env_list
-    assoc_env_list = do
-      (L _ d, _) <- ds_w_fvs
-      case d of
-        ClassDecl { tcdLName = L _ cls_name
-                  , tcdATs = ats }
-          -> do L _ (FamilyDecl { fdLName = L _ fam_name }) <- ats
-                return [(fam_name, cls_name)]
-        DataDecl { tcdLName = L _ data_name
-                 , tcdDataDefn = HsDataDefn { dd_cons = cons } }
-          -> do L _ dc <- cons
-                return $ zip (map unLoc $ getConNames dc) (repeat data_name)
-        _ -> []
 
-{-
-Note [Dependency analysis of type and class decls]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We need to do dependency analysis on type and class declarations
-else we get bad error messages.  Consider
-
-     data T f a = MkT f a
-     data S f a = MkS f (T f a)
-
-This has a kind error, but the error message is better if you
-check T first, (fixing its kind) and *then* S.  If you do kind
-inference together, you might get an error reported in S, which
-is jolly confusing.  See Trac #4875
-
-Note [Role annotations in the renamer]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We must ensure that a type's role annotation is put in the same group as the
-proper type declaration. This is because role annotations are needed during
-type-checking when creating the type's TyCon. So, rnRoleAnnots builds a
-NameEnv (LRoleAnnotDecl Name) that maps a name to a role annotation for that
-type, if any. Then, this map can be used to add the role annotations to the
-groups after dependency analysis.
-
-This process checks for duplicate role annotations, where we must be careful
-to do the check *before* renaming to avoid calling all unbound names duplicates
-of one another.
-
-The renaming process, as usual, might identify and report errors for unbound
-names. We exclude the annotations for unbound names in the annotation
-environment to avoid spurious errors for orphaned annotations.
-
-We then (in rnTyClDecls) do a check for orphan role annotations (role
-annotations without an accompanying type decl). The check works by folding
-over raw_groups (of type [[TyClDecl Name]]), selecting out the relevant
-role declarations for each group, as well as diminishing the annotation
-environment. After the fold is complete, anything left over in the name
-environment must be an orphan, and errors are generated.
-
-An earlier version of this algorithm short-cut the orphan check by renaming
-only with names declared in this module. But, this check is insufficient in
-the case of staged module compilation (Template Haskell, GHCi).
-See #8485. With the new lookup process (which includes types declared in other
-modules), we get better error messages, too.
-
-*********************************************************
+{- *****************************************************
 *                                                      *
-\subsection{Support code for type/data declarations}
+     Support code for type/data declarations
 *                                                      *
-*********************************************************
--}
+***************************************************** -}
 
 ---------------
 badAssocRhs :: [Name] -> RnM ()
@@ -1953,9 +2128,13 @@ add gp@(HsGroup {hs_valds  = ts}) l (ValD d) ds
 add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD d) ds
   = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds
 
+-- NB instance declarations go into TyClGroups. We throw them into the first
+-- group, just as we do for the TyClD case. The renamer will go on to group
+-- and order them later.
+add gp@(HsGroup {hs_tyclds = ts})  l (InstD d) ds
+  = addl (gp { hs_tyclds = add_instd (L l d) ts }) ds
+
 -- The rest are routine
-add gp@(HsGroup {hs_instds = ts})  l (InstD d) ds
-  = addl (gp { hs_instds = L l d : ts }) ds
 add gp@(HsGroup {hs_derivds = ts})  l (DerivD d) ds
   = addl (gp { hs_derivds = L l d : ts }) ds
 add gp@(HsGroup {hs_defds  = ts})  l (DefD d) ds
@@ -1974,12 +2153,29 @@ add gp l (DocD d) ds
   = addl (gp { hs_docs = (L l d) : (hs_docs gp) })  ds
 
 add_tycld :: LTyClDecl a -> [TyClGroup a] -> [TyClGroup a]
-add_tycld d []       = [TyClGroup { group_tyclds = [d], group_roles = [] }]
+add_tycld d []       = [TyClGroup { group_tyclds = [d]
+                                  , group_roles = []
+                                  , group_instds = []
+                                  }
+                       ]
 add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss)
   = ds { group_tyclds = d : tyclds } : dss
 
+add_instd :: LInstDecl a -> [TyClGroup a] -> [TyClGroup a]
+add_instd d []       = [TyClGroup { group_tyclds = []
+                                  , group_roles = []
+                                  , group_instds = [d]
+                                  }
+                       ]
+add_instd d (ds@(TyClGroup { group_instds = instds }):dss)
+  = ds { group_instds = d : instds } : dss
+
 add_role_annot :: LRoleAnnotDecl a -> [TyClGroup a] -> [TyClGroup a]
-add_role_annot d [] = [TyClGroup { group_tyclds = [], group_roles = [d] }]
+add_role_annot d [] = [TyClGroup { group_tyclds = []
+                                 , group_roles = [d]
+                                 , group_instds = []
+                                 }
+                      ]
 add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest)
   = tycls { group_roles = d : roles } : rest
 
index 4d20a4a..f46fc46 100644 (file)
@@ -340,11 +340,9 @@ data DerivInfo = DerivInfo { di_rep_tc :: TyCon
                            }
 
 -- | Extract `deriving` clauses of proper data type (skips data families)
-mkDerivInfos :: [TyClGroup Name] -> TcM [DerivInfo]
-mkDerivInfos tycls = concatMapM mk_derivs tycls
+mkDerivInfos :: [LTyClDecl Name] -> TcM [DerivInfo]
+mkDerivInfos decls = concatMapM (mk_deriv . unLoc) decls
   where
-    mk_derivs (TyClGroup { group_tyclds = decls })
-      = concatMapM (mk_deriv . unLoc) decls
 
     mk_deriv decl@(DataDecl { tcdLName = L _ data_name
                             , tcdDataDefn =
@@ -2167,7 +2165,6 @@ genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon
                  , ds_name = dfun_name, ds_cls = clas, ds_loc = loc })
   | Just rhs_ty <- is_newtype   -- See Note [Bindings for Generalised Newtype Deriving]
   = do { inst_spec <- newDerivClsInst theta spec
-       ; traceTc "genInst/is_newtype" (vcat [ppr loc, ppr clas, ppr tvs, ppr tys, ppr rhs_ty])
        ; return ( InstInfo
                     { iSpec   = inst_spec
                     , iBinds  = InstBindings
index bd26e6e..8554796 100644 (file)
@@ -8,7 +8,7 @@ TcInstDecls: Typechecking instance declarations
 
 {-# LANGUAGE CPP #-}
 
-module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where
+module TcInstDcls ( tcInstDecls1, tcInstDeclsDeriv, tcInstDecls2 ) where
 
 #include "HsVersions.h"
 
@@ -51,7 +51,6 @@ import BasicTypes
 import DynFlags
 import ErrUtils
 import FastString
-import HscTypes ( isHsBootOrSig )
 import Id
 import MkId
 import Name
@@ -64,8 +63,6 @@ import qualified GHC.LanguageExtensions as LangExt
 
 import Control.Monad
 import Maybes
-import Data.List  ( partition )
-
 
 
 {-
@@ -361,102 +358,45 @@ Gather up the instance declarations from their various sources
 -}
 
 tcInstDecls1    -- Deal with both source-code and imported instance decls
-   :: [TyClGroup Name]          -- For deriving stuff
-   -> [LInstDecl Name]          -- Source code instance decls
-   -> [LDerivDecl Name]         -- Source code stand-alone deriving decls
+   :: [LInstDecl Name]          -- Source code instance decls
    -> TcM (TcGblEnv,            -- The full inst env
            [InstInfo Name],     -- Source-code instance decls to process;
                                 -- contains all dfuns for this module
-           HsValBinds Name)     -- Supporting bindings for derived instances
-
-tcInstDecls1 tycl_decls inst_decls deriv_decls
-  = checkNoErrs $
-    do {    -- Stop if addInstInfos etc discovers any errors
-            -- (they recover, so that we get more than one error each
-            -- round)
+           [DerivInfo])         -- From data family instances
 
-            -- Do class and family instance declarations
+tcInstDecls1 inst_decls
+  = do {    -- Do class and family instance declarations
        ; stuff <- mapAndRecoverM tcLocalInstDecl inst_decls
-       ; let (local_infos_s, fam_insts_s, datafam_deriv_infos) = unzip3 stuff
-             fam_insts    = concat fam_insts_s
-             local_infos' = concat local_infos_s
-             -- Handwritten instances of the poly-kinded Typeable class are
-             -- forbidden, so we handle those separately
-             (typeable_instances, local_infos)
-                = partition bad_typeable_instance local_infos'
-
-       ; addClsInsts local_infos $
-         addFamInsts fam_insts   $
-    do {    -- Compute instances from "deriving" clauses;
-            -- This stuff computes a context for the derived instance
-            -- decl, so it needs to know about all the instances possible
-            -- NB: class instance declarations can contain derivings as
-            --     part of associated data type declarations
-         failIfErrsM    -- If the addInsts stuff gave any errors, don't
-                        -- try the deriving stuff, because that may give
-                        -- more errors still
-
-       ; traceTc "tcDeriving" Outputable.empty
-       ; th_stage <- getStage   -- See Note [Deriving inside TH brackets ]
-       ; (gbl_env, deriv_inst_info, deriv_binds)
-              <- if isBrackStage th_stage
-                 then do { gbl_env <- getGblEnv
-                         ; return (gbl_env, emptyBag, emptyValBindsOut) }
-                 else do { data_deriv_infos <- mkDerivInfos tycl_decls
-                         ; let deriv_infos = concat datafam_deriv_infos ++
-                                             data_deriv_infos
-                         ; tcDeriving deriv_infos deriv_decls }
-
-       -- Fail if there are any handwritten instance of poly-kinded Typeable
-       ; mapM_ typeable_err typeable_instances
-
-       -- Check that if the module is compiled with -XSafe, there are no
-       -- hand written instances of old Typeable as then unsafe casts could be
-       -- performed. Derived instances are OK.
-       ; dflags <- getDynFlags
-       ; when (safeLanguageOn dflags) $ forM_ local_infos $ \x -> case x of
-             _ | genInstCheck x -> addErrAt (getSrcSpan $ iSpec x) (genInstErr x)
-             _ -> return ()
-
-       -- As above but for Safe Inference mode.
-       ; when (safeInferOn dflags) $ forM_ local_infos $ \x -> case x of
-             _ | genInstCheck x -> recordUnsafeInfer emptyBag
-             _ -> return ()
 
-       ; return ( gbl_env
-                , bagToList deriv_inst_info ++ local_infos
-                , deriv_binds )
-    }}
-  where
-    -- Separate the Typeable instances from the rest
-    bad_typeable_instance i
-      = typeableClassName == is_cls_nm (iSpec i)
+       ; let (local_infos_s, fam_insts_s, datafam_deriv_infos) = unzip3 stuff
+             fam_insts   = concat fam_insts_s
+             local_infos = concat local_infos_s
 
-    -- Check for hand-written Generic instances (disallowed in Safe Haskell)
-    genInstCheck ty = is_cls_nm (iSpec ty) `elem` genericClassNames
-    genInstErr i = hang (text ("Generic instances can only be "
-                            ++ "derived in Safe Haskell.") $+$
-                         text "Replace the following instance:")
-                     2 (pprInstanceHdr (iSpec i))
+       ; gbl_env <- addClsInsts local_infos $
+                    addFamInsts fam_insts   $
+                    getGblEnv
 
-    -- Report an error or a warning for a Typeable instances.
-    -- If we are working on an .hs-boot file, we just report a warning,
-    -- and ignore the instance.  We do this, to give users a chance to fix
-    -- their code.
-    typeable_err i =
-      setSrcSpan (getSrcSpan (iSpec i)) $
-        do env <- getGblEnv
-           if isHsBootOrSig (tcg_src env)
-             then
-               do warn <- woptM Opt_WarnDerivingTypeable
-                  when warn $ addWarnTc (Reason Opt_WarnDerivingTypeable) $ vcat
-                    [ ppTypeable <+> text "instances in .hs-boot files are ignored"
-                    , text "This warning will become an error in future versions of the compiler"
-                    ]
-             else addErrTc $ text "Class" <+> ppTypeable
-                             <+> text "does not support user-specified instances"
-    ppTypeable :: SDoc
-    ppTypeable = quotes (ppr typeableClassName)
+       ; return ( gbl_env
+                , local_infos
+                , concat datafam_deriv_infos ) }
+
+-- | Use DerivInfo for data family instances (produced by tcInstDecls1),
+--   datatype declarations (TyClDecl), and standalone deriving declarations
+--   (DerivDecl) to check and process all derived class instances.
+tcInstDeclsDeriv
+  :: [DerivInfo]
+  -> [LTyClDecl Name]
+  -> [LDerivDecl Name]
+  -> TcM (TcGblEnv, [InstInfo Name], HsValBinds Name)
+tcInstDeclsDeriv datafam_deriv_infos tyclds derivds
+  = do th_stage <- getStage -- See Note [Deriving inside TH brackets]
+       if isBrackStage th_stage
+       then do { gbl_env <- getGblEnv
+               ; return (gbl_env, bagToList emptyBag, emptyValBindsOut) }
+       else do { data_deriv_infos <- mkDerivInfos tyclds
+               ; let deriv_infos = datafam_deriv_infos ++ data_deriv_infos
+               ; (tcg_env, info_bag, valbinds) <- tcDeriving deriv_infos derivds
+               ; return (tcg_env, bagToList info_bag, valbinds) }
 
 addClsInsts :: [InstInfo Name] -> TcM a -> TcM a
 addClsInsts infos thing_inside
@@ -517,18 +457,14 @@ tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl }))
 
 tcClsInstDecl :: LClsInstDecl Name
               -> TcM ([InstInfo Name], [FamInst], [DerivInfo])
--- the returned DerivInfos are for any associated data families
+-- The returned DerivInfos are for any associated data families
 tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
                                   , cid_sigs = uprags, cid_tyfam_insts = ats
                                   , cid_overlap_mode = overlap_mode
                                   , cid_datafam_insts = adts }))
   = setSrcSpan loc                      $
     addErrCtxt (instDeclCtxt1 poly_ty)  $
-    do  { is_boot <- tcIsHsBootOrSig
-        ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
-                  badBootDeclErr
-
-        ; (tyvars, theta, clas, inst_tys) <- tcHsClsInstType InstDeclCtxt poly_ty
+    do  { (tyvars, theta, clas, inst_tys) <- tcHsClsInstType InstDeclCtxt poly_ty
         ; let mini_env   = mkVarEnv (classTyVars clas `zip` inst_tys)
               mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env
               mb_info    = Just (clas, tyvars, mini_env)
@@ -557,6 +493,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
 
         ; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name tyvars theta
                               clas inst_tys
+
         ; let inst_info = InstInfo { iSpec  = ispec
                                    , iBinds = InstBindings
                                      { ib_binds = binds
@@ -565,10 +502,48 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
                                      , ib_extensions = []
                                      , ib_derived = False } }
 
+        ; doClsInstErrorChecks inst_info
+
         ; return ( [inst_info], tyfam_insts0 ++ concat tyfam_insts1 ++ datafam_insts
                  , deriv_infos ) }
 
 
+doClsInstErrorChecks :: InstInfo Name -> TcM ()
+doClsInstErrorChecks inst_info
+ = do { traceTc "doClsInstErrorChecks" (ppr ispec)
+      ; dflags <- getDynFlags
+      ; is_boot <- tcIsHsBootOrSig
+
+         -- In hs-boot files there should be no bindings
+      ; failIfTc (is_boot && not no_binds) badBootDeclErr
+
+         -- Handwritten instances of the poly-kinded Typeable
+         -- class are always forbidden
+      ; failIfTc (clas_nm == typeableClassName) typeable_err
+
+         -- Check for hand-written Generic instances (disallowed in Safe Haskell)
+      ; when (clas_nm `elem` genericClassNames) $
+        do { failIfTc (safeLanguageOn dflags) gen_inst_err
+           ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) }
+  }
+  where
+    ispec    = iSpec inst_info
+    binds    = iBinds inst_info
+    no_binds = isEmptyLHsBinds (ib_binds binds) && null (ib_pragmas binds)
+    clas_nm  = is_cls_nm ispec
+
+    gen_inst_err = hang (text ("Generic instances can only be "
+                            ++ "derived in Safe Haskell.") $+$
+                         text "Replace the following instance:")
+                      2 (pprInstanceHdr ispec)
+
+    -- Report an error or a warning for a Typeable instances.
+    -- If we are working on an .hs-boot file, we just report a warning,
+    -- and ignore the instance.  We do this, to give users a chance to fix
+    -- their code.
+    typeable_err = text "Class" <+> quotes (ppr clas_nm)
+                    <+> text "does not support user-specified instances"
+
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/typecheck/TcInstDcls.hs-boot b/compiler/typecheck/TcInstDcls.hs-boot
new file mode 100644 (file)
index 0000000..16db4e8
--- /dev/null
@@ -0,0 +1,16 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+-}
+
+module TcInstDcls ( tcInstDecls1 ) where
+
+import HsSyn
+import TcRnTypes
+import TcEnv( InstInfo )
+import TcDeriv
+import Name
+
+-- We need this because of the mutual recursion
+-- between TcTyClsDecls and TcInstDcls
+tcInstDecls1 :: [LInstDecl Name] -> TcM (TcGblEnv, [InstInfo Name], [DerivInfo])
index c166ab7..e21d614 100644 (file)
@@ -472,21 +472,21 @@ tcRnImports hsc_env import_decls
 tcRnSrcDecls :: Bool  -- False => no 'module M(..) where' header at all
              -> [LHsDecl RdrName]               -- Declarations
              -> TcM TcGblEnv
-        -- Returns the variables free in the decls
-        -- Reason: solely to report unused imports and bindings
 tcRnSrcDecls explicit_mod_hdr decls
  = do { -- Do all the declarations
       ; ((tcg_env, tcl_env), lie) <- captureConstraints $
               do { (tcg_env, tcl_env) <- tc_rn_src_decls decls ;
+
+                   -- Check for the 'main' declaration
+                   -- Must do this inside the captureConstraints
                  ; tcg_env <- setEnvs (tcg_env, tcl_env) $
                               checkMain explicit_mod_hdr
                  ; return (tcg_env, tcl_env) }
-      ; setEnvs (tcg_env, tcl_env) $ do {
 
         -- Emit Typeable bindings
       ; tcg_env <- setGblEnv tcg_env mkTypeableBinds
 
-      ; setGblEnv tcg_env $ do {
+      ; setEnvs (tcg_env, tcl_env) $ do {
 
 #ifdef GHCI
       ; finishTH
@@ -495,12 +495,7 @@ tcRnSrcDecls explicit_mod_hdr decls
         -- wanted constraints from static forms
       ; stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef
 
-             --         Finish simplifying class constraints
-             --
-             -- simplifyTop deals with constant or ambiguous InstIds.
-             -- How could there be ambiguous ones?  They can only arise if a
-             -- top-level decl falls under the monomorphism restriction
-             -- and no subsequent decl instantiates its type.
+             --         Simplify constraints
              --
              -- We do this after checkMain, so that we use the type info
              -- that checkMain adds
@@ -546,7 +541,7 @@ tcRnSrcDecls explicit_mod_hdr decls
 
       ; setGlobalTypeEnv tcg_env' final_type_env
 
-   } } }
+   } }
 
 tc_rn_src_decls :: [LHsDecl RdrName]
                 -> TcM (TcGblEnv, TcLclEnv)
@@ -640,7 +635,6 @@ tcRnHsBootDecls hsc_src decls
 
                 -- Rename the declarations
         ; (tcg_env, HsGroup { hs_tyclds = tycl_decls
-                            , hs_instds = inst_decls
                             , hs_derivds = deriv_decls
                             , hs_fords  = for_decls
                             , hs_defds  = def_decls
@@ -666,7 +660,7 @@ tcRnHsBootDecls hsc_src decls
                 -- Typecheck type/class/instance decls
         ; traceTc "Tc2 (boot)" empty
         ; (tcg_env, inst_infos, _deriv_binds)
-             <- tcTyClsInstDecls tycl_decls inst_decls deriv_decls val_binds
+             <- tcTyClsInstDecls tycl_decls deriv_decls val_binds
         ; setGblEnv tcg_env     $ do {
 
                 -- Typecheck value declarations
@@ -1143,7 +1137,6 @@ rnTopSrcDecls group
 
 tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
 tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
-                         hs_instds = inst_decls,
                          hs_derivds = deriv_decls,
                          hs_fords  = foreign_decls,
                          hs_defds  = default_decls,
@@ -1159,7 +1152,8 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
                 -- and import the supporting declarations
         traceTc "Tc3" empty ;
         (tcg_env, inst_infos, ValBindsOut deriv_binds deriv_sigs)
-            <- tcTyClsInstDecls tycl_decls inst_decls deriv_decls val_binds ;
+            <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ;
+
         setGblEnv tcg_env       $ do {
 
                 -- Generate Applicative/Monad proposal (AMP) warnings
@@ -1193,7 +1187,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
                 -- Second pass over class and instance declarations,
                 -- now using the kind-checked decls
         traceTc "Tc6" empty ;
-        inst_binds <- tcInstDecls2 (tyClGroupConcat tycl_decls) inst_infos ;
+        inst_binds <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls) inst_infos ;
 
                 -- Foreign exports
         traceTc "Tc7" empty ;
@@ -1427,7 +1421,6 @@ tcMissingParentClassWarn warnFlag isName shouldName
 
 ---------------------------
 tcTyClsInstDecls :: [TyClGroup Name]
-                 -> [LInstDecl Name]
                  -> [LDerivDecl Name]
                  -> [(RecFlag, LHsBinds Name)]
                  -> TcM (TcGblEnv,            -- The full inst env
@@ -1435,13 +1428,26 @@ tcTyClsInstDecls :: [TyClGroup Name]
                                               -- contains all dfuns for this module
                           HsValBinds Name)    -- Supporting bindings for derived instances
 
-tcTyClsInstDecls tycl_decls inst_decls deriv_decls binds
- = tcAddDataFamConPlaceholders inst_decls           $
+tcTyClsInstDecls tycl_decls deriv_decls binds
+ = tcAddDataFamConPlaceholders (tycl_decls >>= group_instds) $
    tcAddPatSynPlaceholders (getPatSynBinds binds) $
-   do { tcg_env <- tcTyAndClassDecls tycl_decls ;
-      ; setGblEnv tcg_env $
-        tcInstDecls1 tycl_decls inst_decls deriv_decls }
-
+   do { (tcg_env, inst_info, datafam_deriv_info)
+          <- tcTyAndClassDecls tycl_decls ;
+      ; setGblEnv tcg_env $ do {
+          -- With the @TyClDecl@s and @InstDecl@s checked we're ready to
+          -- process the deriving clauses, including data family deriving
+          -- clauses discovered in @tcTyAndClassDecls@.
+          --
+          -- Careful to quit now in case there were instance errors, so that
+          -- the deriving errors don't pile up as well.
+          ; failIfErrsM
+          ; let tyclds = tycl_decls >>= group_tyclds
+          ; (tcg_env', inst_info', val_binds)
+              <- tcInstDeclsDeriv datafam_deriv_info tyclds deriv_decls
+          ; setGblEnv tcg_env' $ do {
+                failIfErrsM
+              ; pure (tcg_env', inst_info' ++ inst_info, val_binds)
+      }}}
 
 {- *********************************************************************
 *                                                                      *
index 4d664f4..afb7b64 100644 (file)
@@ -30,11 +30,14 @@ import TcValidity
 import TcHsSyn
 import TcTyDecls
 import TcClassDcl
+import {-# SOURCE #-} TcInstDcls
+import TcDeriv (DerivInfo)
 import TcUnify
 import TcHsType
 import TcMType
 import TysWiredIn ( unitTy )
 import TcType
+import RnEnv( RoleAnnotEnv, mkRoleAnnotEnv, lookupRoleAnnot )
 import FamInst
 import FamInstEnv
 import Coercion
@@ -105,25 +108,72 @@ Thus, we take two passes over the resulting tycons, first checking for general
 validity and then checking for valid role annotations.
 -}
 
-tcTyAndClassDecls :: [TyClGroup Name]   -- Mutually-recursive groups in dependency order
-                  -> TcM TcGblEnv       -- Input env extended by types and classes
-                                        -- and their implicit Ids,DataCons
+tcTyAndClassDecls :: [TyClGroup Name]       -- Mutually-recursive groups in
+                                            -- dependency order
+                  -> TcM ( TcGblEnv         -- Input env extended by types and
+                                            -- classes
+                                            -- and their implicit Ids,DataCons
+                         , [InstInfo Name]  -- Source-code instance decls info
+                         , [DerivInfo]      -- data family deriving info
+                         )
 -- Fails if there are any errors
 tcTyAndClassDecls tyclds_s
-  = checkNoErrs $       -- The code recovers internally, but if anything gave rise to
-                        -- an error we'd better stop now, to avoid a cascade
-    fold_env tyclds_s   -- Type check each group in dependency order folding the global env
+  -- The code recovers internally, but if anything gave rise to
+  -- an error we'd better stop now, to avoid a cascade
+  -- Type check each group in dependency order folding the global env
+  = checkNoErrs $ fold_env [] [] tyclds_s
   where
-    fold_env :: [TyClGroup Name] -> TcM TcGblEnv
-    fold_env [] = getGblEnv
-    fold_env (tyclds:tyclds_s)
-      = do { tcg_env <- tcTyClGroup tyclds
-           ; setGblEnv tcg_env $ fold_env tyclds_s }
-             -- remaining groups are typecheck in the extended global env
-
-tcTyClGroup :: TyClGroup Name -> TcM TcGblEnv
--- Typecheck one strongly-connected component of type and class decls
-tcTyClGroup tyclds
+    fold_env :: [InstInfo Name]
+             -> [DerivInfo]
+             -> [TyClGroup Name]
+             -> TcM (TcGblEnv, [InstInfo Name], [DerivInfo])
+    fold_env inst_info deriv_info []
+      = do { gbl_env <- getGblEnv
+           ; return (gbl_env, inst_info, deriv_info) }
+    fold_env inst_info deriv_info (tyclds:tyclds_s)
+      = do { (tcg_env, inst_info', deriv_info') <- tcTyClGroup tyclds
+           ; setGblEnv tcg_env $
+               -- remaining groups are typechecked in the extended global env.
+             fold_env (inst_info' ++ inst_info)
+                      (deriv_info' ++ deriv_info)
+                      tyclds_s }
+
+tcTyClGroup :: TyClGroup Name
+            -> TcM (TcGblEnv, [InstInfo Name], [DerivInfo])
+-- Typecheck one strongly-connected component of type, class, and instance decls
+tcTyClGroup (TyClGroup { group_tyclds = tyclds
+                       , group_roles  = roles
+                       , group_instds = instds })
+  = do { let role_annots = mkRoleAnnotEnv roles
+
+           -- Step 1: Typecheck the type/class declarations
+       ; tyclss <- tcTyClDecls tyclds role_annots
+
+           -- Step 2: Perform the validity check on those types/classes
+           -- We can do this now because we are done with the recursive knot
+           -- Do it before Step 3 (adding implicit things) because the latter
+           -- expects well-formed TyCons
+       ; traceTc "Starting validity check" (ppr tyclss)
+       ; tyclss <- mapM checkValidTyCl tyclss
+       ; traceTc "Done validity check" (ppr tyclss)
+       ; mapM_ (recoverM (return ()) . checkValidRoleAnnots role_annots) tyclss
+           -- See Note [Check role annotations in a second pass]
+
+           -- Step 3: Add the implicit things;
+           -- we want them in the environment because
+           -- they may be mentioned in interface files
+       ; tcExtendTyConEnv tyclss $
+    do { gbl_env <- tcAddImplicits tyclss
+       ; setGblEnv gbl_env $
+    do {
+            -- Step 4: check instance declarations
+       ; (gbl_env, inst_info, datafam_deriv_info) <- tcInstDecls1 instds
+
+       ; return (gbl_env, inst_info, datafam_deriv_info) } } }
+
+
+tcTyClDecls :: [LTyClDecl Name] -> RoleAnnotEnv -> TcM [TyCon]
+tcTyClDecls tyclds role_annots
   = do {    -- Step 1: kind-check this group and returns the final
             -- (possibly-polymorphic) kind of each TyCon and Class
             -- See Note [Kind checking for type and class decls]
@@ -132,9 +182,7 @@ tcTyClGroup tyclds
 
             -- Step 2: type-check all groups together, returning
             -- the final TyCons and Classes
-       ; let role_annots = extractRoleAnnots tyclds
-             decls = group_tyclds tyclds
-       ; tyclss <- fixM $ \ ~rec_tyclss -> do
+       ; fixM $ \ ~rec_tyclss -> do
            { is_boot   <- tcIsHsBootOrSig
            ; self_boot <- tcSelfBootInfo
            ; let rec_flags = calcRecFlags self_boot is_boot
@@ -152,23 +200,8 @@ tcTyClGroup tyclds
              tcExtendKindEnv2 (map mkTcTyConPair tc_tycons)              $
 
                  -- Kind and type check declarations for this group
-             mapM (tcTyClDecl rec_flags) decls }
-
-           -- Step 3: Perform the validity check
-           -- We can do this now because we are done with the recursive knot
-           -- Do it before Step 4 (adding implicit things) because the latter
-           -- expects well-formed TyCons
-       ; traceTc "Starting validity check" (ppr tyclss)
-       ; tyclss <- mapM checkValidTyCl tyclss
-       ; traceTc "Done validity check" (ppr tyclss)
-       ; mapM_ (recoverM (return ()) . checkValidRoleAnnots role_annots) tyclss
-           -- See Note [Check role annotations in a second pass]
-
-           -- Step 4: Add the implicit things;
-           -- we want them in the environment because
-           -- they may be mentioned in interface files
-       ; tcExtendTyConEnv tyclss $
-         tcAddImplicits tyclss }
+               mapM (tcTyClDecl rec_flags) tyclds
+           } }
   where
     ppr_tc_tycon tc = parens (sep [ ppr (tyConName tc) <> comma
                                   , ppr (tyConBinders tc) <> comma
@@ -264,13 +297,13 @@ See also Note [Kind checking recursive type and class declarations]
 
 -}
 
-kcTyClGroup :: TyClGroup Name -> TcM [TcTyCon]
+kcTyClGroup :: [LTyClDecl Name] -> TcM [TcTyCon]
 -- Kind check this group, kind generalize, and return the resulting local env
 -- This bindds the TyCons and Classes of the group, but not the DataCons
 -- See Note [Kind checking for type and class decls]
 -- Third return value is Nothing if the tycon be unsaturated; otherwise,
 -- the arity
-kcTyClGroup (TyClGroup { group_tyclds = decls })
+kcTyClGroup decls
   = do  { mod <- getModule
         ; traceTc "kcTyClGroup" (text "module" <+> ppr mod $$ vcat (map ppr decls))
 
@@ -2023,21 +2056,41 @@ checkValidTyCl :: TyCon -> TcM TyCon
 checkValidTyCl tc
   = setSrcSpan (getSrcSpan tc) $
     addTyConCtxt tc $
-    recoverM (do { traceTc "Aborted validity for tycon" (ppr tc)
-                 ; return (makeTyConAbstract tc) })
+    recoverM recovery_code
              (do { traceTc "Starting validity for tycon" (ppr tc)
                  ; checkValidTyCon tc
                  ; traceTc "Done validity for tycon" (ppr tc)
                  ; return tc })
-    -- We recover, which allows us to report multiple validity errors
-    -- In the failure case we return a TyCon of the right kind, but
-    -- with no interesting behaviour (makeTyConAbstract). Why?
-    -- Suppose we have
-    --    type T a = Fun
-    -- where Fun is a type family of arity 1.  The RHS is invalid, but we
-    -- want to go on checking validity of subsequent type declarations.
-    -- So we replace T with an abstract TyCon which will do no harm.
-    -- See indexed-types/should_fail/BadSock ande Trac #10896
+  where
+    recovery_code -- See Note [Recover from validity error]
+      = do { traceTc "Aborted validity for tycon" (ppr tc)
+           ; return fake_tc }
+    fake_tc | isFamilyTyCon tc || isTypeSynonymTyCon tc
+            = makeTyConAbstract tc
+            | otherwise
+            = tc
+
+{- Note [Recover from validity error]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We recover from a validity error in a type or class, which allows us
+to report multiple validity errors. In the failure case we return a
+TyCon of the right kind, but with no interesting behaviour
+(makeTyConAbstract). Why?  Suppose we have
+   type T a = Fun
+where Fun is a type family of arity 1.  The RHS is invalid, but we
+want to go on checking validity of subsequent type declarations.
+So we replace T with an abstract TyCon which will do no harm.
+See indexed-types/should_fail/BadSock and Trac #10896
+
+Painfully, though, we *don't* want to do this for classes.
+Consider tcfail041:
+   class (?x::Int) => C a where ...
+   instance C Int
+The class is invalid because of the superclass constraint.  But
+we still want it to look like a /class/, else the instance bleats
+that the instance is mal-formed because it hasn't got a class in
+the head.
+-}
 
 -------------------------
 -- For data types declared with record syntax, we require
@@ -2060,7 +2113,8 @@ checkValidTyCon tc
   = return ()
 
   | otherwise
-  = do { checkValidTyConTyVars tc
+  = do { traceTc "checkValidTyCon" (ppr tc $$ ppr (tyConClass_maybe tc))
+       ; checkValidTyConTyVars tc
        ; if | Just cl <- tyConClass_maybe tc
               -> checkValidClass cl
 
@@ -2460,7 +2514,7 @@ This fixes Trac #9415, #9739
 ************************************************************************
 -}
 
-checkValidRoleAnnots :: RoleAnnots -> TyCon -> TcM ()
+checkValidRoleAnnots :: RoleAnnotEnv -> TyCon -> TcM ()
 checkValidRoleAnnots role_annots tc
   | isTypeSynonymTyCon tc = check_no_roles
   | isFamilyTyCon tc      = check_no_roles
@@ -2476,7 +2530,7 @@ checkValidRoleAnnots role_annots tc
     (vis_roles, vis_vars)  = unzip $ snd $
                              partitionInvisibles tc (mkTyVarTy . snd) $
                              zip roles tyvars
-    role_annot_decl_maybe  = lookupRoleAnnots role_annots name
+    role_annot_decl_maybe  = lookupRoleAnnot role_annots name
 
     check_roles
       = whenIsJust role_annot_decl_maybe $
index 7f5b025..6579b5f 100644 (file)
@@ -16,9 +16,6 @@ module TcTyDecls(
         calcSynCycles,
         checkClassCycles,
 
-        -- * Roles
-        RoleAnnots, extractRoleAnnots, emptyRoleAnnots, lookupRoleAnnots,
-
         -- * Implicits
         tcAddImplicits,
 
@@ -31,6 +28,7 @@ module TcTyDecls(
 import TcRnMonad
 import TcEnv
 import TcBinds( tcRecSelBinds )
+import RnEnv( RoleAnnotEnv, lookupRoleAnnot )
 import TyCoRep( Type(..), TyBinder(..), delBinderVar )
 import TcType
 import TysWiredIn( unitTy )
@@ -363,7 +361,7 @@ data RecTyInfo = RTI { rti_roles      :: Name -> [Role]
                      , rti_is_rec     :: Name -> RecFlag }
 
 calcRecFlags :: SelfBootInfo -> Bool  -- hs-boot file?
-             -> RoleAnnots -> [TyCon] -> RecTyInfo
+             -> RoleAnnotEnv -> [TyCon] -> RecTyInfo
 -- The 'boot_names' are the things declared in M.hi-boot, if M is the current module.
 -- Any type constructors in boot_names are automatically considered loop breakers
 -- Recursion of newtypes/data types can happen via
@@ -460,27 +458,6 @@ findLoopBreakers deps
 {-
 ************************************************************************
 *                                                                      *
-        Role annotations
-*                                                                      *
-************************************************************************
--}
-
-type RoleAnnots = NameEnv (LRoleAnnotDecl Name)
-
-extractRoleAnnots :: TyClGroup Name -> RoleAnnots
-extractRoleAnnots (TyClGroup { group_roles = roles })
-  = mkNameEnv [ (tycon, role_annot)
-              | role_annot@(L _ (RoleAnnotDecl (L _ tycon) _)) <- roles ]
-
-emptyRoleAnnots :: RoleAnnots
-emptyRoleAnnots = emptyNameEnv
-
-lookupRoleAnnots :: RoleAnnots -> Name -> Maybe (LRoleAnnotDecl Name)
-lookupRoleAnnots = lookupNameEnv
-
-{-
-************************************************************************
-*                                                                      *
         Role inference
 *                                                                      *
 ************************************************************************
@@ -588,12 +565,12 @@ we want to totally ignore coercions when doing role inference. This includes omi
 any type variables that appear in nominal positions but only within coercions.
 -}
 
-type RoleEnv    = NameEnv [Role]        -- from tycon names to roles
+type RoleEnv = NameEnv [Role]        -- from tycon names to roles
 
 -- This, and any of the functions it calls, must *not* look at the roles
 -- field of a tycon we are inferring roles about!
 -- See Note [Role inference]
-inferRoles :: Bool -> RoleAnnots -> [TyCon] -> Name -> [Role]
+inferRoles :: Bool -> RoleAnnotEnv -> [TyCon] -> Name -> [Role]
 inferRoles is_boot annots tycons
   = let role_env  = initialRoleEnv is_boot annots tycons
         role_env' = irGroup role_env tycons in
@@ -601,11 +578,11 @@ inferRoles is_boot annots tycons
       Just roles -> roles
       Nothing    -> pprPanic "inferRoles" (ppr name)
 
-initialRoleEnv :: Bool -> RoleAnnots -> [TyCon] -> RoleEnv
+initialRoleEnv :: Bool -> RoleAnnotEnv -> [TyCon] -> RoleEnv
 initialRoleEnv is_boot annots = extendNameEnvList emptyNameEnv .
                                 map (initialRoleEnv1 is_boot annots)
 
-initialRoleEnv1 :: Bool -> RoleAnnots -> TyCon -> (Name, [Role])
+initialRoleEnv1 :: Bool -> RoleAnnotEnv -> TyCon -> (Name, [Role])
 initialRoleEnv1 is_boot annots_env tc
   | isFamilyTyCon tc      = (name, map (const Nominal) bndrs)
   | isAlgTyCon tc         = (name, default_roles)
@@ -619,7 +596,7 @@ initialRoleEnv1 is_boot annots_env tc
           -- if the number of annotations in the role annotation decl
           -- is wrong, just ignore it. We check this in the validity check.
         role_annots
-          = case lookupNameEnv annots_env name of
+          = case lookupRoleAnnot annots_env name of
               Just (L _ (RoleAnnotDecl _ annots))
                 | annots `lengthIs` num_exps -> map unLoc annots
               _                              -> replicate num_exps Nothing
index 36425e4..a98f775 100644 (file)
@@ -1,3 +1,5 @@
 
-T9687.hs:4:10: error:
-    Class ‘Typeable’ does not support user-specified instances
+T9687.hs:4:1: error:
+    • Class ‘Typeable’ does not support user-specified instances
+    • In the instance declaration for
+        ‘Typeable (a, b, c, d, e, f, g, h)’
index cd094df..8e46f1d 100644 (file)
@@ -14,7 +14,6 @@ infixl 9 !,\\
 type role Map nominal representational
 data Map k a
 
-instance Typeable Map
 instance Functor (Map k)
 instance Foldable (Map k)
 instance Traversable (Map k)
index d319bd6..f76feb6 100644 (file)
@@ -1,56 +1,56 @@
-type family A a b :: *         -- Defined at T4175.hs:7:1\r
-type instance A (B a) b = ()   -- Defined at T4175.hs:10:15\r
-type instance A (Maybe a) a = a        -- Defined at T4175.hs:9:15\r
-type instance A Int Int = ()   -- Defined at T4175.hs:8:15\r
-data family B a        -- Defined at T4175.hs:12:1\r
-instance G B -- Defined at T4175.hs:34:10\r
-data instance B () = MkB       -- Defined at T4175.hs:13:15\r
-type instance A (B a) b = ()   -- Defined at T4175.hs:10:15\r
-class C a where\r
-  type family D a b :: *\r
-       -- Defined at T4175.hs:16:5\r
-type instance D () a = Bool    -- Defined at T4175.hs:22:10\r
-type instance D Int b = String         -- Defined at T4175.hs:19:10\r
-type family E a :: *\r
-  where\r
-      E () = Bool\r
-      E Int = String\r
-       -- Defined at T4175.hs:24:1\r
-data () = ()   -- Defined in ‘GHC.Tuple’\r
-instance C () -- Defined at T4175.hs:21:10\r
-instance Bounded () -- Defined in ‘GHC.Enum’\r
-instance Enum () -- Defined in ‘GHC.Enum’\r
-instance Eq () -- Defined in ‘GHC.Classes’\r
-instance Ord () -- Defined in ‘GHC.Classes’\r
-instance Read () -- Defined in ‘GHC.Read’\r
-instance Show () -- Defined in ‘GHC.Show’\r
-instance Monoid () -- Defined in ‘GHC.Base’\r
-type instance D () a = Bool    -- Defined at T4175.hs:22:10\r
-data instance B () = MkB       -- Defined at T4175.hs:13:15\r
-data Maybe a = Nothing | Just a        -- Defined in ‘GHC.Base’\r
-instance Eq a => Eq (Maybe a) -- Defined in ‘GHC.Base’\r
-instance Monad Maybe -- Defined in ‘GHC.Base’\r
-instance Functor Maybe -- Defined in ‘GHC.Base’\r
-instance Ord a => Ord (Maybe a) -- Defined in ‘GHC.Base’\r
-instance Read a => Read (Maybe a) -- Defined in ‘GHC.Read’\r
-instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’\r
-instance Applicative Maybe -- Defined in ‘GHC.Base’\r
-instance Foldable Maybe -- Defined in ‘Data.Foldable’\r
-instance Traversable Maybe -- Defined in ‘Data.Traversable’\r
-instance Monoid a => Monoid (Maybe a) -- Defined in ‘GHC.Base’\r
-type instance A (Maybe a) a = a        -- Defined at T4175.hs:9:15\r
-data Int = I# Int#     -- Defined in ‘GHC.Types’\r
-instance C Int -- Defined at T4175.hs:18:10\r
-instance Bounded Int -- Defined in ‘GHC.Enum’\r
-instance Enum Int -- Defined in ‘GHC.Enum’\r
-instance Eq Int -- Defined in ‘GHC.Classes’\r
-instance Integral Int -- Defined in ‘GHC.Real’\r
-instance Num Int -- Defined in ‘GHC.Num’\r
-instance Ord Int -- Defined in ‘GHC.Classes’\r
-instance Read Int -- Defined in ‘GHC.Read’\r
-instance Real Int -- Defined in ‘GHC.Real’\r
-instance Show Int -- Defined in ‘GHC.Show’\r
-type instance D Int b = String         -- Defined at T4175.hs:19:10\r
-type instance A Int Int = ()   -- Defined at T4175.hs:8:15\r
-class Z a      -- Defined at T4175.hs:28:1\r
-instance F (Z a) -- Defined at T4175.hs:31:10\r
+type family A a b :: *         -- Defined at T4175.hs:7:1
+type instance A (Maybe a) a = a        -- Defined at T4175.hs:9:15
+type instance A Int Int = ()   -- Defined at T4175.hs:8:15
+type instance A (B a) b = ()   -- Defined at T4175.hs:10:15
+data family B a        -- Defined at T4175.hs:12:1
+instance G B -- Defined at T4175.hs:34:10
+data instance B () = MkB       -- Defined at T4175.hs:13:15
+type instance A (B a) b = ()   -- Defined at T4175.hs:10:15
+class C a where
+  type family D a b :: *
+       -- Defined at T4175.hs:16:5
+type instance D () a = Bool    -- Defined at T4175.hs:22:10
+type instance D Int b = String         -- Defined at T4175.hs:19:10
+type family E a :: *
+  where
+      E () = Bool
+      E Int = String
+       -- Defined at T4175.hs:24:1
+data () = ()   -- Defined in ‘GHC.Tuple’
+instance C () -- Defined at T4175.hs:21:10
+instance Bounded () -- Defined in ‘GHC.Enum’
+instance Enum () -- Defined in ‘GHC.Enum’
+instance Eq () -- Defined in ‘GHC.Classes’
+instance Ord () -- Defined in ‘GHC.Classes’
+instance Read () -- Defined in ‘GHC.Read’
+instance Show () -- Defined in ‘GHC.Show’
+instance Monoid () -- Defined in ‘GHC.Base’
+type instance D () a = Bool    -- Defined at T4175.hs:22:10
+data instance B () = MkB       -- Defined at T4175.hs:13:15
+data Maybe a = Nothing | Just a        -- Defined in ‘GHC.Base’
+instance Eq a => Eq (Maybe a) -- Defined in ‘GHC.Base’
+instance Monad Maybe -- Defined in ‘GHC.Base’
+instance Functor Maybe -- Defined in ‘GHC.Base’
+instance Ord a => Ord (Maybe a) -- Defined in ‘GHC.Base’
+instance Read a => Read (Maybe a) -- Defined in ‘GHC.Read’
+instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’
+instance Applicative Maybe -- Defined in ‘GHC.Base’
+instance Foldable Maybe -- Defined in ‘Data.Foldable’
+instance Traversable Maybe -- Defined in ‘Data.Traversable’
+instance Monoid a => Monoid (Maybe a) -- Defined in ‘GHC.Base’
+type instance A (Maybe a) a = a        -- Defined at T4175.hs:9:15
+data Int = I# Int#     -- Defined in ‘GHC.Types’
+instance C Int -- Defined at T4175.hs:18:10
+instance Bounded Int -- Defined in ‘GHC.Enum’
+instance Enum Int -- Defined in ‘GHC.Enum’
+instance Eq Int -- Defined in ‘GHC.Classes’
+instance Integral Int -- Defined in ‘GHC.Real’
+instance Num Int -- Defined in ‘GHC.Num’
+instance Ord Int -- Defined in ‘GHC.Classes’
+instance Read Int -- Defined in ‘GHC.Read’
+instance Real Int -- Defined in ‘GHC.Real’
+instance Show Int -- Defined in ‘GHC.Show’
+type instance D Int b = String         -- Defined at T4175.hs:19:10
+type instance A Int Int = ()   -- Defined at T4175.hs:8:15
+class Z a      -- Defined at T4175.hs:28:1
+instance F (Z a) -- Defined at T4175.hs:31:10
index 1092ed2..fb37303 100644 (file)
@@ -1,11 +1,12 @@
 
-T8550.hs:13:12:
-    Reduction stack overflow; size = 201
-    When simplifying the following type: F ()
-    Use -freduction-depth=0 to disable this check
-    (any upper bound you could choose might fail unpredictably with
-     minor updates to GHC, so disabling the check is recommended if
-     you're sure that type checking should terminate)
-    In the expression: A
-    In the expression: seq A (return ())
-    In an equation for ‘main’: main = seq A (return ())
+T8550.hs:8:3: error:
+    • Reduction stack overflow; size = 201
+      When simplifying the following type: F ()
+      Use -freduction-depth=0 to disable this check
+      (any upper bound you could choose might fail unpredictably with
+       minor updates to GHC, so disabling the check is recommended if
+       you're sure that type checking should terminate)
+    • In the ambiguity check for ‘A’
+      To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
+      In the definition of data constructor ‘A’
+      In the data type declaration for ‘A’
index 4a1ca2b..c5f56f9 100644 (file)
@@ -1,3 +1,4 @@
 
-T8132.hs:6:10: error:
-    Class ‘Typeable’ does not support user-specified instances
+T8132.hs:6:1: error:
+    • Class ‘Typeable’ does not support user-specified instances
+    • In the instance declaration for ‘Typeable K’
index a615301..04902dd 100644 (file)
@@ -4,5 +4,4 @@ import Data.Data
 
 data HsExpr i
 
-instance Typeable HsExpr
 instance Data i => Data (HsExpr i)
index f88557e..9826868 100644 (file)
@@ -12,9 +12,9 @@ TYPE CONSTRUCTORS
 COERCION AXIOMS
   axiom T8958.N:Map :: Map k v = [(k, v)] -- Defined at T8958.hs:13:1
 INSTANCES
-  instance [incoherent] Nominal a -- Defined at T8958.hs:7:10
   instance [incoherent] Representational a
     -- Defined at T8958.hs:10:10
+  instance [incoherent] Nominal a -- Defined at T8958.hs:7:10
 Dependent modules: []
 Dependent packages: [base-4.9.0.0, ghc-prim-0.5.0.0,
                      integer-gmp-1.0.0.1]
index 5b21c03..7d34ae0 100644 (file)
@@ -1,8 +1,8 @@
 class GHC.Classes.Eq a_0 => Main.MyClass (a_0 :: *)
-instance Main.MyClass Main.Foo
+instance GHC.Classes.Ord a_1 => Main.MyClass (Main.Quux2 a_1)
+instance GHC.Classes.Eq a_2 => Main.MyClass (Main.Quux a_2)
 instance Main.MyClass Main.Baz
-instance GHC.Classes.Eq a_1 => Main.MyClass (Main.Quux a_1)
-instance GHC.Classes.Ord a_2 => Main.MyClass (Main.Quux2 a_2)
+instance Main.MyClass Main.Foo
 True
 True
 True
diff --git a/testsuite/tests/typecheck/should_compile/T11348.hs b/testsuite/tests/typecheck/should_compile/T11348.hs
new file mode 100644 (file)
index 0000000..2548dbd
--- /dev/null
@@ -0,0 +1,18 @@
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeInType #-}
+
+module T11348 where
+
+import Data.Kind
+import Data.Proxy
+
+type family TrivialFamily t :: Type
+type instance TrivialFamily (t :: Type) = Bool
+
+data R where
+    R :: Proxy Bool -> R
+
+type ProblemType t = 'R ('Proxy :: Proxy (TrivialFamily t))
index 8046fa3..ebc68eb 100644 (file)
@@ -513,3 +513,4 @@ test('T11512', normal, compile, [''])
 test('T11754', normal, compile, [''])
 test('T11811', normal, compile, [''])
 test('T11793', normal, compile, [''])
+test('T11348', normal, compile, [''])
index 95b9d1b..c20c9ec 100644 (file)
@@ -62,7 +62,7 @@ T6018fail.hs:59:10: error:
         (i.e. ones independent of the class type variables)
         must be distinct type variables
       Expected: PolyKindVarsF '[]
-      Actual:   PolyKindVarsF '[]
+        Actual: PolyKindVarsF '[]
       Use -fprint-explicit-kinds to see the kind arguments
     • In the type instance declaration for ‘PolyKindVarsF’
       In the instance declaration for ‘PolyKindVarsC '[]’
@@ -91,10 +91,10 @@ T6018fail.hs:70:15: error:
       forall k (a :: k) (b :: k).
         Gc a b = Int -- Defined at T6018fail.hs:70:15
 
-T6018fail.hs:75:15: error:
+T6018fail.hs:74:15: error:
     Type family equations violate injectivity annotation:
-      F1 (Maybe a) = Maybe (GF2 a) -- Defined at T6018fail.hs:75:15
       F1 [a] = Maybe (GF1 a) -- Defined at T6018fail.hs:74:15
+      F1 (Maybe a) = Maybe (GF2 a) -- Defined at T6018fail.hs:75:15
 
 T6018fail.hs:87:15: error:
     Type family equation violates injectivity annotation.
index 614aaf5..7a5053a 100644 (file)
@@ -1,6 +1,12 @@
 
-tcfail211.hs:5:1:
-    Illegal implicit parameter ‘?imp::Int’
-    In the context: ?imp::Int
-    While checking the super-classes of class ‘D’
-    In the class declaration for ‘D’
+tcfail211.hs:5:1: error:
+    • Illegal implicit parameter ‘?imp::Int’
+    • In the context: ?imp::Int
+      While checking the super-classes of class ‘D’
+      In the class declaration for ‘D’
+
+tcfail211.hs:8:10: error:
+    • Illegal implicit parameter ‘?imp::Int’
+    • In the context: ?imp::Int
+      While checking an instance declaration
+      In the instance declaration for ‘D Int’
index 0eff514..ba116b6 100644 (file)
@@ -256,7 +256,8 @@ boundValues mod group =
                        , bind <- bagToList binds
                        , x <- boundThings mod bind ]
                _other -> error "boundValues"
-      tys = [ n | ns <- map (fst . hsLTyClDeclBinders) (tyClGroupConcat (hs_tyclds group))
+      tys = [ n | ns <- map (fst . hsLTyClDeclBinders)
+                            (hs_tyclds group >>= group_tyclds)
                 , n <- map found ns ]
       fors = concat $ map forBound (hs_fords group)
              where forBound lford = case unLoc lford of
index 5c82c9f..56dbfe1 160000 (submodule)
@@ -1 +1 @@
-Subproject commit 5c82c9fc2d21ddaae4a2470f1c375426968f19c6
+Subproject commit 56dbfe17d272670e5f2d082401c025755796950d