Remove support for CTYPE pragmas on type synonyms
authorIan Lynagh <igloo@earth.li>
Tue, 21 Feb 2012 23:03:41 +0000 (23:03 +0000)
committerIan Lynagh <igloo@earth.li>
Wed, 22 Feb 2012 01:46:33 +0000 (01:46 +0000)
It's not clear whether it's desirable or not, and it turns out that
the way we use coercions in GHC means we tend to lose information
about type synonyms.

14 files changed:
compiler/hsSyn/Convert.lhs
compiler/hsSyn/HsDecls.lhs
compiler/iface/BinIface.hs
compiler/iface/BuildTyCl.lhs
compiler/iface/IfaceSyn.lhs
compiler/iface/MkIface.lhs
compiler/iface/TcIface.lhs
compiler/parser/Parser.y.pp
compiler/parser/RdrHsSyn.lhs
compiler/rename/RnSource.lhs
compiler/typecheck/TcTyClsDecls.lhs
compiler/types/TyCon.lhs
compiler/vectorise/Vectorise/Type/Env.hs
docs/users_guide/ffi-chap.xml

index 0d7c960..068a9ee 100644 (file)
@@ -161,7 +161,7 @@ cvtDec (PragmaD prag)
 cvtDec (TySynD tc tvs rhs)
   = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
        ; rhs' <- cvtType rhs
-       ; returnL $ TyClD (TySynonym tc' Nothing tvs' Nothing rhs') }
+       ; returnL $ TyClD (TySynonym tc' tvs' Nothing rhs') }
 
 cvtDec (DataD ctxt tc tvs constrs derivs)
   = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
@@ -235,7 +235,7 @@ cvtDec (TySynInstD tc tys rhs)
   = do { (_, tc', tvs', tys') <- cvt_tyinst_hdr [] tc tys
        ; rhs' <- cvtType rhs
        ; returnL $ InstD $ FamInstDecl $ 
-                    TySynonym tc' Nothing tvs' tys' rhs' }
+                    TySynonym tc' tvs' tys' rhs' }
 
 ----------------
 cvt_ci_decs :: MsgDoc -> [TH.Dec]
index 142d53f..4d8c01d 100644 (file)
@@ -497,7 +497,6 @@ data TyClDecl name
     }
 
   | TySynonym { tcdLName  :: Located name,              -- ^ type constructor
-                tcdCType  :: Maybe CType,
                 tcdTyVars :: [LHsTyVarBndr name],       -- ^ type variables
                 tcdTyPats :: Maybe [LHsType name],      -- ^ Type patterns
                   -- See Note [tcdTyVars and tcdTyPats] 
index 1533bf1..13f9496 100644 (file)
@@ -1381,13 +1381,12 @@ instance Binary IfaceDecl where
         put_ bh a7
         put_ bh a8
 
-    put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do
+    put_ bh (IfaceSyn a1 a2 a3 a4) = do
         putByte bh 3
         put_ bh (occNameFS a1)
         put_ bh a2
         put_ bh a3
         put_ bh a4
-        put_ bh a5
 
     put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
         putByte bh 4
@@ -1430,9 +1429,8 @@ instance Binary IfaceDecl where
                     a2 <- get bh
                     a3 <- get bh
                     a4 <- get bh
-                    a5 <- get bh
                     occ <- return $! mkOccNameFS tcName a1
-                    return (IfaceSyn occ a2 a3 a4 a5)
+                    return (IfaceSyn occ a2 a3 a4)
             4 -> do a1 <- get bh
                     a2 <- get bh
                     a3 <- get bh
index 8e6f43a..4a93a2b 100644 (file)
@@ -46,13 +46,12 @@ import Outputable
 \begin{code}
 ------------------------------------------------------
 buildSynTyCon :: Name -> [TyVar] 
-              -> Maybe CType
               -> SynTyConRhs
               -> Kind                   -- ^ Kind of the RHS
               -> TyConParent
               -> TcRnIf m n TyCon
-buildSynTyCon tc_name tvs cType rhs rhs_kind parent 
-  = return (mkSynTyCon tc_name kind tvs cType rhs parent)
+buildSynTyCon tc_name tvs rhs rhs_kind parent 
+  = return (mkSynTyCon tc_name kind tvs rhs parent)
   where kind = mkPiKinds tvs rhs_kind
 
 ------------------------------------------------------
index 62b8234..44703d2 100644 (file)
@@ -80,7 +80,6 @@ data IfaceDecl
     }
 
   | IfaceSyn  { ifName    :: OccName,           -- Type constructor
-                ifCType   :: Maybe CType,       -- C type for CAPI FFI
                 ifTyVars  :: [IfaceTvBndr],     -- Type variables
                 ifSynKind :: IfaceKind,         -- Kind of the *rhs* (not of the tycon)
                 ifSynRhs  :: Maybe IfaceType    -- Just rhs for an ordinary synonyn
@@ -455,11 +454,11 @@ pprIfaceDecl (IfaceId {ifName = var, ifType = ty,
 pprIfaceDecl (IfaceForeign {ifName = tycon})
   = hsep [ptext (sLit "foreign import type dotnet"), ppr tycon]
 
-pprIfaceDecl (IfaceSyn {ifName = tycon, ifCType = cType,
+pprIfaceDecl (IfaceSyn {ifName = tycon,
                         ifTyVars = tyvars,
                         ifSynRhs = Just mono_ty})
   = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars)
-       4 (vcat [pprCType cType, equals <+> ppr mono_ty])
+       4 (vcat [equals <+> ppr mono_ty])
 
 pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
                         ifSynRhs = Nothing, ifSynKind = kind })
index 9290a68..32cb582 100644 (file)
@@ -1432,7 +1432,6 @@ tyThingToIfaceDecl (ATyCon tycon)
 
   | isSynTyCon tycon
   = IfaceSyn {  ifName    = getOccName tycon,
-                ifCType   = tyConCType tycon,
                 ifTyVars  = toIfaceTvBndrs tyvars,
                 ifSynRhs  = syn_rhs,
                 ifSynKind = syn_ki }
index 231481b..74902dd 100644 (file)
@@ -463,7 +463,6 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name,
            ; return (FamInstTyCon ax fam_tc (substTys subst fam_tys)) }
 
 tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, 
-                                  ifCType = cType,
                                   ifSynRhs = mb_rhs_ty,
                                   ifSynKind = kind })
    = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
