[commit: ghc] data-kind-syntax: Add IfacePromotionInfo (4174458)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : data-kind-syntax
Link       : http://ghc.haskell.org/trac/ghc/changeset/4174458178cf484b15874ac8656e41fe35be46f3/ghc

>---------------------------------------------------------------

commit 4174458178cf484b15874ac8656e41fe35be46f3
Author: Trevor Elliott <trevor at galois.com>
Date:   Sun Sep 8 18:25:48 2013 -0700

    Add IfacePromotionInfo
    
     * Remove the orphan instance for PromotionInfo from types/TyCon.lhs


>---------------------------------------------------------------

4174458178cf484b15874ac8656e41fe35be46f3
 compiler/iface/IfaceSyn.lhs |   29 +++++++++++++++++------------
 compiler/iface/MkIface.lhs  |    9 ++++++++-
 compiler/iface/TcIface.lhs  |    9 ++++++++-
 3 files changed, 33 insertions(+), 14 deletions(-)

diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index ca772ac..5fd3e02 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -23,6 +23,7 @@ module IfaceSyn (
         IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
         IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..), 
         IfaceBang(..), IfaceAxBranch(..),
+        IfacePromotionInfo(..),
 
         -- Misc
         ifaceDeclImplicitBndrs, visibleIfConDecls,
@@ -37,7 +38,6 @@ module IfaceSyn (
 
 #include "HsVersions.h"
 
-import TyCon( PromotionInfo(..) )
 import IfaceType
 import PprCore()            -- Printing DFunArgs
 import Demand
@@ -91,7 +91,7 @@ data IfaceDecl
                 ifCtxt       :: IfaceContext,   -- The "stupid theta"
                 ifCons       :: IfaceConDecls,  -- Includes new/data/data family info
                 ifRec        :: RecFlag,        -- Recursive or not?
-                ifPromotable :: PromotionInfo (),-- Promotable to kind level?
+                ifPromotable :: IfacePromotionInfo,-- Promotable to kind level?
                 ifGadtSyntax :: Bool,           -- True <=> declared using
                                                 -- GADT syntax
                 ifAxiom      :: Maybe IfExtName -- The axiom, for a newtype, 
@@ -242,17 +242,22 @@ instance Binary IfaceDecl where
                     return (IfaceDataKind occ a2 a3 a4)
             _ -> error ("Binary.get(TyClDecl): Unknown tag " ++ show h)
 
-instance Binary (PromotionInfo ()) where
+data IfacePromotionInfo
+  = IfaceNeverPromote
+  | IfaceNotPromotable
+  | IfacePromotable
+
+instance Binary IfacePromotionInfo where
   put_ bh p = case p of
-    NeverPromote  -> putByte bh 0x0
-    NotPromotable -> putByte bh 0x1
-    Promotable () -> putByte bh 0x2
+    IfaceNeverPromote  -> putByte bh 0x0
+    IfaceNotPromotable -> putByte bh 0x1
+    IfacePromotable    -> putByte bh 0x2
   get bh = do
     tag <- getByte bh
     case tag of
-      0x0 -> return NeverPromote
-      0x1 -> return NotPromotable
-      0x2 -> return (Promotable ())
+      0x0 -> return IfaceNeverPromote
+      0x1 -> return IfaceNotPromotable
+      0x2 -> return IfacePromotable
       _   -> error ("Binary.get(Promotable ()): Unknown tag " ++ show tag)
 
 data IfaceSynTyConRhs
@@ -1105,9 +1110,9 @@ pprIfaceDecl (IfaceData {ifName = tycon, ifCType = cType,
                , pprAxiom mbAxiom])
   where
     pp_prom = case is_prom of
-      NeverPromote  -> ptext (sLit "Never promotable")
-      NotPromotable -> ptext (sLit "Not promotable")
-      Promotable () -> ptext (sLit "Promotable")
+      IfaceNeverPromote  -> ptext (sLit "Never promotable")
+      IfaceNotPromotable -> ptext (sLit "Not promotable")
+      IfacePromotable    -> ptext (sLit "Promotable")
 
     pp_nd = case condecls of
                 IfAbstractTyCon dis -> ptext (sLit "abstract") <> parens (ppr dis)
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index 3fff2b8..ed96a53 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -1514,7 +1514,8 @@ tyConToIfaceDecl env tycon
                 ifCons    = ifaceConDecls (algTyConRhs tycon),
                 ifRec     = boolToRecFlag (isRecursiveTyCon tycon),
                 ifGadtSyntax = isGadtSyntaxTyCon tycon,
-                ifPromotable = fmap (\_ -> ()) (promotableTyConInfo tycon),
+                ifPromotable = toIfacePromotionInfo
+                             $ fmap (\_ -> ()) (promotableTyConInfo tycon),
                 ifAxiom   = fmap coAxiomName (tyConFamilyCoercion_maybe tycon) }
 
   | isForeignTyCon tycon
@@ -1571,6 +1572,12 @@ tyConToIfaceDecl env tycon
         where
           (args,_) = splitFunTys (tyConKind ty_con)
 
+toIfacePromotionInfo :: PromotionInfo () -> IfacePromotionInfo
+toIfacePromotionInfo pi = case pi of
+  NeverPromote  -> IfaceNeverPromote
+  NotPromotable -> IfaceNotPromotable
+  Promotable () -> IfacePromotable
+
 toIfaceBang :: TidyEnv -> HsBang -> IfaceBang
 toIfaceBang _    HsNoBang            = IfNoBang
 toIfaceBang _   (HsUnpack Nothing)   = IfUnpack
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 2d18a74..6c37654 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -473,10 +473,17 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name,
             ; parent' <- tc_parent tyvars mb_axiom_name
             ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
             ; return (buildAlgTyCon tc_name tyvars roles cType stupid_theta 
-                                    cons is_rec is_prom gadt_syn parent') }
+                                    cons is_rec is_prom' gadt_syn parent') }
     ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
     ; return (ATyCon tycon) }
   where
+
+    is_prom' :: PromotionInfo ()
+    is_prom'  = case is_prom of
+      IfaceNeverPromote  -> NeverPromote
+      IfaceNotPromotable -> NotPromotable
+      IfacePromotable    -> Promotable ()
+
     tc_parent :: [TyVar] -> Maybe Name -> IfL TyConParent
     tc_parent _ Nothing = return parent
     tc_parent tyvars (Just ax_name)