Test for type synonym loops on TyCon.
authorEdward Z. Yang <ezyang@cs.stanford.edu>
Sat, 29 Oct 2016 00:54:36 +0000 (17:54 -0700)
committerEdward Z. Yang <ezyang@cs.stanford.edu>
Thu, 17 Nov 2016 05:31:59 +0000 (21:31 -0800)
Summary:
Previously, we tested for type synonym loops by doing
a syntactic test on the literal type synonym declarations.
However, in some cases, loops could go through hs-boot
files, leading to an infinite loop (#12042); a similar
situation can occur when signature merging.

This commit replaces the syntactic test with a test on
TyCon, simply by walking down all type synonyms until
we bottom out, or find we've looped back.  It's a lot
simpler.

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>
Test Plan: validate

Reviewers: simonpj, austin, bgamari

Subscribers: goldfire, thomie

Differential Revision: https://phabricator.haskell.org/D2656

GHC Trac Issues: #12042

22 files changed:
compiler/hsSyn/HsDecls.hs
compiler/typecheck/TcBackpack.hs
compiler/typecheck/TcBinds.hs
compiler/typecheck/TcTyClsDecls.hs
compiler/typecheck/TcTyDecls.hs
compiler/types/Type.hs
docs/users_guide/8.2.1-notes.rst
docs/users_guide/glasgow_exts.rst
testsuite/driver/extra_files.py
testsuite/tests/backpack/should_fail/all.T
testsuite/tests/backpack/should_fail/bkpfail29.bkp [new file with mode: 0644]
testsuite/tests/backpack/should_fail/bkpfail29.stderr [new file with mode: 0644]
testsuite/tests/module/mod27.stderr
testsuite/tests/typecheck/should_compile/all.T
testsuite/tests/typecheck/should_compile/tc268.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/tc269.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/tc270.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T12042.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T12042.hs-boot [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T12042.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T12042a.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/all.T

index ed8da4d..0d6bbf6 100644 (file)
@@ -619,6 +619,7 @@ countTyClDecls decls
 hsDeclHasCusk :: TyClDecl Name -> Bool
 hsDeclHasCusk (FamDecl { tcdFam = fam_decl }) = famDeclHasCusk Nothing fam_decl
 hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })
+  -- NB: Keep this synchronized with 'getInitialKind'
   = hsTvbAllKinded tyvars && rhs_annotated rhs
   where
     rhs_annotated (L _ ty) = case ty of
index ff924a7..6f78499 100644 (file)
@@ -21,6 +21,7 @@ import DynFlags
 import HsSyn
 import RdrName
 import TcRnMonad
+import TcTyDecls
 import InstEnv
 import FamInstEnv
 import Inst
@@ -395,6 +396,9 @@ mergeSignatures lcl_iface0 = do
                             typecheckIfacesForMerging inner_mod ifaces type_env_var
     let infos = zip ifaces detailss
 
+    -- Test for cycles
+    checkSynCycles (thisPackage dflags) (typeEnvTyCons type_env) []
+
     -- NB on type_env: it contains NO dfuns.  DFuns are recorded inside
     -- detailss, and given a Name that doesn't correspond to anything real.  See
     -- also Note [Signature merging DFuns]
index 09746d3..60ef826 100644 (file)
@@ -1134,7 +1134,9 @@ tcMonoBinds is_rec sig_fn no_gen
                              -- Single function binding,
   | NonRecursive <- is_rec   -- ...binder isn't mentioned in RHS
   , Nothing <- sig_fn name   -- ...with no type signature
-  =     -- In this very special case we infer the type of the
+  =     -- Note [Single function non-recursive binding special-case]
+        -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+        -- In this very special case we infer the type of the
         -- right hand side first (it may have a higher-rank type)
         -- and *then* make the monomorphic Id for the LHS
         -- e.g.         f = \(x::forall a. a->a) -> <body>
index c009bc9..b711ef3 100644 (file)
@@ -63,7 +63,6 @@ import Unify
 import Util
 import SrcLoc
 import ListSetOps
-import Digraph
 import DynFlags
 import Unique
 import BasicTypes
@@ -150,6 +149,12 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds
            -- Step 1: Typecheck the type/class declarations
        ; tyclss <- tcTyClDecls tyclds role_annots
 
+           -- Step 1.5: Make sure we don't have any type synonym cycles
+       ; traceTc "Starting synonym cycle check" (ppr tyclss)
+       ; this_uid <- fmap thisPackage getDynFlags
+       ; checkSynCycles this_uid tyclss tyclds
+       ; traceTc "Done synonym cycle check" (ppr tyclss)
+
            -- 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
@@ -172,7 +177,6 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds
 
        ; 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
@@ -183,6 +187,10 @@ tcTyClDecls tyclds role_annots
 
             -- Step 2: type-check all groups together, returning
             -- the final TyCons and Classes
+            --
+            -- NB: We have to be careful here to NOT eagerly unfold
+            -- type synonyms, as we have not tested for type synonym
+            -- loops yet and could fall into a black hole.
        ; fixM $ \ ~rec_tyclss -> do
            { is_boot   <- tcIsHsBootOrSig
            ; let roles = inferRoles is_boot role_annots rec_tyclss
@@ -241,14 +249,10 @@ Note [Kind checking for type and class decls]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Kind checking is done thus:
 
-   1. Make up a kind variable for each parameter of the *data* type, class,
-      and closed type family decls, and extend the kind environment (which is
-      in the TcLclEnv)
-
-   2. Dependency-analyse the type *synonyms* (which must be non-recursive),
-      and kind-check them in dependency order.  Extend the kind envt.
+   1. Make up a kind variable for each parameter of the declarations,
+      and extend the kind environment (which is in the TcLclEnv)
 
-   3. Kind check the data type and class decls
+   2. Kind check the declarations
 
 We need to kind check all types in the mutually recursive group
 before we know the kind of the type variables.  For example:
@@ -263,21 +267,18 @@ Here, the kind of the locally-polymorphic type variable "b"
 depends on *all the uses of class D*.  For example, the use of
 Monad c in bop's type signature means that D must have kind Type->Type.
 
-However type synonyms work differently.  They can have kinds which don't
-just involve (->) and *:
-        type R = Int#           -- Kind #
-        type S a = Array# a     -- Kind * -> #
-        type T a b = (# a,b #)  -- Kind * -> * -> (# a,b #)
-and a kind variable can't unify with UnboxedTypeKind.
+Note: we don't treat type synonyms specially (we used to, in the past);
+in particular, even if we have a type synonym cycle, we still kind check
+it normally, and test for cycles later (checkSynCycles).  The reason
+we can get away with this is because we have more systematic TYPE r
+inference, which means that we can do unification between kinds that
+aren't lifted (this historically was not true.)
 
-So we must infer the kinds of type synonyms from their right-hand
-sides *first* and then use them, whereas for the mutually recursive
-data types D we bring into scope kind bindings D -> k, where k is a
-kind variable, and do inference.
-
-NB: synonyms can be mutually recursive with data type declarations though!
-   type T = D -> D
-   data D = MkD Int T
+The downside of not directly reading off the kinds off the RHS of
+type synonyms in topological order is that we don't transparently
+support making synonyms of types with higher-rank kinds.  But
+you can always specify a CUSK directly to make this work out.
+See tc269 for an example.
 
 Open type families
 ~~~~~~~~~~~~~~~~~~
@@ -296,7 +297,28 @@ See also Note [Kind checking recursive type and class declarations]
 
 -}
 
+
+-- Note [Missed opportunity to retain higher-rank kinds]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- In 'kcTyClGroup', there is a missed opportunity to make kind
+-- inference work in a few more cases.  The idea is analogous
+-- to Note [Single function non-recursive binding special-case]:
+--
+--      * If we have an SCC with a single decl, which is non-recursive,
+--        instead of creating a unification variable representing the
+--        kind of the decl and unifying it with the rhs, we can just
+--        read the type directly of the rhs.
+--
+--      * Furthermore, we can update our SCC analysis to ignore
+--        dependencies on declarations which have CUSKs: we don't
+--        have to kind-check these all at once, since we can use
+--        the CUSK to initialize the kind environment.
+--
+-- Unfortunately this requires reworking a bit of the code in
+-- 'kcLTyClDecl' so I've decided to punt unless someone shouts about it.
+--
 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]