@@ -471,7 +470,7 @@ tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
      ; rhs_kind <- tcIfaceType kind     -- Note [Synonym kind loop]
      ; rhs      <- forkM (mk_doc tc_name) $ 
                    tc_syn_rhs mb_rhs_ty
-     ; tycon    <- buildSynTyCon tc_name tyvars cType rhs rhs_kind parent
+     ; tycon    <- buildSynTyCon tc_name tyvars rhs rhs_kind parent
      ; return (ATyCon tycon) }
    where
      mk_doc n = ptext (sLit "Type syonym") <+> ppr n
index 62fdedd..ff98b74 100644 (file)
@@ -609,7 +609,7 @@ cl_decl :: { LTyClDecl RdrName }
 --
 ty_decl :: { LTyClDecl RdrName }
            -- ordinary type synonyms
-        : 'type' capi_ctype type '=' ctypedoc
+        : 'type' type '=' ctypedoc
                 -- Note ctype, not sigtype, on the right of '='
                 -- We allow an explicit for-all but we don't insert one
                 -- in   type Foo a = (b,b)
@@ -617,7 +617,7 @@ ty_decl :: { LTyClDecl RdrName }
                 --
                 -- Note the use of type for the head; this allows
                 -- infix type constructors to be declared 
-                {% mkTySynonym (comb2 $1 $5) False $2 $3 $5 }
+                {% mkTySynonym (comb2 $1 $4) False $2 $4 }
 
            -- type family declarations
         | 'type' 'family' type opt_kind_sig 
@@ -651,10 +651,10 @@ inst_decl :: { LInstDecl RdrName }
                    in L (comb3 $1 $2 $3) (ClsInstDecl $2 binds sigs ats) }
 
            -- type instance declarations
-        | 'type' 'instance' capi_ctype type '=' ctype
+        | 'type' 'instance' type '=' ctype
                 -- Note the use of type for the head; this allows
                 -- infix type constructors and type patterns
