Fix tyConToIfaceDecl (Trac #9190)
authorSimon Peyton Jones <simonpj@microsoft.com>
Wed, 11 Jun 2014 14:09:55 +0000 (15:09 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Wed, 11 Jun 2014 19:56:37 +0000 (20:56 +0100)
There are three bugs here, one serious

 * We were failing to tidy the type arguments in an IfTyConParent
   This is what was causing Trac #9190.

 * toIfaceTcArgs is careful to suppress kind arguments, but there
   was a clone, tidyToIfaceTcArgs in IfaceSyn which didn't.
   Now the latter goes via the former.

 * When pretty-printing a IfaceDecl for an algebraic data type, and
   doing so in Haskell-98 syntax, we were silently assuming that the
   universal type variables of the TyCon and the DataCon were the
   same. But that has not been true for some time. Result: a very
   confusing display.

   Solution: during the conversion to IfaceSyn, take the opportunity
   to make the universal type variables line up exactly.  This is very
   easy to do, makes the pretty-printing easy, and leaves open the future
   possiblity of not serialising the universal type variables of the
   data constructor.

compiler/iface/MkIface.lhs
testsuite/tests/ghci/scripts/T4087.stdout
testsuite/tests/polykinds/T7438.stderr

index de99e98..2094c3b 100644 (file)
@@ -1534,7 +1534,7 @@ coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches
  = IfaceAxiom { ifName       = name
               , ifTyCon      = toIfaceTyCon tycon
               , ifRole       = role
-              , ifAxBranches = brListMap (coAxBranchToIfaceBranch
+              , ifAxBranches = brListMap (coAxBranchToIfaceBranch tycon
                                             (brListMap coAxBranchLHS branches))
                                          branches }
  where
@@ -1543,10 +1543,10 @@ coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches
 -- 2nd parameter is the list of branch LHSs, for conversion from incompatible branches
 -- to incompatible indices
 -- See Note [Storing compatibility] in CoAxiom
-coAxBranchToIfaceBranch :: [[Type]] -> CoAxBranch -> IfaceAxBranch
-coAxBranchToIfaceBranch lhs_s
+coAxBranchToIfaceBranch :: TyCon -> [[Type]] -> CoAxBranch -> IfaceAxBranch
+coAxBranchToIfaceBranch tc lhs_s
                         branch@(CoAxBranch { cab_incomps = incomps })
-  = (coAxBranchToIfaceBranch' branch) { ifaxbIncomps = iface_incomps }
+  = (coAxBranchToIfaceBranch' tc branch) { ifaxbIncomps = iface_incomps }
   where
     iface_incomps = map (expectJust "iface_incomps"
                         . (flip findIndex lhs_s
@@ -1554,11 +1554,11 @@ coAxBranchToIfaceBranch lhs_s
                         . coAxBranchLHS) incomps
 
 -- use this one for standalone branches without incompatibles
-coAxBranchToIfaceBranch' :: CoAxBranch -> IfaceAxBranch
-coAxBranchToIfaceBranch' (CoAxBranch { cab_tvs = tvs, cab_lhs = lhs
-                                     , cab_roles = roles, cab_rhs = rhs })
+coAxBranchToIfaceBranch' :: TyCon -> CoAxBranch -> IfaceAxBranch
+coAxBranchToIfaceBranch' tc (CoAxBranch { cab_tvs = tvs, cab_lhs = lhs
+                                        , cab_roles = roles, cab_rhs = rhs })
   = IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tv_bndrs
-                  , ifaxbLHS    = tidyToIfaceTcArgs env1 lhs
+                  , ifaxbLHS    = tidyToIfaceTcArgs env1 tc lhs
                   , ifaxbRoles  = roles
                   , ifaxbRHS    = tidyToIfaceType env1 rhs
                   , ifaxbIncomps = [] }
@@ -1577,17 +1577,17 @@ tyConToIfaceDecl env tycon
 
   | Just syn_rhs <- synTyConRhs_maybe tycon
   = IfaceSyn {  ifName    = getOccName tycon,
-                ifTyVars  = toIfaceTvBndrs tyvars,
+                ifTyVars  = if_tc_tyvars,
                 ifRoles   = tyConRoles tycon,
                 ifSynRhs  = to_ifsyn_rhs syn_rhs,
-                ifSynKind = tidyToIfaceType env1 (synTyConResKind tycon) }
+                ifSynKind = tidyToIfaceType tc_env1 (synTyConResKind tycon) }
 
   | isAlgTyCon tycon
   = IfaceData { ifName    = getOccName tycon,
                 ifCType   = tyConCType tycon,
-                ifTyVars  = toIfaceTvBndrs tyvars,
+                ifTyVars  = if_tc_tyvars,
                 ifRoles   = tyConRoles tycon,
-                ifCtxt    = tidyToIfaceContext env1 (tyConStupidTheta tycon),
+                ifCtxt    = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon),
                 ifCons    = ifaceConDecls (algTyConRhs tycon),
                 ifRec     = boolToRecFlag (isRecursiveTyCon tycon),
                 ifGadtSyntax = isGadtSyntaxTyCon tycon,
