Fix Trac #2412: type synonyms and hs-boot recursion

Max Bolingbroke found this awkward bug, which relates to the way in
which hs-boot files are handled.

   --> HEADS UP: interface file format change: recompile everything!

When we import a type synonym, we want to *refrain* from looking at its
RHS until we've "tied the knot" in the module being compiled.  (Reason:
the type synonym might ultimately loop back to the module being compiled.)
To achieve this goal we need to know the *kind* of the synonym without 
looking at its RHS.  And to do that we need its kind recorded in the interface
file.

I slightly refactored the way that the IfaceSyn data constructor
fields work, eliminating the previous tricky re-use of the same field
as either a type or a kind.

See Note [Synonym kind loop] in TcIface

4 files changed, 67 insertions, 41 deletions

diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index 8459edf98a..ef75d7f31a 100644
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -39,22 +39,23 @@ import Data.List
 ------------------------------------------------------
 buildSynTyCon :: Name -> [TyVar] 
               -> SynTyConRhs 
+	      -> Kind			-- Kind of the RHS
 	      -> Maybe (TyCon, [Type])  -- family instance if applicable
               -> TcRnIf m n TyCon
 
-buildSynTyCon tc_name tvs rhs@(OpenSynTyCon rhs_ki _) _
+buildSynTyCon tc_name tvs rhs@(OpenSynTyCon {}) rhs_kind _
   = let
-      kind = mkArrowKinds (map tyVarKind tvs) rhs_ki
+      kind = mkArrowKinds (map tyVarKind tvs) rhs_kind
     in
     return $ mkSynTyCon tc_name kind tvs rhs NoParentTyCon
     
-buildSynTyCon tc_name tvs rhs@(SynonymTyCon rhs_ty) mb_family
+buildSynTyCon tc_name tvs rhs@(SynonymTyCon {}) rhs_kind mb_family
   = do { -- We need to tie a knot as the coercion of a data instance depends
 	 -- on the instance representation tycon and vice versa.
        ; tycon <- fixM (\ tycon_rec -> do 
 	 { parent <- mkParentInfo mb_family tc_name tvs tycon_rec
 	 ; let { tycon   = mkSynTyCon tc_name kind tvs rhs parent
-	       ; kind    = mkArrowKinds (map tyVarKind tvs) (typeKind rhs_ty)
+	       ; kind    = mkArrowKinds (map tyVarKind tvs) rhs_kind
 	       }
          ; return tycon
          })
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index 39a1fd2fd6..c33d1f5ee6 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -81,11 +81,10 @@ data IfaceDecl
 
   | IfaceSyn  {	ifName    :: OccName,		-- Type constructor
 		ifTyVars  :: [IfaceTvBndr],	-- Type variables
-		ifOpenSyn :: Bool,		-- Is an open family?
-		ifSynRhs  :: IfaceType,		-- Type for an ordinary
-						-- synonym and kind for an
-						-- open family
-                ifFamInst    :: Maybe (IfaceTyCon, [IfaceType])
+		ifSynKind :: IfaceKind,		-- Kind of the *rhs* (not of the tycon)
+		ifSynRhs  :: Maybe IfaceType,	-- Just rhs for an ordinary synonyn
+						-- Nothing for an open family
+                ifFamInst :: Maybe (IfaceTyCon, [IfaceType])
                                                 -- Just <=> instance of family
                                                 -- Invariant: ifOpenSyn == False
                                                 --   for family instances
@@ -426,15 +425,15 @@ pprIfaceDecl (IfaceForeign {ifName = tycon})
   = hsep [ptext (sLit "foreign import type dotnet"), ppr tycon]
 
 pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, 
-		        ifOpenSyn = False, ifSynRhs = mono_ty, 
+		        ifSynRhs = Just mono_ty, 
                         ifFamInst = mbFamInst})
   = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars)
        4 (vcat [equals <+> ppr mono_ty, pprFamily mbFamInst])
 
 pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, 
-		        ifOpenSyn = True, ifSynRhs = mono_ty})
+		        ifSynRhs = Nothing, ifSynKind = kind })
   = hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars)
-       4 (dcolon <+> ppr mono_ty)
+       4 (dcolon <+> ppr kind)
 
 pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context,
 			 ifTyVars = tyvars, ifCons = condecls, 
@@ -668,7 +667,7 @@ freeNamesIfDecl d@IfaceData{} =
   freeNamesIfConDecls (ifCons d)
 freeNamesIfDecl d@IfaceSyn{} =
   freeNamesIfTvBndrs (ifTyVars d) &&&
-  freeNamesIfType    (ifSynRhs d) &&&
+  freeNamesIfSynRhs (ifSynRhs d) &&&
   freeNamesIfTcFam (ifFamInst d)
 freeNamesIfDecl d@IfaceClass{} =
   freeNamesIfTvBndrs (ifTyVars d) &&&
@@ -677,6 +676,10 @@ freeNamesIfDecl d@IfaceClass{} =
   fnList freeNamesIfClsSig (ifSigs d)
 
 -- All other changes are handled via the version info on the tycon
+freeNamesIfSynRhs :: Maybe IfaceType -> NameSet
+freeNamesIfSynRhs (Just ty) = freeNamesIfType ty
+freeNamesIfSynRhs Nothing   = emptyNameSet
+
 freeNamesIfTcFam :: Maybe (IfaceTyCon, [IfaceType]) -> NameSet
 freeNamesIfTcFam (Just (tc,tys)) = 
   freeNamesIfTc tc &&& fnList freeNamesIfType tys
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index 3f1ee46e1f..bc84cf168a 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -1290,8 +1290,8 @@ tyThingToIfaceDecl (ATyCon tycon)
   | isSynTyCon tycon
   = IfaceSyn {	ifName    = getOccName tycon,
 		ifTyVars  = toIfaceTvBndrs tyvars,
-		ifOpenSyn = syn_isOpen,
-		ifSynRhs  = toIfaceType syn_tyki,
+		ifSynRhs  = syn_rhs,
+	  	ifSynKind = syn_ki,
                 ifFamInst = famInstToIface (tyConFamInst_maybe tycon)
              }
 