-                {% do { L loc d <- mkTySynonym (comb2 $1 $6) True $3 $4 $6
+                {% do { L loc d <- mkTySynonym (comb2 $1 $5) True $3 $5
                       ; return (L loc (FamInstDecl d)) } }
 
           -- data/newtype instance declaration
@@ -682,19 +682,16 @@ inst_decl :: { LInstDecl RdrName }
 --
 at_decl_cls :: { LTyClDecl RdrName }
            -- type family declarations
-        : 'type' capi_ctype type opt_kind_sig
+        : 'type' type opt_kind_sig
                 -- Note the use of type for the head; this allows
                 -- infix type constructors to be declared.
-                -- Note that we ignore the capi_ctype for now, but
-                -- we need it in the grammar or we get loads of
-                -- extra shift/reduce conflicts and parsing goes wrong.
-                {% mkTyFamily (comb3 $1 $3 $4) TypeFamily $3 (unLoc $4) }
+                {% mkTyFamily (comb3 $1 $2 $3) TypeFamily $2 (unLoc $3) }
 
            -- default type instance
-        | 'type' capi_ctype type '=' ctype
+        | 'type' type '=' ctype
                 -- Note the use of type for the head; this allows
                 -- infix type constructors and type patterns
-                {% mkTySynonym (comb2 $1 $5) True $2 $3 $5 }
+                {% mkTySynonym (comb2 $1 $4) True $2 $4 }
 
           -- data/newtype family declaration
         | 'data' type opt_kind_sig
@@ -704,10 +701,10 @@ at_decl_cls :: { LTyClDecl RdrName }
 --
 at_decl_inst :: { LTyClDecl RdrName }
            -- type instance declarations
-        : 'type' capi_ctype type '=' ctype
+        : 'type' type '=' ctype
                 -- Note the use of type for the head; this allows
                 -- infix type constructors and type patterns
-                {% mkTySynonym (comb2 $1 $5) True $2 $3 $5 }
+                {% mkTySynonym (comb2 $1 $4) True $2 $4 }
 
         -- data/newtype instance declaration
         | data_or_newtype capi_ctype tycl_hdr constrs deriving
index 890c379..c20ce1a 100644 (file)
@@ -212,14 +212,13 @@ mkTyData loc new_or_data is_family cType (L _ (mcxt, tycl_hdr)) ksig data_cons m
 
 mkTySynonym :: SrcSpan
             -> Bool             -- True <=> type family instances
-            -> Maybe CType
             -> LHsType RdrName  -- LHS
             -> LHsType RdrName  -- RHS
             -> P (LTyClDecl RdrName)
-mkTySynonym loc is_family cType lhs rhs
+mkTySynonym loc is_family lhs rhs
   = do { (tc, tparams) <- checkTyClHdr lhs
        ; (tyvars, typats) <- checkTParams is_family lhs tparams
-       ; return (L loc (TySynonym tc cType tyvars typats rhs)) }
+       ; return (L loc (TySynonym tc tyvars typats rhs)) }
 
 mkTyFamily :: SrcSpan
            -> FamilyFlavour
index 0ebda54..e747b85 100644 (file)
@@ -851,7 +851,7 @@ rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCType = cType,
                             ; return (Just ds', extractHsTyNames_s ds') }
 
 -- "type" and "type instance" declarations