@@ -307,29 +329,23 @@ kcTyClGroup decls
         ; traceTc "kcTyClGroup" (text "module" <+> ppr mod $$ vcat (map ppr decls))
 
           -- Kind checking;
-          --    1. Bind kind variables for non-synonyms
-          --    2. Kind-check synonyms, and bind kinds of those synonyms
-          --    3. Kind-check non-synonyms
-          --    4. Generalise the inferred kinds
+          --    1. Bind kind variables for decls
+          --    2. Kind-check decls
+          --    3. Generalise the inferred kinds
           -- See Note [Kind checking for type and class decls]
 
         ; lcl_env <- solveEqualities $
           do {
-               -- Step 1: Bind kind variables for non-synonyms
-               let (syn_decls, non_syn_decls) = partition (isSynDecl . unLoc) decls
-             ; initial_kinds <- getInitialKinds non_syn_decls
+               -- Step 1: Bind kind variables for all decls
+               initial_kinds <- getInitialKinds decls
              ; traceTc "kcTyClGroup: initial kinds" $
                vcat (map pp_initial_kind initial_kinds)
+             ; tcExtendKindEnv2 initial_kinds $ do {
 
-             -- Step 2: Set initial envt, kind-check the synonyms
-             ; lcl_env <- tcExtendKindEnv2 initial_kinds $
-                          kcSynDecls (calcSynCycles syn_decls)
-
-             -- Step 3: Set extended envt, kind-check the non-synonyms
-             ; setLclEnv lcl_env $
-               mapM_ kcLTyClDecl non_syn_decls
+             -- Step 2: Set extended envt, kind-check the decls
+             ; mapM_ kcLTyClDecl decls
 
-             ; return lcl_env }
+             ; getLclEnv } }
 
              -- Step 4: generalisation
              -- Kind checking done for this group