@@ -1312,9 +1312,10 @@ tyThingToIfaceDecl (ATyCon tycon)
   | otherwise = pprPanic "toIfaceDecl" (ppr tycon)
   where
     tyvars = tyConTyVars tycon
-    (syn_isOpen, syn_tyki) = case synTyConRhs tycon of
-			       OpenSynTyCon ki _ -> (True , ki)
-			       SynonymTyCon ty   -> (False, ty)
+    (syn_rhs, syn_ki) 
+       = case synTyConRhs tycon of
+	    OpenSynTyCon ki _ -> (Nothing,               toIfaceType ki)
+	    SynonymTyCon ty   -> (Just (toIfaceType ty), toIfaceType (typeKind ty))
 
     ifaceConDecls (NewTyCon { data_con = con })     = 
       IfNewTyCon  (ifaceConDecl con)
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index b36aad5177..32735a4e36 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -356,14 +356,13 @@ tcIfaceDecl ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, ifIdI
 	; info <- tcIdInfo ignore_prags name ty info
 	; return (AnId (mkVanillaGlobalWithInfo name ty info)) }
 
-tcIfaceDecl _
-	    (IfaceData {ifName = occ_name, 
-			ifTyVars = tv_bndrs, 
-			ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
-			ifCons = rdr_cons, 
-			ifRec = is_rec, 
-			ifGeneric = want_generic,
-			ifFamInst = mb_family })
+tcIfaceDecl _ (IfaceData {ifName = occ_name, 
+			  ifTyVars = tv_bndrs, 
+			  ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
+			  ifCons = rdr_cons, 
+			  ifRec = is_rec, 
+			  ifGeneric = want_generic,
+			  ifFamInst = mb_family })
   = do	{ tc_name <- lookupIfaceTop occ_name
 	; bindIfaceTyVars tv_bndrs $ \ tyvars -> do
 
@@ -385,25 +384,30 @@ tcIfaceDecl _
 	; return (ATyCon tycon)
     }}
 
-tcIfaceDecl _
-	    (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, 
-		       ifOpenSyn = isOpen, ifSynRhs = rdr_rhs_ty,
-		       ifFamInst = mb_family})
+tcIfaceDecl _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, 
+		         ifSynRhs = mb_rhs_ty,
+		         ifSynKind = kind, ifFamInst = mb_family})
    = bindIfaceTyVars tv_bndrs $ \ tyvars -> do
      { tc_name <- lookupIfaceTop occ_name
-     ; rhs_tyki <- tcIfaceType rdr_rhs_ty
-     ; let rhs = if isOpen then OpenSynTyCon rhs_tyki Nothing
-			   else SynonymTyCon rhs_tyki
-     ; famInst <- case mb_family of
-		    Nothing         -> return Nothing
-		    Just (fam, tys) -> 
-		      do { famTyCon <- tcIfaceTyCon fam
-		         ; insttys <- mapM tcIfaceType tys
-		         ; return $ Just (famTyCon, insttys)
-		         }
-     ; tycon <- buildSynTyCon tc_name tyvars rhs famInst
+     ; rhs_kind <- tcIfaceType kind	-- Note [Synonym kind loop]
+     ; ~(rhs, fam) <- forkM (mk_doc tc_name) $ 
+       	      	      do { rhs <- tc_syn_rhs rhs_kind mb_rhs_ty
+			 ; fam <- tc_syn_fam mb_family
+			 ; return (rhs, fam) }
+     ; tycon <- buildSynTyCon tc_name tyvars rhs rhs_kind fam
      ; return $ ATyCon tycon
      }
+   where
+     mk_doc n = ptext (sLit "Type syonym") <+> ppr n
+     tc_syn_rhs kind Nothing   = return (OpenSynTyCon kind Nothing)
+     tc_syn_rhs _    (Just ty) = do { rhs_ty <- tcIfaceType ty
+		   		    ; return (SynonymTyCon rhs_ty) }
+     tc_syn_fam Nothing 
+       = return Nothing
+     tc_syn_fam (Just (fam, tys)) 
+       = do { famTyCon <- tcIfaceTyCon fam
+      	    ; insttys <- mapM tcIfaceType tys
+       	    ; return $ Just (famTyCon, insttys) }
 
 tcIfaceDecl ignore_prags
 	    (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, 
@@ -505,6 +509,23 @@ tcIfaceEqSpec spec
                               ; return (tv,ty) }
 \end{code}
 
+Note [Synonym kind loop]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Notice that we eagerly grab the *kind* from the interface file, but
+build a forkM thunk for the *rhs* (and family stuff).  To see why, 
+consider this (Trac #2412)
+
+M.hs:       module M where { import X; data T = MkT S }
+X.hs:       module X where { import {-# SOURCE #-} M; type S = T }
+M.hs-boot:  module M where { data T }
+
+When kind-checking M.hs we need S's kind.  But we do not want to
+find S's kind from (typeKind S-rhs), because we don't want to look at
+S-rhs yet!  Since S is imported from X.hi, S gets just one chance to
+be defined, and we must not do that until we've finished with M.T.
+
+Solution: record S's kind in the interface file; now we can safely
+look at it.
 
 %************************************************************************
 %*									*