@@ -1611,26 +1611,27 @@ tyConToIfaceDecl env tycon
                 ifPromotable = False,
                 ifParent     = IfNoParent }
   where
-    (env1, tyvars) = tidyTyClTyVarBndrs env (tyConTyVars tycon)
+    (tc_env1, tc_tyvars) = tidyTyClTyVarBndrs env (tyConTyVars tycon)
+    if_tc_tyvars = toIfaceTvBndrs tc_tyvars
 
     funAndPrimTyVars = toIfaceTvBndrs $ take (tyConArity tycon) alphaTyVars
 
     parent = case tyConFamInstSig_maybe tycon of
                Just (tc, ty, ax) -> IfDataInstance (coAxiomName ax)
                                                    (toIfaceTyCon tc)
-                                                   (toIfaceTcArgs tc ty)
+                                                   (tidyToIfaceTcArgs tc_env1 tc ty)
                Nothing           -> IfNoParent
 
     to_ifsyn_rhs OpenSynFamilyTyCon        = IfaceOpenSynFamilyTyCon
     to_ifsyn_rhs (ClosedSynFamilyTyCon ax) = IfaceClosedSynFamilyTyCon axn ibr
       where defs = fromBranchList $ coAxiomBranches ax
-            ibr  = map coAxBranchToIfaceBranch' defs
+            ibr  = map (coAxBranchToIfaceBranch' tycon) defs
             axn  = coAxiomName ax
     to_ifsyn_rhs AbstractClosedSynFamilyTyCon
       = IfaceAbstractClosedSynFamilyTyCon
 
     to_ifsyn_rhs (SynonymTyCon ty)
-      = IfaceSynonymTyCon (tidyToIfaceType env1 ty)
+      = IfaceSynonymTyCon (tidyToIfaceType tc_env1 ty)
 
     to_ifsyn_rhs (BuiltInSynFamTyCon {})
       = IfaceBuiltInSynFamTyCon
@@ -1649,22 +1650,29 @@ tyConToIfaceDecl env tycon
         = IfCon   { ifConOcc     = getOccName (dataConName data_con),
                     ifConInfix   = dataConIsInfix data_con,
                     ifConWrapper = isJust (dataConWrapId_maybe data_con),
-                    ifConUnivTvs = toIfaceTvBndrs univ_tvs',
+                    ifConUnivTvs = if_tc_tyvars,
                     ifConExTvs   = toIfaceTvBndrs ex_tvs',
                     ifConEqSpec  = map to_eq_spec eq_spec,
-                    ifConCtxt    = tidyToIfaceContext env2 theta,
-                    ifConArgTys  = map (tidyToIfaceType env2) arg_tys,
+                    ifConCtxt    = tidyToIfaceContext con_env2 theta,
+                    ifConArgTys  = map (tidyToIfaceType con_env2) arg_tys,
                     ifConFields  = map getOccName
                                        (dataConFieldLabels data_con),
-                    ifConStricts = map (toIfaceBang env2) (dataConRepBangs data_con) }
+                    ifConStricts = map (toIfaceBang con_env2) (dataConRepBangs data_con) }
         where
           (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con
 
-          -- Start with 'emptyTidyEnv' not 'env1', because the type of the
-          -- data constructor is fully standalone
-          (env1, univ_tvs') = tidyTyVarBndrs emptyTidyEnv univ_tvs
-          (env2, ex_tvs')   = tidyTyVarBndrs env1 ex_tvs
-          to_eq_spec (tv,ty) = (toIfaceTyVar (tidyTyVar env2 tv), tidyToIfaceType env2 ty)
+          -- Tidy the univ_tvs of the data constructor to be identical
+          -- to the tyConTyVars of the type constructor.  This means
+          -- (a) we don't need to redundantly put them into the interface file
+          -- (b) when pretty-printing an Iface data declaration in H98-style syntax,
+          --     we know that the type variables will line up
+          -- The latter (b) is important because we pretty-print type construtors
+          -- by converting to IfaceSyn and pretty-printing that
+          con_env1 = (fst tc_env1, mkVarEnv (zipEqual "ifaceConDecl" univ_tvs tc_tyvars))
+                     -- A bit grimy, perhaps, but it's simple!
+
+          (con_env2, ex_tvs') = tidyTyVarBndrs con_env1 ex_tvs
+          to_eq_spec (tv,ty)  = (toIfaceTyVar (tidyTyVar con_env2 tv), tidyToIfaceType con_env2 ty)
 
 toIfaceBang :: TidyEnv -> HsBang -> IfaceBang
 toIfaceBang _    HsNoBang            = IfNoBang
@@ -1693,7 +1701,7 @@ classToIfaceDecl env clas
 
     toIfaceAT :: ClassATItem -> IfaceAT
     toIfaceAT (tc, defs)
-      = IfaceAT (tyConToIfaceDecl env1 tc) (map coAxBranchToIfaceBranch' defs)
+      = IfaceAT (tyConToIfaceDecl env1 tc) (map (coAxBranchToIfaceBranch' tc) defs)
 
     toIfaceClassOp (sel_id, def_meth)
         = ASSERT(sel_tyvars == clas_tyvars)
@@ -1719,11 +1727,8 @@ classToIfaceDecl env clas
 tidyToIfaceType :: TidyEnv -> Type -> IfaceType
 tidyToIfaceType env ty = toIfaceType (tidyType env ty)
 
-tidyToIfaceTcArgs :: TidyEnv -> [Type] -> IfaceTcArgs
-tidyToIfaceTcArgs _ [] = ITC_Nil
-tidyToIfaceTcArgs env (t:ts)
-  | isKind t  = ITC_Kind  (tidyToIfaceType env t) (tidyToIfaceTcArgs env ts)
-  | otherwise = ITC_Type  (tidyToIfaceType env t) (tidyToIfaceTcArgs env ts)
+tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceTcArgs
+tidyToIfaceTcArgs env tc tys = toIfaceTcArgs tc (tidyTypes env tys)
 
 tidyToIfaceContext :: TidyEnv -> ThetaType -> IfaceContext
 tidyToIfaceContext env theta = map (tidyToIfaceType env) theta
index 770a3e1..2ca08aa 100644 (file)
@@ -1,4 +1,4 @@
-type role Equal nominal nominal
-data Equal a b where
-  Equal :: Equal a1 a1
-       -- Defined at T4087.hs:5:1
+type role Equal nominal nominal\r
+data Equal a b where\r
+  Equal :: Equal b b\r
+       -- Defined at T4087.hs:5:1\r
index 509dcc4..b844655 100644 (file)
@@ -1,19 +1,19 @@
-
-T7438.hs:6:14:
-    Couldn't match expected type ‘t1’ with actual type ‘t’
-      ‘t’ is untouchable
-        inside the constraints (t2 ~ t3)
-        bound by a pattern with constructor
-                   Nil :: forall (k :: BOX) (a :: k). Thrist a a,
-                 in an equation for ‘go’
-        at T7438.hs:6:4-6
-      ‘t’ is a rigid type variable bound by
-          the inferred type of go :: Thrist t2 t3 -> t -> t1 at T7438.hs:6:1
-      ‘t1’ is a rigid type variable bound by
-           the inferred type of go :: Thrist t2 t3 -> t -> t1 at T7438.hs:6:1
-    Possible fix: add a type signature for ‘go’
-    Relevant bindings include
-      acc :: t (bound at T7438.hs:6:8)
-      go :: Thrist t2 t3 -> t -> t1 (bound at T7438.hs:6:1)
-    In the expression: acc
-    In an equation for ‘go’: go Nil acc = acc
+\r
+T7438.hs:6:14:\r
+    Couldn't match expected type ‘t1’ with actual type ‘t’\r
+      ‘t’ is untouchable\r
+        inside the constraints (t2 ~ t3)\r
+        bound by a pattern with constructor\r
+                   Nil :: forall (k :: BOX) (b :: k). Thrist b b,\r
+                 in an equation for ‘go’\r
+        at T7438.hs:6:4-6\r
+      ‘t’ is a rigid type variable bound by\r
+          the inferred type of go :: Thrist t2 t3 -> t -> t1 at T7438.hs:6:1\r
+      ‘t1’ is a rigid type variable bound by\r
+           the inferred type of go :: Thrist t2 t3 -> t -> t1 at T7438.hs:6:1\r
+    Possible fix: add a type signature for ‘go’\r
+    Relevant bindings include\r
+      acc :: t (bound at T7438.hs:6:8)\r
+      go :: Thrist t2 t3 -> t -> t1 (bound at T7438.hs:6:1)\r
+    In the expression: acc\r
+    In an equation for ‘go’: go Nil acc = acc\r