-rnTyClDecl mb_cls tydecl@(TySynonym { tcdTyVars = tyvars, tcdCType = cType,
+rnTyClDecl mb_cls tydecl@(TySynonym { tcdTyVars = tyvars,
                           tcdLName = name,
                                      tcdTyPats = typats, tcdSynRhs = ty})
   = bindQTvs syn_doc mb_cls tyvars $ \ tyvars' -> do
@@ -859,7 +859,7 @@ rnTyClDecl mb_cls tydecl@(TySynonym { tcdTyVars = tyvars, tcdCType = cType,
       name' <- lookupTcdName mb_cls tydecl
     ; (typats',fvs1) <- rnTyPats syn_doc name' typats
     ; (ty', fvs2)    <- rnHsTypeFVs syn_doc ty
-    ; return (TySynonym { tcdLName = name', tcdCType = cType
+    ; return (TySynonym { tcdLName = name'
                 , tcdTyVars = tyvars'
                        , tcdTyPats = typats', tcdSynRhs = ty'}
              , extractHsTyVarBndrNames_s tyvars' (fvs1 `plusFV` fvs2)) }
index 7829d1b..d02f0a8 100644 (file)
@@ -560,7 +560,7 @@ tcTyClDecl1 parent _calc_isrec
   = tcTyClTyVars tc_name tvs $ \ tvs' kind -> do
   { traceTc "type family:" (ppr tc_name)
   ; checkFamFlag tc_name
-  ; tycon <- buildSynTyCon tc_name tvs' Nothing SynFamilyTyCon kind parent
+  ; tycon <- buildSynTyCon tc_name tvs' SynFamilyTyCon kind parent
   ; return [ATyCon tycon] }
 
   -- "data family" declaration
@@ -577,11 +577,11 @@ tcTyClDecl1 parent _calc_isrec
 
   -- "type" synonym declaration
 tcTyClDecl1 _parent _calc_isrec
-            (TySynonym {tcdLName = L _ tc_name, tcdCType = cType, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
+            (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
   = ASSERT( isNoParent _parent )
     tcTyClTyVars tc_name tvs $ \ tvs' kind -> do
     { rhs_ty' <- tcCheckHsType rhs_ty kind
-    ; tycon <- buildSynTyCon tc_name tvs' cType (SynonymTyCon rhs_ty')
+    ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty')
                  kind NoParentTyCon
     ; return [ATyCon tycon] }
 
index 18504d1..0543092 100644 (file)
@@ -360,9 +360,6 @@ data TyCon
         tyConArity   :: Arity,
 
         tyConTyVars  :: [TyVar],        -- Bound tyvars
-        tyConCType   :: Maybe CType,    -- The C type that should be used
-                                        -- for this type when using the FFI
-                                        -- and CAPI
 
         synTcRhs     :: SynTyConRhs,    -- ^ Contains information about the
                                         -- expansion of the synonym
@@ -934,15 +931,14 @@ mkPrimTyCon' name kind arity rep is_unlifted
     }
 
 -- | Create a type synonym 'TyCon'
-mkSynTyCon :: Name -> Kind -> [TyVar] -> Maybe CType -> SynTyConRhs -> TyConParent -> TyCon
-mkSynTyCon name kind tyvars cType rhs parent
+mkSynTyCon :: Name -> Kind -> [TyVar] -> SynTyConRhs -> TyConParent -> TyCon
+mkSynTyCon name kind tyvars rhs parent
   = SynTyCon {
         tyConName = name,
         tyConUnique = nameUnique name,
         tc_kind = kind,
         tyConArity = length tyvars,
         tyConTyVars = tyvars,
-        tyConCType = cType,
         synTcRhs = rhs,
         synTcParent = parent
     }
@@ -1232,7 +1228,6 @@ isImplicitTyCon tycon
 
 tyConCType_maybe :: TyCon -> Maybe CType
 tyConCType_maybe tc@(AlgTyCon {}) = tyConCType tc
-tyConCType_maybe tc@(SynTyCon {}) = tyConCType tc
 tyConCType_maybe _ = Nothing
 \end{code}
 
index dd4b923..0051d07 100644 (file)
@@ -326,7 +326,7 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls
         origName  = tyConName origTyCon
         vectName  = tyConName vectTyCon
 
-        mkSyn canonName ty = mkSynTyCon canonName (typeKind ty) [] Nothing (SynonymTyCon ty) NoParentTyCon
+        mkSyn canonName ty = mkSynTyCon canonName (typeKind ty) [] (SynonymTyCon ty) NoParentTyCon
         
         defDataCons
           | isAbstract = return ()
index bf378bf..b5ae0e0 100644 (file)
@@ -191,7 +191,6 @@ foreign import capi
 <programlisting>
 data    {-# CTYPE "unistd.h" "useconds_t" #-} T = ...
 newtype {-# CTYPE            "useconds_t" #-} T = ...
-type    {-# CTYPE "unistd.h" "useconds_t" #-} T = ...
 </programlisting>
         </para>
       </sect2>