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

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)
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]
......
......@@ -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]
......
......@@ -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
......
......@@ -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
------------------------------------------------------
......
......@@ -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 })
......
......@@ -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 }
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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)) }
......
......@@ -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] }
......
......@@ -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}
......
......@@ -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 ()
......
......@@ -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>
......
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