@@ -462,8 +478,22 @@ getInitialKind decl@(DataDecl { tcdLName = L _ name
 getInitialKind (FamDecl { tcdFam = decl })
   = getFamDeclInitialKind Nothing decl
 
-getInitialKind decl@(SynDecl {})
-  = pprPanic "getInitialKind" (ppr decl)
+getInitialKind decl@(SynDecl { tcdLName = L _ name
+                             , tcdTyVars = ktvs
+                             , tcdRhs = rhs })
+  = do  { (tycon, _) <- kcHsTyVarBndrs name False (hsDeclHasCusk decl)
+                            False {- not open -} True ktvs $
+            do  { res_k <- case kind_annotation rhs of
+                            Nothing -> newMetaKindVar
+                            Just ksig -> tcLHsKind ksig
+                ; return (res_k, ()) }
+        ; return [ mkTcTyConPair tycon ] }
+  where
+    -- Keep this synchronized with 'hsDeclHasCusk'.
+    kind_annotation (L _ ty) = case ty of
+        HsParTy lty     -> kind_annotation lty
+        HsKindSig _ k   -> Just k
+        _               -> Nothing
 
 ---------------------------------
 getFamDeclInitialKinds :: Maybe Bool  -- if assoc., CUSKness of assoc. class
@@ -499,37 +529,6 @@ getFamDeclInitialKind mb_cusk decl@(FamilyDecl { fdLName     = L _ name
       OpenTypeFamily     -> (True,  False)
       ClosedTypeFamily _ -> (False, False)
 
-----------------
-kcSynDecls :: [SCC (LTyClDecl Name)]
-           -> TcM TcLclEnv -- Kind bindings
-kcSynDecls [] = getLclEnv
-kcSynDecls (group : groups)
-  = do  { tc <- kcSynDecl1 group
-        ; traceTc "kcSynDecl" (ppr tc <+> dcolon <+> ppr (tyConKind tc))
-        ; tcExtendKindEnv2 [ mkTcTyConPair tc ] $
-          kcSynDecls groups }
-
-kcSynDecl1 :: SCC (LTyClDecl Name)
-           -> TcM TcTyCon -- Kind bindings
-kcSynDecl1 (AcyclicSCC (L _ decl)) = kcSynDecl decl
-kcSynDecl1 (CyclicSCC decls)       = do { recSynErr decls; failM }
-                                     -- Fail here to avoid error cascade
-                                     -- of out-of-scope tycons
-
-kcSynDecl :: TyClDecl Name -> TcM TcTyCon
-kcSynDecl decl@(SynDecl { tcdTyVars = hs_tvs, tcdLName = L _ name
-                        , tcdRhs = rhs })
-  -- Returns a possibly-unzonked kind
-  = tcAddDeclCtxt decl $
-    do { (tycon, _) <-
-           kcHsTyVarBndrs name False (hsDeclHasCusk decl) False True hs_tvs $
-           do { traceTc "kcd1" (ppr name <+> brackets (ppr hs_tvs))
-              ; (_, rhs_kind) <- tcLHsType rhs
-              ; traceTc "kcd2" (ppr name)
-              ; return (rhs_kind, ()) }
-       ; return tycon }
-kcSynDecl decl = pprPanic "kcSynDecl" (ppr decl)
-
 ------------------------------------------------------------------------
 kcLTyClDecl :: LTyClDecl Name -> TcM ()
   -- See Note [Kind checking for type and class decls]
@@ -557,7 +556,12 @@ kcTyClDecl (DataDecl { tcdLName = L _ name, tcdDataDefn = defn })
     do  { _ <- tcHsContext ctxt
         ; mapM_ (wrapLocM kcConDecl) cons }
 
-kcTyClDecl decl@(SynDecl {}) = pprPanic "kcTyClDecl" (ppr decl)
+kcTyClDecl (SynDecl { tcdLName = L _ name, tcdRhs = lrhs })
+  = kcTyClTyVars name $
+    do  { syn_tc <- kcLookupTcTyCon name
+        -- NB: check against the result kind that we allocated
+        -- in getInitialKinds.
+        ; discardResult $ tcCheckLHsType lrhs (tyConResKind syn_tc) }
 
 kcTyClDecl (ClassDecl { tcdLName = L _ name
                       , tcdCtxt = ctxt, tcdSigs = sigs })
@@ -2742,15 +2746,6 @@ noClassTyVarErr clas fam_tc
         , text "mentions none of the type or kind variables of the class" <+>
                 quotes (ppr clas <+> hsep (map ppr (classTyVars clas)))]
 
-recSynErr :: [LTyClDecl Name] -> TcRn ()
-recSynErr syn_decls
-  = setSrcSpan (getLoc (head sorted_decls)) $
-    addErr (sep [text "Cycle in type synonym declarations:",
-                 nest 2 (vcat (map ppr_decl sorted_decls))])
-  where
-    sorted_decls = sortLocated syn_decls
-    ppr_decl (L loc decl) = ppr loc <> colon <+> ppr decl
-
 badDataConTyCon :: DataCon -> Type -> Type -> SDoc
 badDataConTyCon data_con res_ty_tmpl actual_res_ty
   = hang (text "Data constructor" <+> quotes (ppr data_con) <+>
index 67361f8..f2a868d 100644 (file)
@@ -14,7 +14,7 @@ files for imported data types.
 module TcTyDecls(
         RolesInfo,
         inferRoles,
-        calcSynCycles,
+        checkSynCycles,
         checkClassCycles,
 
         -- * Implicits
@@ -30,7 +30,7 @@ import TcRnMonad
 import TcEnv
 import TcBinds( tcRecSelBinds )
 import RnEnv( RoleAnnotEnv, lookupRoleAnnot )
-import TyCoRep( Type(..) )
+import TyCoRep( Type(..), Coercion(..), UnivCoProvenance(..) )
 import TcType
 import TysWiredIn( unitTy )
 import MkCore( rEC_SEL_ERROR_ID )
@@ -50,7 +50,6 @@ import VarEnv
 import VarSet
 import NameSet  ( NameSet, unitNameSet, extendNameSet, elemNameSet )
 import Coercion ( ltRole )
-import Digraph
 import BasicTypes
 import SrcLoc
 import Unique ( mkBuiltinUnique )
@@ -60,7 +59,7 @@ import Maybes
 import Bag
 import FastString
 import FV
-import UniqFM
+import Module
 
 import Control.Monad
 
@@ -70,77 +69,163 @@ import Control.Monad
         Cycles in type synonym declarations
 *                                                                      *
 ************************************************************************
-
-Checking for class-decl loops is easy, because we don't allow class decls
-in interface files.
-
-We allow type synonyms in hi-boot files, but we *trust* hi-boot files,
-so we don't check for loops that involve them.  So we only look for synonym
-loops in the module being compiled.
-
-We check for type synonym and class cycles on the *source* code.
-Main reasons:
-
-  a) Otherwise we'd need a special function to extract type-synonym tycons
-     from a type, whereas we already have the free vars pinned on the decl
-
-  b) If we checked for type synonym loops after building the TyCon, we
-        can't do a hoistForAllTys on the type synonym rhs, (else we fall into
-        a black hole) which seems unclean.  Apart from anything else, it'd mean
-        that a type-synonym rhs could have for-alls to the right of an arrow,
-        which means adding new cases to the validity checker
-
-        Indeed, in general, checking for cycles beforehand means we need to
-        be less careful about black holes through synonym cycles.
-
-The main disadvantage is that a cycle that goes via a type synonym in an
-.hi-boot file can lead the compiler into a loop, because it assumes that cycles
-only occur entirely within the source code of the module being compiled.
-But hi-boot files are trusted anyway, so this isn't much worse than (say)
-a kind error.
-
-[  NOTE ----------------------------------------------
-If we reverse this decision, this comment came from tcTyDecl1, and should
- go back there
-        -- dsHsType, not tcHsKindedType, to avoid a loop.  tcHsKindedType does hoisting,
-        -- which requires looking through synonyms... and therefore goes into a loop
-        -- on (erroneously) recursive synonyms.
-        -- Solution: do not hoist synonyms, because they'll be hoisted soon enough
-        --           when they are substituted
-
-We'd also need to add back in this definition
+-}
 
 synonymTyConsOfType :: Type -> [TyCon]
 -- Does not look through type synonyms at all
 -- Return a list of synonym tycons
+-- Keep this synchronized with 'expandTypeSynonyms'
 synonymTyConsOfType ty
   = nameEnvElts (go ty)
   where
      go :: Type -> NameEnv TyCon  -- The NameEnv does duplicate elim
-     go (TyVarTy v)               = emptyNameEnv
-     go (TyConApp tc tys)         = go_tc tc tys
+     go (TyConApp tc tys)         = go_tc tc `plusNameEnv` go_s tys
+     go (LitTy _)                 = emptyNameEnv
+     go (TyVarTy _)               = emptyNameEnv
      go (AppTy a b)               = go a `plusNameEnv` go b
      go (FunTy a b)               = go a `plusNameEnv` go b
      go (ForAllTy _ ty)           = go ty
-
-     go_tc tc tys | isTypeSynonymTyCon tc = extendNameEnv (go_s tys)
-                                                          (tyConName tc) tc
-                  | otherwise             = go_s tys
+     go (CastTy ty co)            = go ty `plusNameEnv` go_co co
+     go (CoercionTy co)           = go_co co
+
+     -- Note [TyCon cycles through coercions?!]
+     -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+     -- Although, in principle, it's possible for a type synonym loop
+     -- could go through a coercion (since a coercion can refer to
+     -- a TyCon or Type), it doesn't seem possible to actually construct
+     -- a Haskell program which tickles this case.  Here is an example
+     -- program which causes a coercion:
+     --
+     --   type family Star where
+     --       Star = Type
+     --
+     --   data T :: Star -> Type
+     --   data S :: forall (a :: Type). T a -> Type
+     --
+     -- Here, the application 'T a' must first coerce a :: Type to a :: Star,
+     -- witnessed by the type family.  But if we now try to make Type refer
+     -- to a type synonym which in turn refers to Star, we'll run into
+     -- trouble: we're trying to define and use the type constructor
+     -- in the same recursive group.  Possibly this restriction will be
+     -- lifted in the future but for now, this code is "just for completeness
+     -- sake".
+     go_co (Refl _ ty)            = go ty
+     go_co (TyConAppCo _ tc cs)   = go_tc tc `plusNameEnv` go_co_s cs
+     go_co (AppCo co co')         = go_co co `plusNameEnv` go_co co'
+     go_co (ForAllCo _ co co')    = go_co co `plusNameEnv` go_co co'
+     go_co (CoVarCo _)            = emptyNameEnv
+     go_co (AxiomInstCo _ _ cs)   = go_co_s cs
+     go_co (UnivCo p _ ty ty')    = go_prov p `plusNameEnv` go ty `plusNameEnv` go ty'
+     go_co (SymCo co)             = go_co co
+     go_co (TransCo co co')       = go_co co `plusNameEnv` go_co co'
+     go_co (NthCo _ co)           = go_co co
+     go_co (LRCo _ co)            = go_co co
+     go_co (InstCo co co')        = go_co co `plusNameEnv` go_co co'
+     go_co (CoherenceCo co co')   = go_co co `plusNameEnv` go_co co'
+     go_co (KindCo co)            = go_co co
+     go_co (SubCo co)             = go_co co
+     go_co (AxiomRuleCo _ cs)     = go_co_s cs
+
+     go_prov UnsafeCoerceProv     = emptyNameEnv
+     go_prov (PhantomProv co)     = go_co co
+     go_prov (ProofIrrelProv co)  = go_co co
+     go_prov (PluginProv _)       = emptyNameEnv
+     go_prov (HoleProv _)         = emptyNameEnv
+
+     go_tc tc | isTypeSynonymTyCon tc = unitNameEnv (tyConName tc) tc
+              | otherwise             = emptyNameEnv
      go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
----------------------------------------- END NOTE ]
--}
+     go_co_s cos = foldr (plusNameEnv . go_co) emptyNameEnv cos
+
+-- | A monad for type synonym cycle checking, which keeps
+-- track of the TyCons which are known to be acyclic, or
+-- a failure message reporting that a cycle was found.
+newtype SynCycleM a = SynCycleM {
+    runSynCycleM :: SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState) }
+
+type SynCycleState = NameSet
+
+instance Functor SynCycleM where
+    fmap = liftM
+
+instance Applicative SynCycleM where
+    pure x = SynCycleM $ \state -> Right (x, state)
+    (<*>) = ap
 
-mkSynEdges :: [LTyClDecl Name] -> [(LTyClDecl Name, Name, [Name])]
-mkSynEdges syn_decls = [ (ldecl, name, nonDetEltsUFM fvs)
-                       | ldecl@(L _ (SynDecl { tcdLName = L _ name
-                                             , tcdFVs = fvs })) <- syn_decls ]
-            -- It's OK to use nonDetEltsUFM here as
-            -- stronglyConnCompFromEdgedVertices is still deterministic even
-            -- if the edges are in nondeterministic order as explained in
-            -- Note [Deterministic SCC] in Digraph.
-
-calcSynCycles :: [LTyClDecl Name] -> [SCC (LTyClDecl Name)]
-calcSynCycles = stronglyConnCompFromEdgedVerticesUniq . mkSynEdges
+instance Monad SynCycleM where
+    m >>= f = SynCycleM $ \state ->
+        case runSynCycleM m state of
+            Right (x, state') ->
+                runSynCycleM (f x) state'
+            Left err -> Left err
+
+failSynCycleM :: SrcSpan -> SDoc -> SynCycleM ()
+failSynCycleM loc err = SynCycleM $ \_ -> Left (loc, err)
+
+-- | Test if a 'Name' is acyclic, short-circuiting if we've
+-- seen it already.
+checkNameIsAcyclic :: Name -> SynCycleM () -> SynCycleM ()
+checkNameIsAcyclic n m = SynCycleM $ \s ->
+    if n `elemNameSet` s
+        then Right ((), s) -- short circuit
+        else case runSynCycleM m s of
+                Right ((), s') -> Right ((), extendNameSet s' n)
+                Left err -> Left err
+
+-- | Checks if any of the passed in 'TyCon's have cycles.
+-- Takes the 'UnitId' of the home package (as we can avoid
+-- checking those TyCons: cycles never go through foreign packages) and
+-- the corresponding @LTyClDecl Name@ for each 'TyCon', so we
+-- can give better error messages.
+checkSynCycles :: UnitId -> [TyCon] -> [LTyClDecl Name] -> TcM ()
+checkSynCycles this_uid tcs tyclds = do
+    case runSynCycleM (mapM_ (go emptyNameEnv []) tcs) emptyNameEnv of
+        Left (loc, err) -> setSrcSpan loc $ failWithTc err
+        Right _  -> return ()
+  where
+    -- Try our best to print the LTyClDecl for locally defined things
+    lcl_decls = mkNameEnv (zip (map tyConName tcs) tyclds)
+
+    -- Short circuit if we've already seen this Name and concluded
+    -- it was acyclic.
+    go :: NameSet -> [TyCon] -> TyCon -> SynCycleM ()
+    go so_far seen_tcs tc =
+        checkNameIsAcyclic (tyConName tc) $ go' so_far seen_tcs tc
+
+    -- Expand type synonyms, complaining if you find the same
+    -- type synonym a second time.
+    go' :: NameSet -> [TyCon] -> TyCon -> SynCycleM ()
+    go' so_far seen_tcs tc
+        | n `elemNameSet` so_far
+            = failSynCycleM (getSrcSpan (head seen_tcs)) $
+                  sep [ text "Cycle in type synonym declarations:"
+                      , nest 2 (vcat (map ppr_decl seen_tcs)) ]
+        -- Optimization: we don't allow cycles through external packages,
+        -- so once we find a non-local name we are guaranteed to not
+        -- have a cycle.
+        --
+        -- This won't hold once we get recursive packages with Backpack,
+        -- but for now it's fine.
+        | not (isHoleModule mod ||
+               moduleUnitId mod == this_uid ||
+               isInteractiveModule mod)
+            = return ()
+        | Just ty <- synTyConRhs_maybe tc =
+            go_ty (extendNameSet so_far (tyConName tc)) (tc:seen_tcs) ty
+        | otherwise = return ()
+      where
+        n = tyConName tc
+        mod = nameModule n
+        ppr_decl tc =
+          case lookupNameEnv lcl_decls n of
+            Just (L loc decl) -> ppr loc <> colon <+> ppr decl
+            Nothing -> ppr (getSrcSpan n) <> colon <+> ppr n <+> text "from external module"
+         where
+          n = tyConName tc
+
+    go_ty :: NameSet -> [TyCon] -> Type -> SynCycleM ()
+    go_ty so_far seen_tcs ty =
+        mapM_ (go so_far seen_tcs) (synonymTyConsOfType ty)
 
 {- Note [Superclass cycle check]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
index 86cb5a8..926acf7 100644 (file)
@@ -334,6 +334,8 @@ expandTypeSynonyms :: Type -> Type
 --
 -- 'expandTypeSynonyms' only expands out type synonyms mentioned in the type,
 -- not in the kinds of any TyCon or TyVar mentioned in the type.
+--
+-- Keep this synchronized with 'synonymTyConsOfType'
 expandTypeSynonyms ty
   = go (mkEmptyTCvSubst in_scope) ty
   where
index 748bc80..1699ebb 100644 (file)
@@ -87,6 +87,16 @@ Compiler
   pre-processor causing the pre-processor to warn on uses of the ``#if``
   directive on undefined identifiers.
 
+- GHC will no longer automatically infer the kind of higher-rank type synonyms;
+  you must explicitly explicitly annotate the synonym with a kind signature.
+  For example, given::
+
+    data T :: (forall k. k -> Type) -> Type
+
+  to define a synonym of ``T``, you must write::
+
+    data TSyn = (T :: (forall k. k -> Type) -> Type)
+
 GHCi
 ~~~~
 
index af58792..12c2def 100644 (file)
@@ -2144,10 +2144,10 @@ much more liberal about type synonyms than Haskell 98.
          foo :: forall x. x -> [x]
 
 GHC currently does kind checking before expanding synonyms (though even
-that could be changed)..
+that could be changed).
 
 After expanding type synonyms, GHC does validity checking on types,
-looking for the following mal-formedness which isn't detected simply by
+looking for the following malformedness which isn't detected simply by
 kind checking:
 
 -  Type constructor applied to a type involving for-alls (if
index 3b92935..fcb6ea0 100644 (file)
@@ -85,6 +85,7 @@ extra_src_files = {
   'T11827': ['A.hs', 'A.hs-boot', 'B.hs'],
   'T12062': ['A.hs', 'A.hs-boot', 'C.hs'],
   'T12035j': ['T12035.hs', 'T12035a.hs', 'T12035.hs-boot'],
+  'T12042': ['T12042.hs', 'T12042a.hs', 'T12042.hs-boot'],
   'T12485': ['a.pkg', 'b.pkg', 'Main.hs'],
   'T12733': ['p/', 'q/', 'Setup.hs'],
   'T1372': ['p1/', 'p2/'],
index d9fab3c..f29657a 100644 (file)
@@ -24,3 +24,4 @@ test('bkpfail25', normal, backpack_compile_fail, [''])
 test('bkpfail26', normal, backpack_compile_fail, [''])
 test('bkpfail27', normal, backpack_compile_fail, [''])
 test('bkpfail28', normal, backpack_compile_fail, [''])
+test('bkpfail29', normal, backpack_compile_fail, [''])
diff --git a/testsuite/tests/backpack/should_fail/bkpfail29.bkp b/testsuite/tests/backpack/should_fail/bkpfail29.bkp
new file mode 100644 (file)
index 0000000..3dcb5a4
--- /dev/null
@@ -0,0 +1,15 @@
+unit p where
+    signature A where
+        data S
+        type T = S
+unit q where
+    signature A where
+        data T
+        type S = T
+unit r where
+    dependency p[A=<A>]
+    dependency q[A=<A>]
+    module M where
+        import A
+        x :: S
+        x = undefined
diff --git a/testsuite/tests/backpack/should_fail/bkpfail29.stderr b/testsuite/tests/backpack/should_fail/bkpfail29.stderr
new file mode 100644 (file)
index 0000000..1991709
--- /dev/null
@@ -0,0 +1,11 @@
+[1 of 3] Processing p
+  [1 of 1] Compiling A[sig]           (.hsig -> nothing)
+[2 of 3] Processing q
+  [1 of 1] Compiling A[sig]           (.hsig -> nothing)
+[3 of 3] Processing r
+  [1 of 2] Compiling A[sig]           (.hsig -> nothing)
+
+bkpfail29.bkp:8:9: error:
+    Cycle in type synonym declarations:
+      bkpfail29.bkp:8:9-18: {A.S} from external module
+      bkpfail29.bkp:7:9-14: {A.T} from external module
index 8584834..d2c333f 100644 (file)
@@ -1,5 +1,5 @@
 
-mod27.hs:3:1:
+mod27.hs:3:1: error:
     Cycle in type synonym declarations:
       mod27.hs:3:1-18: type T1 = (Int, T2)
       mod27.hs:4:1-18: type T2 = (Int, T1)
index 08a24d7..98e4ece 100644 (file)
@@ -366,6 +366,9 @@ test('Tc267',
      extra_clean(['Tc267a.hi-boot', 'Tc267a.o-boot', 'Tc267b.hi-boot', 'Tc267b.o-boot', 'Tc267a.hi', 'Tc267a.o', 'Tc267b.hi', 'Tc267b.o']),
      run_command,
      ['$MAKE -s --no-print-directory Tc267'])
+test('tc268', normal, compile, [''])
+test('tc269', normal, compile, [''])
+test('tc270', normal, compile, [''])
 
 test('GivenOverlapping', normal, compile, [''])
 test('GivenTypeSynonym', normal, compile, [''])
diff --git a/testsuite/tests/typecheck/should_compile/tc268.hs b/testsuite/tests/typecheck/should_compile/tc268.hs
new file mode 100644 (file)
index 0000000..d100673
--- /dev/null
@@ -0,0 +1,5 @@
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE ConstraintKinds #-}
+module Tc268 where
+import GHC.Exts
+type A = (() :: Constraint)
diff --git a/testsuite/tests/typecheck/should_compile/tc269.hs b/testsuite/tests/typecheck/should_compile/tc269.hs
new file mode 100644 (file)
index 0000000..33151ce
--- /dev/null
@@ -0,0 +1,22 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE TypeInType #-}
+module Tc269 where
+
+import GHC.Types
+
+{-
+-- We'd like this to kind check, but it doesn't today,
+-- see Note [Missed opportunity to retain higher-rank kinds]
+
+-- TSyn is in an SCC of its own, so we can read off the
+-- kind directly.
+data T (p :: forall k. k -> Type) = T
+type TSyn = T
+-}
+
+-- S and SSyn are in an SCC, so we do kind inference for
+-- everything.  Need an explicit type signature.
+data K (a :: k) = K
+data S (p :: forall k. k -> Type) = S (SSyn K)
+type SSyn = (S :: (forall k. k -> Type) -> Type)
diff --git a/testsuite/tests/typecheck/should_compile/tc270.hs b/testsuite/tests/typecheck/should_compile/tc270.hs
new file mode 100644 (file)
index 0000000..7ab1b6c
--- /dev/null
@@ -0,0 +1,1006 @@
+module Tc270 where
+
+-- Type synonym stress test... though, it does seem that we
+-- are quadratic in the number of nested type synonyms.
+
+type T0 = ()
+type T1 = T0
+type T2 = T1
+type T3 = T2
+type T4 = T3
+type T5 = T4
+type T6 = T5
+type T7 = T6
+type T8 = T7
+type T9 = T8
+type T10 = T9
+type T11 = T10
+type T12 = T11
+type T13 = T12
+type T14 = T13
+type T15 = T14
+type T16 = T15
+type T17 = T16
+type T18 = T17
+type T19 = T18
+type T20 = T19
+type T21 = T20
+type T22 = T21
+type T23 = T22
+type T24 = T23
+type T25 = T24
+type T26 = T25
+type T27 = T26
+type T28 = T27
+type T29 = T28
+type T30 = T29
+type T31 = T30
+type T32 = T31
+type T33 = T32
+type T34 = T33
+type T35 = T34
+type T36 = T35
+type T37 = T36
+type T38 = T37
+type T39 = T38
+type T40 = T39
+type T41 = T40
+type T42 = T41
+type T43 = T42
+type T44 = T43
+type T45 = T44
+type T46 = T45
+type T47 = T46
+type T48 = T47
+type T49 = T48
+type T50 = T49
+type T51 = T50
+type T52 = T51
+type T53 = T52
+type T54 = T53
+type T55 = T54
+type T56 = T55
+type T57 = T56
+type T58 = T57
+type T59 = T58
+type T60 = T59
+type T61 = T60
+type T62 = T61
+type T63 = T62
+type T64 = T63
+type T65 = T64
+type T66 = T65
+type T67 = T66
+type T68 = T67
+type T69 = T68
+type T70 = T69
+type T71 = T70
+type T72 = T71
+type T73 = T72
+type T74 = T73
+type T75 = T74
+type T76 = T75
+type T77 = T76
+type T78 = T77
+type T79 = T78
+type T80 = T79
+type T81 = T80
+type T82 = T81
+type T83 = T82
+type T84 = T83
+type T85 = T84
+type T86 = T85
+type T87 = T86
+type T88 = T87
+type T89 = T88
+type T90 = T89
+type T91 = T90
+type T92 = T91
+type T93 = T92
+type T94 = T93
+type T95 = T94
+type T96 = T95
+type T97 = T96
+type T98 = T97
+type T99 = T98
+type T100 = T99
+type T101 = T100
+type T102 = T101
+type T103 = T102
+type T104 = T103
+type T105 = T104
+type T106 = T105
+type T107 = T106
+type T108 = T107
+type T109 = T108
+type T110 = T109
+type T111 = T110
+type T112 = T111
+type T113 = T112
+type T114 = T113
+type T115 = T114
+type T116 = T115
+type T117 = T116
+type T118 = T117
+type T119 = T118
+type T120 = T119
+type T121 = T120
+type T122 = T121
+type T123 = T122
+type T124 = T123
+type T125 = T124
+type T126 = T125
+type T127 = T126
+type T128 = T127
+type T129 = T128
+type T130 = T129
+type T131 = T130
+type T132 = T131
+type T133 = T132
+type T134 = T133
+type T135 = T134
+type T136 = T135
+type T137 = T136
+type T138 = T137
+type T139 = T138
+type T140 = T139
+type T141 = T140
+type T142 = T141
+type T143 = T142
+type T144 = T143
+type T145 = T144
+type T146 = T145
+type T147 = T146
+type T148 = T147
+type T149 = T148
+type T150 = T149
+type T151 = T150
+type T152 = T151
+type T153 = T152
+type T154 = T153
+type T155 = T154
+type T156 = T155
+type T157 = T156
+type T158 = T157
+type T159 = T158
+type T160 = T159
+type T161 = T160
+type T162 = T161
+type T163 = T162
+type T164 = T163
+type T165 = T164
+type T166 = T165
+type T167 = T166
+type T168 = T167
+type T169 = T168
+type T170 = T169
+type T171 = T170
+type T172 = T171
+type T173 = T172
+type T174 = T173
+type T175 = T174
+type T176 = T175
+type T177 = T176
+type T178 = T177
+type T179 = T178
+type T180 = T179
+type T181 = T180
+type T182 = T181
+type T183 = T182
+type T184 = T183
+type T185 = T184
+type T186 = T185
+type T187 = T186
+type T188 = T187
+type T189 = T188
+type T190 = T189
+type T191 = T190
+type T192 = T191
+type T193 = T192
+type T194 = T193
+type T195 = T194
+type T196 = T195
+type T197 = T196
+type T198 = T197
+type T199 = T198
+type T200 = T199
+type T201 = T200
+type T202 = T201
+type T203 = T202
+type T204 = T203
+type T205 = T204
+type T206 = T205
+type T207 = T206
+type T208 = T207
+type T209 = T208
+type T210 = T209
+type T211 = T210
+type T212 = T211
+type T213 = T212
+type T214 = T213
+type T215 = T214
+type T216 = T215
+type T217 = T216
+type T218 = T217
+type T219 = T218
+type T220 = T219
+type T221 = T220
+type T222 = T221
+type T223 = T222
+type T224 = T223
+type T225 = T224
+type T226 = T225
+type T227 = T226
+type T228 = T227
+type T229 = T228
+type T230 = T229
+type T231 = T230
+type T232 = T231
+type T233 = T232
+type T234 = T233
+type T235 = T234
+type T236 = T235
+type T237 = T236
+type T238 = T237
+type T239 = T238
+type T240 = T239
+type T241 = T240
+type T242 = T241
+type T243 = T242
+type T244 = T243
+type T245 = T244
+type T246 = T245
+type T247 = T246
+type T248 = T247
+type T249 = T248
+type T250 = T249
+type T251 = T250
+type T252 = T251
+type T253 = T252
+type T254 = T253
+type T255 = T254
+type T256 = T255
+type T257 = T256
+type T258 = T257
+type T259 = T258
+type T260 = T259
+type T261 = T260
+type T262 = T261
+type T263 = T262
+type T264 = T263
+type T265 = T264
+type T266 = T265
+type T267 = T266
+type T268 = T267
+type T269 = T268
+type T270 = T269
+type T271 = T270
+type T272 = T271
+type T273 = T272
+type T274 = T273
+type T275 = T274
+type T276 = T275
+type T277 = T276
+type T278 = T277
+type T279 = T278
+type T280 = T279
+type T281 = T280
+type T282 = T281
+type T283 = T282
+type T284 = T283
+type T285 = T284
+type T286 = T285
+type T287 = T286
+type T288 = T287
+type T289 = T288
+type T290 = T289
+type T291 = T290
+type T292 = T291
+type T293 = T292
+type T294 = T293
+type T295 = T294
+type T296 = T295
+type T297 = T296
+type T298 = T297
+type T299 = T298
+type T300 = T299
+type T301 = T300
+type T302 = T301
+type T303 = T302
+type T304 = T303
+type T305 = T304
+type T306 = T305
+type T307 = T306
+type T308 = T307
+type T309 = T308
+type T310 = T309
+type T311 = T310
+type T312 = T311
+type T313 = T312
+type T314 = T313
+type T315 = T314
+type T316 = T315
+type T317 = T316
+type T318 = T317
+type T319 = T318
+type T320 = T319
+type T321 = T320
+type T322 = T321
+type T323 = T322
+type T324 = T323
+type T325 = T324
+type T326 = T325
+type T327 = T326
+type T328 = T327
+type T329 = T328
+type T330 = T329
+type T331 = T330
+type T332 = T331
+type T333 = T332
+type T334 = T333
+type T335 = T334
+type T336 = T335
+type T337 = T336
+type T338 = T337
+type T339 = T338
+type T340 = T339
+type T341 = T340
+type T342 = T341
+type T343 = T342
+type T344 = T343
+type T345 = T344
+type T346 = T345
+type T347 = T346
+type T348 = T347
+type T349 = T348
+type T350 = T349
+type T351 = T350
+type T352 = T351
+type T353 = T352
+type T354 = T353
+type T355 = T354
+type T356 = T355
+type T357 = T356
+type T358 = T357
+type T359 = T358
+type T360 = T359
+type T361 = T360
+type T362 = T361
+type T363 = T362
+type T364 = T363
+type T365 = T364
+type T366 = T365
+type T367 = T366
+type T368 = T367
+type T369 = T368
+type T370 = T369
+type T371 = T370
+type T372 = T371
+type T373 = T372
+type T374 = T373
+type T375 = T374
+type T376 = T375
+type T377 = T376
+type T378 = T377
+type T379 = T378
+type T380 = T379
+type T381 = T380
+type T382 = T381
+type T383 = T382
+type T384 = T383
+type T385 = T384
+type T386 = T385
+type T387 = T386
+type T388 = T387
+type T389 = T388
+type T390 = T389
+type T391 = T390
+type T392 = T391
+type T393 = T392
+type T394 = T393
+type T395 = T394
+type T396 = T395
+type T397 = T396
+type T398 = T397
+type T399 = T398
+type T400 = T399
+type T401 = T400
+type T402 = T401
+type T403 = T402
+type T404 = T403
+type T405 = T404
+type T406 = T405
+type T407 = T406
+type T408 = T407
+type T409 = T408
+type T410 = T409
+type T411 = T410
+type T412 = T411
+type T413 = T412
+type T414 = T413
+type T415 = T414
+type T416 = T415
+type T417 = T416
+type T418 = T417
+type T419 = T418
+type T420 = T419
+type T421 = T420
+type T422 = T421
+type T423 = T422
+type T424 = T423
+type T425 = T424
+type T426 = T425
+type T427 = T426
+type T428 = T427
+type T429 = T428
+type T430 = T429
+type T431 = T430
+type T432 = T431
+type T433 = T432
+type T434 = T433
+type T435 = T434
+type T436 = T435
+type T437 = T436
+type T438 = T437
+type T439 = T438
+type T440 = T439
+type T441 = T440
+type T442 = T441
+type T443 = T442
+type T444 = T443
+type T445 = T444
+type T446 = T445
+type T447 = T446
+type T448 = T447
+type T449 = T448
+type T450 = T449
+type T451 = T450
+type T452 = T451
+type T453 = T452
+type T454 = T453
+type T455 = T454
+type T456 = T455
+type T457 = T456
+type T458 = T457
+type T459 = T458
+type T460 = T459
+type T461 = T460
+type T462 = T461
+type T463 = T462
+type T464 = T463
+type T465 = T464
+type T466 = T465
+type T467 = T466
+type T468 = T467
+type T469 = T468
+type T470 = T469
+type T471 = T470
+type T472 = T471
+type T473 = T472
+type T474 = T473
+type T475 = T474
+type T476 = T475
+type T477 = T476
+type T478 = T477
+type T479 = T478
+type T480 = T479
+type T481 = T480
+type T482 = T481
+type T483 = T482
+type T484 = T483
+type T485 = T484
+type T486 = T485
+type T487 = T486
+type T488 = T487
+type T489 = T488
+type T490 = T489
+type T491 = T490
+type T492 = T491
+type T493 = T492
+type T494 = T493
+type T495 = T494
+type T496 = T495
+type T497 = T496
+type T498 = T497
+type T499 = T498
+type T500 = T499
+type T501 = T500
+type T502 = T501
+type T503 = T502
+type T504 = T503
+type T505 = T504
+type T506 = T505
+type T507 = T506
+type T508 = T507
+type T509 = T508
+type T510 = T509
+type T511 = T510
+type T512 = T511
+type T513 = T512
+type T514 = T513
+type T515 = T514
+type T516 = T515
+type T517 = T516
+type T518 = T517
+type T519 = T518
+type T520 = T519
+type T521 = T520
+type T522 = T521
+type T523 = T522
+type T524 = T523
+type T525 = T524
+type T526 = T525
+type T527 = T526
+type T528 = T527
+type T529 = T528
+type T530 = T529
+type T531 = T530
+type T532 = T531
+type T533 = T532
+type T534 = T533
+type T535 = T534
+type T536 = T535
+type T537 = T536
+type T538 = T537
+type T539 = T538
+type T540 = T539
+type T541 = T540
+type T542 = T541
+type T543 = T542
+type T544 = T543
+type T545 = T544
+type T546 = T545
+type T547 = T546
+type T548 = T547
+type T549 = T548
+type T550 = T549
+type T551 = T550
+type T552 = T551
+type T553 = T552
+type T554 = T553
+type T555 = T554
+type T556 = T555
+type T557 = T556
+type T558 = T557
+type T559 = T558
+type T560 = T559
+type T561 = T560
+type T562 = T561
+type T563 = T562
+type T564 = T563
+type T565 = T564
+type T566 = T565
+type T567 = T566
+type T568 = T567
+type T569 = T568
+type T570 = T569
+type T571 = T570
+type T572 = T571
+type T573 = T572
+type T574 = T573
+type T575 = T574
+type T576 = T575
+type T577 = T576
+type T578 = T577
+type T579 = T578
+type T580 = T579
+type T581 = T580
+type T582 = T581
+type T583 = T582
+type T584 = T583
+type T585 = T584
+type T586 = T585
+type T587 = T586
+type T588 = T587
+type T589 = T588
+type T590 = T589
+type T591 = T590
+type T592 = T591
+type T593 = T592
+type T594 = T593
+type T595 = T594
+type T596 = T595
+type T597 = T596
+type T598 = T597
+type T599 = T598
+type T600 = T599
+type T601 = T600
+type T602 = T601
+type T603 = T602
+type T604 = T603
+type T605 = T604
+type T606 = T605
+type T607 = T606
+type T608 = T607
+type T609 = T608
+type T610 = T609
+type T611 = T610
+type T612 = T611
+type T613 = T612
+type T614 = T613
+type T615 = T614
+type T616 = T615
+type T617 = T616
+type T618 = T617
+type T619 = T618
+type T620 = T619
+type T621 = T620
+type T622 = T621
+type T623 = T622
+type T624 = T623
+type T625 = T624
+type T626 = T625
+type T627 = T626
+type T628 = T627
+type T629 = T628
+type T630 = T629
+type T631 = T630
+type T632 = T631
+type T633 = T632
+type T634 = T633
+type T635 = T634
+type T636 = T635
+type T637 = T636
+type T638 = T637
+type T639 = T638
+type T640 = T639
+type T641 = T640
+type T642 = T641
+type T643 = T642
+type T644 = T643
+type T645 = T644
+type T646 = T645
+type T647 = T646
+type T648 = T647
+type T649 = T648
+type T650 = T649
+type T651 = T650
+type T652 = T651
+type T653 = T652
+type T654 = T653
+type T655 = T654
+type T656 = T655
+type T657 = T656
+type T658 = T657
+type T659 = T658
+type T660 = T659
+type T661 = T660
+type T662 = T661
+type T663 = T662
+type T664 = T663
+type T665 = T664
+type T666 = T665
+type T667 = T666
+type T668 = T667
+type T669 = T668
+type T670 = T669
+type T671 = T670
+type T672 = T671
+type T673 = T672
+type T674 = T673
+type T675 = T674
+type T676 = T675
+type T677 = T676
+type T678 = T677
+type T679 = T678
+type T680 = T679
+type T681 = T680
+type T682 = T681
+type T683 = T682
+type T684 = T683
+type T685 = T684
+type T686 = T685
+type T687 = T686
+type T688 = T687
+type T689 = T688
+type T690 = T689
+type T691 = T690
+type T692 = T691
+type T693 = T692
+type T694 = T693
+type T695 = T694
+type T696 = T695
+type T697 = T696
+type T698 = T697
+type T699 = T698
+type T700 = T699
+type T701 = T700
+type T702 = T701
+type T703 = T702
+type T704 = T703
+type T705 = T704
+type T706 = T705
+type T707 = T706
+type T708 = T707
+type T709 = T708
+type T710 = T709
+type T711 = T710
+type T712 = T711
+type T713 = T712
+type T714 = T713
+type T715 = T714
+type T716 = T715
+type T717 = T716
+type T718 = T717
+type T719 = T718
+type T720 = T719
+type T721 = T720
+type T722 = T721
+type T723 = T722
+type T724 = T723
+type T725 = T724
+type T726 = T725
+type T727 = T726
+type T728 = T727
+type T729 = T728
+type T730 = T729
+type T731 = T730
+type T732 = T731
+type T733 = T732
+type T734 = T733
+type T735 = T734
+type T736 = T735
+type T737 = T736
+type T738 = T737
+type T739 = T738
+type T740 = T739
+type T741 = T740
+type T742 = T741
+type T743 = T742
+type T744 = T743
+type T745 = T744
+type T746 = T745
+type T747 = T746
+type T748 = T747
+type T749 = T748
+type T750 = T749
+type T751 = T750
+type T752 = T751
+type T753 = T752
+type T754 = T753
+type T755 = T754
+type T756 = T755
+type T757 = T756
+type T758 = T757
+type T759 = T758
+type T760 = T759
+type T761 = T760
+type T762 = T761
+type T763 = T762
+type T764 = T763
+type T765 = T764
+type T766 = T765
+type T767 = T766
+type T768 = T767
+type T769 = T768
+type T770 = T769
+type T771 = T770
+type T772 = T771
+type T773 = T772
+type T774 = T773
+type T775 = T774
+type T776 = T775
+type T777 = T776
+type T778 = T777
+type T779 = T778
+type T780 = T779
+type T781 = T780
+type T782 = T781
+type T783 = T782
+type T784 = T783
+type T785 = T784
+type T786 = T785
+type T787 = T786
+type T788 = T787
+type T789 = T788
+type T790 = T789
+type T791 = T790
+type T792 = T791
+type T793 = T792
+type T794 = T793
+type T795 = T794
+type T796 = T795
+type T797 = T796
+type T798 = T797
+type T799 = T798
+type T800 = T799
+type T801 = T800
+type T802 = T801
+type T803 = T802
+type T804 = T803
+type T805 = T804
+type T806 = T805
+type T807 = T806
+type T808 = T807
+type T809 = T808
+type T810 = T809
+type T811 = T810
+type T812 = T811
+type T813 = T812
+type T814 = T813
+type T815 = T814
+type T816 = T815
+type T817 = T816
+type T818 = T817
+type T819 = T818
+type T820 = T819
+type T821 = T820
+type T822 = T821
+type T823 = T822
+type T824 = T823
+type T825 = T824
+type T826 = T825
+type T827 = T826
+type T828 = T827
+type T829 = T828
+type T830 = T829
+type T831 = T830
+type T832 = T831
+type T833 = T832
+type T834 = T833
+type T835 = T834
+type T836 = T835
+type T837 = T836
+type T838 = T837
+type T839 = T838
+type T840 = T839
+type T841 = T840
+type T842 = T841
+type T843 = T842
+type T844 = T843
+type T845 = T844
+type T846 = T845
+type T847 = T846
+type T848 = T847
+type T849 = T848
+type T850 = T849
+type T851 = T850
+type T852 = T851
+type T853 = T852
+type T854 = T853
+type T855 = T854
+type T856 = T855
+type T857 = T856
+type T858 = T857
+type T859 = T858
+type T860 = T859
+type T861 = T860
+type T862 = T861
+type T863 = T862
+type T864 = T863
+type T865 = T864
+type T866 = T865
+type T867 = T866
+type T868 = T867
+type T869 = T868
+type T870 = T869
+type T871 = T870
+type T872 = T871
+type T873 = T872
+type T874 = T873
+type T875 = T874
+type T876 = T875
+type T877 = T876
+type T878 = T877
+type T879 = T878
+type T880 = T879
+type T881 = T880
+type T882 = T881
+type T883 = T882
+type T884 = T883
+type T885 = T884
+type T886 = T885
+type T887 = T886
+type T888 = T887
+type T889 = T888
+type T890 = T889
+type T891 = T890
+type T892 = T891
+type T893 = T892
+type T894 = T893
+type T895 = T894
+type T896 = T895
+type T897 = T896
+type T898 = T897
+type T899 = T898
+type T900 = T899
+type T901 = T900
+type T902 = T901
+type T903 = T902
+type T904 = T903
+type T905 = T904
+type T906 = T905
+type T907 = T906
+type T908 = T907
+type T909 = T908
+type T910 = T909
+type T911 = T910
+type T912 = T911
+type T913 = T912
+type T914 = T913
+type T915 = T914
+type T916 = T915
+type T917 = T916
+type T918 = T917
+type T919 = T918
+type T920 = T919
+type T921 = T920
+type T922 = T921
+type T923 = T922
+type T924 = T923
+type T925 = T924
+type T926 = T925
+type T927 = T926
+type T928 = T927
+type T929 = T928
+type T930 = T929
+type T931 = T930
+type T932 = T931
+type T933 = T932
+type T934 = T933
+type T935 = T934
+type T936 = T935
+type T937 = T936
+type T938 = T937
+type T939 = T938
+type T940 = T939
+type T941 = T940
+type T942 = T941
+type T943 = T942
+type T944 = T943
+type T945 = T944
+type T946 = T945
+type T947 = T946
+type T948 = T947
+type T949 = T948
+type T950 = T949
+type T951 = T950
+type T952 = T951
+type T953 = T952
+type T954 = T953
+type T955 = T954
+type T956 = T955
+type T957 = T956
+type T958 = T957
+type T959 = T958
+type T960 = T959
+type T961 = T960
+type T962 = T961
+type T963 = T962
+type T964 = T963
+type T965 = T964
+type T966 = T965
+type T967 = T966
+type T968 = T967
+type T969 = T968
+type T970 = T969
+type T971 = T970
+type T972 = T971
+type T973 = T972
+type T974 = T973
+type T975 = T974
+type T976 = T975
+type T977 = T976
+type T978 = T977
+type T979 = T978
+type T980 = T979
+type T981 = T980
+type T982 = T981
+type T983 = T982
+type T984 = T983
+type T985 = T984
+type T986 = T985
+type T987 = T986
+type T988 = T987
+type T989 = T988
+type T990 = T989
+type T991 = T990
+type T992 = T991
+type T993 = T992
+type T994 = T993
+type T995 = T994
+type T996 = T995
+type T997 = T996
+type T998 = T997
+type T999 = T998
+type T1000 = T999
diff --git a/testsuite/tests/typecheck/should_fail/T12042.hs b/testsuite/tests/typecheck/should_fail/T12042.hs
new file mode 100644 (file)
index 0000000..20d919b
--- /dev/null
@@ -0,0 +1,4 @@
+module T12042 where
+import qualified T12042a as B
+type S = B.R
+type R = B.U
diff --git a/testsuite/tests/typecheck/should_fail/T12042.hs-boot b/testsuite/tests/typecheck/should_fail/T12042.hs-boot
new file mode 100644 (file)
index 0000000..7ced300
--- /dev/null
@@ -0,0 +1,3 @@
+module T12042 where
+data S
+type R = S
diff --git a/testsuite/tests/typecheck/should_fail/T12042.stderr b/testsuite/tests/typecheck/should_fail/T12042.stderr
new file mode 100644 (file)
index 0000000..5334c8c
--- /dev/null
@@ -0,0 +1,9 @@
+[1 of 3] Compiling T12042[boot]     (.hs-boot -> .o-boot)
+[2 of 3] Compiling T12042a          (.hs -> .o)
+[3 of 3] Compiling T12042           (.hs -> .o)
+
+T12042.hs:3:1: error:
+    Cycle in type synonym declarations:
+      T12042.hs:3:1-12: type S = R
+      T12042a.hs:3:1-10: B.U from external module
+      T12042.hs:4:1-12: type R = B.U
diff --git a/testsuite/tests/typecheck/should_fail/T12042a.hs b/testsuite/tests/typecheck/should_fail/T12042a.hs
new file mode 100644 (file)
index 0000000..4dba8cd
--- /dev/null
@@ -0,0 +1,3 @@
+module T12042a (module T12042a, module T12042) where
+import {-# SOURCE #-} T12042
+type U = S
index 1f3b8ba..4d58d4f 100644 (file)
@@ -431,3 +431,4 @@ test('T12589', normal, compile_fail, [''])
 test('T12529', normal, compile_fail, [''])
 test('T12729', normal, compile_fail, [''])
 test('T12803', normal, compile_fail, [''])
+test('T12042', extra_clean(['T12042a.hi', 'T12042a.o', 'T12042.hi-boot', 'T12042.o-boot']), multimod_compile_fail, ['T12042', ''])