Commit 544926d7 authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Remove support for CTYPE pragmas on type synonyms

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