Implement the CTYPE pragma; part of the CApiFFI extension

For now, the syntax is
    type    {-# CTYPE "some C type" #-} Foo = ...
    newtype {-# CTYPE "some C type" #-} Foo = ...
    data    {-# CTYPE "some C type" #-} Foo = ...

compiler/deSugar/DsForeign.lhs

@@ -11,6 +11,8 @@ module DsForeign ( dsForeigns ) where
 #include "HsVersions.h"
 import TcRnMonad        -- temp
 
+import TypeRep
+
 import CoreSyn
 
 import DsCCall
@@ -227,12 +229,12 @@ dsFCall fn_id co fcall headerFilename = do
                                    Nothing                 -> io_res_ty
                       isVoidRes = raw_res_ty `eqType` unitTy
                       cResType | isVoidRes = text "void"
-                               | otherwise = showStgType raw_res_ty
+                               | otherwise = toCType raw_res_ty
                       pprCconv = ccallConvAttribute CApiConv
                       argTypes
                        | null arg_tys = text "void"
                        | otherwise = hsep $ punctuate comma
-                                         [ showStgType t <+> char 'a' <> int n
+                                         [ toCType t <+> char 'a' <> int n
                                          | (t, n) <- zip arg_tys [1..] ]
                       argVals = hsep $ punctuate comma
                                     [ char 'a' <> int n
@@ -496,7 +498,7 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
                 SDoc,           -- C type
                 Type,           -- Haskell type
                 CmmType)]       -- the CmmType
-  arg_info  = [ let stg_type = showStgType ty in
+  arg_info  = [ let stg_type = toCType ty in
                 (arg_cname n stg_type,
                  stg_type,
                  ty,
@@ -533,7 +535,7 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
   res_hty_is_unit = res_hty `eqType` unitTy     -- Look through any newtypes
 
   cResType | res_hty_is_unit = text "void"
-           | otherwise       = showStgType res_hty
+           | otherwise       = toCType res_hty
 
   -- when the return type is integral and word-sized or smaller, it
   -- must be assigned as type ffi_arg (#3516).  To see what type
@@ -661,12 +663,34 @@ mkHObj t = text "rts_mk" <> text (showFFIType t)
 unpackHObj :: Type -> SDoc
 unpackHObj t = text "rts_get" <> text (showFFIType t)
 
-showStgType :: Type -> SDoc
-showStgType t = text "Hs" <> text (showFFIType t)
-
 showFFIType :: Type -> String
 showFFIType t = getOccString (getName (typeTyCon t))
 
+toCType :: Type -> SDoc
+toCType = f False
+    where f voidOK t
+           -- First, if we have (Ptr t), then we need to convert t to a
+           -- C type and put a * after it.
+           | Just (ptr, [t']) <- splitTyConApp_maybe t
+           , tyConName ptr == ptrTyConName
+              = f True t' <> char '*'
+           -- Otherwise, if we have a type constructor application, then
+           -- see if there is a C type associated with that constructor.
+           -- Note that we aren't looking through type synonyms or
+           -- anything, as it may be the synonym that is annotated.
+           | TyConApp tycon _ <- t
+           , Just (CType cType) <- tyConCType_maybe tycon
+              = ftext cType
+           -- If we don't know a C type for this type, then try looking
+           -- through one layer of type synonym etc.
+           | Just t' <- coreView t
+              = f voidOK t'
+           -- Otherwise we don't know the C type. If we are allowing
+           -- void then return that; otherwise something has gone wrong.
+           | voidOK = ptext (sLit "void")
+           | otherwise
+              = pprPanic "toCType" (ppr t)
+
 typeTyCon :: Type -> TyCon
 typeTyCon ty = case tcSplitTyConApp_maybe (repType ty) of
                  Just (tc,_) -> tc

compiler/hsSyn/Convert.lhs

@@ -161,13 +161,14 @@ cvtDec (PragmaD prag)
 cvtDec (TySynD tc tvs rhs)
   = do	{ (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
 	; rhs' <- cvtType rhs
-	; returnL $ TyClD (TySynonym tc' tvs' Nothing rhs') }
+	; returnL $ TyClD (TySynonym tc' Nothing tvs' Nothing rhs') }
 
 cvtDec (DataD ctxt tc tvs constrs derivs)
   = do	{ (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
 	; cons' <- mapM cvtConstr constrs
 	; derivs' <- cvtDerivs derivs
-	; returnL $ TyClD (TyData { tcdND = DataType, tcdLName = tc', tcdCtxt = ctxt'
+	; returnL $ TyClD (TyData { tcdND = DataType, tcdCType = Nothing
+                                  , tcdLName = tc', tcdCtxt = ctxt'
                                   , tcdTyVars = tvs', tcdTyPats = Nothing, tcdKindSig = Nothing
                                   , tcdCons = cons', tcdDerivs = derivs' }) }
 
@@ -175,7 +176,8 @@ cvtDec (NewtypeD ctxt tc tvs constr derivs)
   = do	{ (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
 	; con' <- cvtConstr constr
 	; derivs' <- cvtDerivs derivs
-	; returnL $ TyClD (TyData { tcdND = NewType, tcdLName = tc', tcdCtxt = ctxt'
+	; returnL $ TyClD (TyData { tcdND = NewType, tcdCType = Nothing
+                                  , tcdLName = tc', tcdCtxt = ctxt'
 	  	    	  	  , tcdTyVars = tvs', tcdTyPats = Nothing, tcdKindSig = Nothing
                                   , tcdCons = [con'], tcdDerivs = derivs'}) }
 
@@ -214,7 +216,8 @@ cvtDec (DataInstD ctxt tc tys constrs derivs)
        ; cons' <- mapM cvtConstr constrs
        ; derivs' <- cvtDerivs derivs
        ; returnL $ InstD $ FamInstDecl $
-                   TyData { tcdND = DataType, tcdLName = tc', tcdCtxt = ctxt'
+                   TyData { tcdND = DataType, tcdCType = Nothing
+                          , tcdLName = tc', tcdCtxt = ctxt'
                           , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing
                           , tcdCons = cons', tcdDerivs = derivs' } }
 
@@ -223,7 +226,8 @@ cvtDec (NewtypeInstD ctxt tc tys constr derivs)
        ; con' <- cvtConstr constr
        ; derivs' <- cvtDerivs derivs
        ; returnL $ InstD $ FamInstDecl $
-                   TyData { tcdND = NewType, tcdLName = tc', tcdCtxt = ctxt'
+                   TyData { tcdND = NewType, tcdCType = Nothing
+                          , tcdLName = tc', tcdCtxt = ctxt'
                           , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing
                           , tcdCons = [con'], tcdDerivs = derivs' } }
 
@@ -231,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' tvs' tys' rhs' }
+                    TySynonym tc' Nothing tvs' tys' rhs' }
 
 ----------------
 cvt_ci_decs :: MsgDoc -> [TH.Dec]

compiler/hsSyn/HsDecls.lhs

@@ -465,6 +465,7 @@ data TyClDecl name
                 tcdCtxt   :: LHsContext name,           -- ^ Context
                 tcdLName  :: Located name,              -- ^ Type constructor
 
+                tcdCType  :: Maybe CType,
                 tcdTyVars :: [LHsTyVarBndr name],       -- ^ Type variables
                 tcdTyPats :: Maybe [LHsType name],      -- ^ Type patterns.
                   -- See Note [tcdTyVars and tcdTyPats] 
@@ -496,6 +497,7 @@ 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] 

compiler/iface/BinIface.hs

@@ -1370,7 +1370,7 @@ instance Binary IfaceDecl where
     put_ _ (IfaceForeign _ _) = 
         error "Binary.put_(IfaceDecl): IfaceForeign"
 
-    put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7) = do
+    put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
         putByte bh 2
         put_ bh (occNameFS a1)
         put_ bh a2
@@ -1379,13 +1379,15 @@ instance Binary IfaceDecl where
         put_ bh a5
         put_ bh a6
         put_ bh a7
+        put_ bh a8
 
-    put_ bh (IfaceSyn a1 a2 a3 a4) = do
+    put_ bh (IfaceSyn a1 a2 a3 a4 a5) = 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
@@ -1421,14 +1423,16 @@ instance Binary IfaceDecl where
                     a5 <- get bh
                     a6 <- get bh
                     a7 <- get bh
+                    a8 <- get bh
                     occ <- return $! mkOccNameFS tcName a1
-                    return (IfaceData occ a2 a3 a4 a5 a6 a7)
+                    return (IfaceData occ a2 a3 a4 a5 a6 a7 a8)
             3 -> do a1 <- get bh
                     a2 <- get bh
                     a3 <- get bh
                     a4 <- get bh
+                    a5 <- get bh
                     occ <- return $! mkOccNameFS tcName a1
-                    return (IfaceSyn occ a2 a3 a4)
+                    return (IfaceSyn occ a2 a3 a4 a5)
             4 -> do a1 <- get bh
                     a2 <- get bh
                     a3 <- get bh

compiler/iface/BuildTyCl.lhs

@@ -29,6 +29,7 @@ import DataCon
 import Var
 import VarSet
 import BasicTypes
+import ForeignCall
 import Name
 import MkId
 import Class
@@ -45,17 +46,19 @@ import Outputable
 \begin{code}
 ------------------------------------------------------
 buildSynTyCon :: Name -> [TyVar] 
+              -> Maybe CType
               -> SynTyConRhs
               -> Kind                   -- ^ Kind of the RHS
               -> TyConParent
               -> TcRnIf m n TyCon
-buildSynTyCon tc_name tvs rhs rhs_kind parent 
-  = return (mkSynTyCon tc_name kind tvs rhs parent)
+buildSynTyCon tc_name tvs cType rhs rhs_kind parent 
+  = return (mkSynTyCon tc_name kind tvs cType rhs parent)
   where kind = mkPiKinds tvs rhs_kind
 
 ------------------------------------------------------
 buildAlgTyCon :: Name 
               -> [TyVar]               -- ^ Kind variables and type variables
+	      -> Maybe CType
 	      -> ThetaType	       -- ^ Stupid theta
 	      -> AlgTyConRhs
 	      -> RecFlag
@@ -63,8 +66,8 @@ buildAlgTyCon :: Name
               -> TyConParent
 	      -> TyCon
 
-buildAlgTyCon tc_name ktvs stupid_theta rhs is_rec gadt_syn parent
-  = mkAlgTyCon tc_name kind ktvs stupid_theta rhs parent is_rec gadt_syn
+buildAlgTyCon tc_name ktvs cType stupid_theta rhs is_rec gadt_syn parent
+  = mkAlgTyCon tc_name kind ktvs cType stupid_theta rhs parent is_rec gadt_syn
   where 
     kind = mkPiKinds ktvs liftedTypeKind
 

compiler/iface/IfaceSyn.lhs

@@ -68,6 +68,7 @@ data IfaceDecl
               ifIdInfo    :: IfaceIdInfo }
 
   | IfaceData { ifName       :: OccName,        -- Type constructor
+                ifCType      :: Maybe CType,    -- C type for CAPI FFI
                 ifTyVars     :: [IfaceTvBndr],  -- Type variables
                 ifCtxt       :: IfaceContext,   -- The "stupid theta"
                 ifCons       :: IfaceConDecls,  -- Includes new/data/data family info
@@ -79,6 +80,7 @@ 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

compiler/iface/MkIface.lhs

@@ -1432,12 +1432,14 @@ tyThingToIfaceDecl (ATyCon tycon)
 
   | isSynTyCon tycon
   = IfaceSyn {  ifName    = getOccName tycon,
+                ifCType   = tyConCType tycon,
                 ifTyVars  = toIfaceTvBndrs tyvars,
                 ifSynRhs  = syn_rhs,
                 ifSynKind = syn_ki }
 
   | isAlgTyCon tycon
   = IfaceData { ifName    = getOccName tycon,
+                ifCType   = tyConCType tycon,
                 ifTyVars  = toIfaceTvBndrs tyvars,
                 ifCtxt    = toIfaceContext (tyConStupidTheta tycon),
                 ifCons    = ifaceConDecls (algTyConRhs tycon),

compiler/iface/TcIface.lhs

@@ -432,6 +432,7 @@ tc_iface_decl _ ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type,
         ; return (AnId (mkGlobalId details name ty info)) }
 
 tc_iface_decl parent _ (IfaceData {ifName = occ_name, 
+                          ifCType = cType, 
                           ifTyVars = tv_bndrs, 
                           ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
                           ifCons = rdr_cons, 
@@ -443,7 +444,7 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name,
             { stupid_theta <- tcIfaceCtxt ctxt
             ; parent' <- tc_parent tyvars mb_axiom_name
             ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
-            ; return (buildAlgTyCon tc_name tyvars stupid_theta 
+            ; return (buildAlgTyCon tc_name tyvars cType stupid_theta 
                                     cons is_rec gadt_syn parent') }
     ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
     ; return (ATyCon tycon) }
@@ -462,6 +463,7 @@ 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
@@ -469,7 +471,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 rhs rhs_kind parent
+     ; tycon    <- buildSynTyCon tc_name tyvars cType rhs rhs_kind parent
      ; return (ATyCon tycon) }
    where
      mk_doc n = ptext (sLit "Type syonym") <+> ppr n

compiler/parser/Lexer.x

@@ -487,6 +487,7 @@ data Token
   | ITvect_prag
   | ITvect_scalar_prag
   | ITnovect_prag
+  | ITctype
 
   | ITdotdot                    -- reserved symbols
   | ITcolon
@@ -2287,7 +2288,8 @@ oneWordPrags = Map.fromList([("rules", rulePrag),
                            ("nounpack", token ITnounpack_prag),
                            ("ann", token ITann_prag),
                            ("vectorize", token ITvect_prag),
-                           ("novectorize", token ITnovect_prag)])
+                           ("novectorize", token ITnovect_prag),
+                           ("ctype", token ITctype)])
 
 twoWordPrags = Map.fromList([("inline conlike", token (ITinline_prag Inline ConLike)),
                              ("notinline conlike", token (ITinline_prag NoInline ConLike)),

compiler/parser/Parser.y.pp

@@ -38,9 +38,7 @@ import TysWiredIn       ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataC
                           unboxedUnitTyCon, unboxedUnitDataCon,
                           listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR, eqTyCon_RDR )
 import Type             ( funTyCon )
-import ForeignCall      ( Safety(..), CExportSpec(..), CLabelString,
-                          CCallConv(..), CCallTarget(..), defaultCCallConv
-                        )
+import ForeignCall
 import OccName          ( varName, dataName, tcClsName, tvName )
 import DataCon          ( DataCon, dataConName )
 import SrcLoc
@@ -269,6 +267,7 @@ incorrect.
  '{-# VECTORISE'          { L _ ITvect_prag }
  '{-# VECTORISE_SCALAR'   { L _ ITvect_scalar_prag }
  '{-# NOVECTORISE'        { L _ ITnovect_prag }
+ '{-# CTYPE'              { L _ ITctype }
  '#-}'                                          { L _ ITclose_prag }
 
  '..'           { L _ ITdotdot }                        -- reserved symbols
@@ -610,7 +609,7 @@ cl_decl :: { LTyClDecl RdrName }
 --
 ty_decl :: { LTyClDecl RdrName }
            -- ordinary type synonyms
-        : 'type' type '=' ctypedoc
+        : 'type' capi_ctype 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)
@@ -618,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 $4) False $2 $4 }
+                {% mkTySynonym (comb2 $1 $5) False $2 $3 $5 }
 
            -- type family declarations
         | 'type' 'family' type opt_kind_sig 
@@ -627,18 +626,18 @@ ty_decl :: { LTyClDecl RdrName }
                 {% mkTyFamily (comb3 $1 $3 $4) TypeFamily $3 (unLoc $4) }
 
           -- ordinary data type or newtype declaration
-        | data_or_newtype tycl_hdr constrs deriving
-                {% mkTyData (comb4 $1 $2 $3 $4) (unLoc $1) False $2 
-                            Nothing (reverse (unLoc $3)) (unLoc $4) }
+        | data_or_newtype capi_ctype tycl_hdr constrs deriving
+                {% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) False $2 $3 
+                            Nothing (reverse (unLoc $4)) (unLoc $5) }
                                    -- We need the location on tycl_hdr in case 
                                    -- constrs and deriving are both empty
 
           -- ordinary GADT declaration
-        | data_or_newtype tycl_hdr opt_kind_sig 
+        | data_or_newtype capi_ctype tycl_hdr opt_kind_sig 
                  gadt_constrlist
                  deriving
-                {% mkTyData (comb4 $1 $2 $4 $5) (unLoc $1) False $2 
-                            (unLoc $3) (unLoc $4) (unLoc $5) }
+                {% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) False $2 $3 
+                            (unLoc $4) (unLoc $5) (unLoc $6) }
                                    -- We need the location on tycl_hdr in case 
                                    -- constrs and deriving are both empty
 
@@ -652,15 +651,15 @@ inst_decl :: { LInstDecl RdrName }
                    in L (comb3 $1 $2 $3) (ClsInstDecl $2 binds sigs ats) }
 
            -- type instance declarations
-        | 'type' 'instance' type '=' ctype
+        | 'type' 'instance' capi_ctype 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 $5) True $3 $5
+                {% do { L loc d <- mkTySynonym (comb2 $1 $6) True $3 $4 $6
                       ; return (L loc (FamInstDecl d)) } }
 
           -- data/newtype instance declaration
         | data_or_newtype 'instance' tycl_hdr constrs deriving
-                {% do { L loc d <- mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) True $3
+                {% do { L loc d <- mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) True Nothing $3
                                       Nothing (reverse (unLoc $4)) (unLoc $5)
                       ; return (L loc (FamInstDecl d)) } }
 
@@ -668,7 +667,7 @@ inst_decl :: { LInstDecl RdrName }
         | data_or_newtype 'instance' tycl_hdr opt_kind_sig 
                  gadt_constrlist
                  deriving
-                {% do { L loc d <- mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) True $3
+                {% do { L loc d <- mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) True Nothing $3
                                             (unLoc $4) (unLoc $5) (unLoc $6)
                       ; return (L loc (FamInstDecl d)) } }
         
@@ -689,10 +688,10 @@ at_decl_cls :: { LTyClDecl RdrName }
                 {% mkTyFamily (comb3 $1 $2 $3) TypeFamily $2 (unLoc $3) }
 
            -- default type instance
-        | 'type' type '=' ctype
+        | 'type' capi_ctype type '=' ctype
                 -- Note the use of type for the head; this allows
                 -- infix type constructors and type patterns
-                {% mkTySynonym (comb2 $1 $4) True $2 $4 }
+                {% mkTySynonym (comb2 $1 $5) True $2 $3 $5 }
 
           -- data/newtype family declaration
         | 'data' type opt_kind_sig
@@ -702,22 +701,22 @@ at_decl_cls :: { LTyClDecl RdrName }
 --
 at_decl_inst :: { LTyClDecl RdrName }
            -- type instance declarations
-        : 'type' type '=' ctype
+        : 'type' capi_ctype type '=' ctype
                 -- Note the use of type for the head; this allows
                 -- infix type constructors and type patterns
-                {% mkTySynonym (comb2 $1 $4) True $2 $4 }
+                {% mkTySynonym (comb2 $1 $5) True $2 $3 $5 }
 
         -- data/newtype instance declaration
-        | data_or_newtype tycl_hdr constrs deriving
-                {% mkTyData (comb4 $1 $2 $3 $4) (unLoc $1) True $2 
-                            Nothing (reverse (unLoc $3)) (unLoc $4) }
+        | data_or_newtype capi_ctype tycl_hdr constrs deriving
+                {% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) True $2 $3 
+                            Nothing (reverse (unLoc $4)) (unLoc $5) }
 
         -- GADT instance declaration
-        | data_or_newtype tycl_hdr opt_kind_sig 
+        | data_or_newtype capi_ctype tycl_hdr opt_kind_sig 
                  gadt_constrlist
                  deriving
-                {% mkTyData (comb4 $1 $2 $4 $5) (unLoc $1) True $2 
-                            (unLoc $3) (unLoc $4) (unLoc $5) }
+                {% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) True $2 $3 
+                            (unLoc $4) (unLoc $5) (unLoc $6) }
 
 data_or_newtype :: { Located NewOrData }
         : 'data'        { L1 DataType }
@@ -738,6 +737,10 @@ tycl_hdr :: { Located (Maybe (LHsContext RdrName), LHsType RdrName) }
         : context '=>' type             { LL (Just $1, $3) }
         | type                          { L1 (Nothing, $1) }
 
+capi_ctype :: { Maybe CType }
+capi_ctype : '{-# CTYPE' STRING '#-}'      { Just (CType (getSTRING $2)) }
+           |                               { Nothing }
+
 -----------------------------------------------------------------------------
 -- Stand-alone deriving
 

compiler/parser/RdrHsSyn.lhs

@@ -192,31 +192,34 @@ mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
 mkTyData :: SrcSpan
          -> NewOrData
          -> Bool                -- True <=> data family instance
+         -> Maybe CType
          -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
          -> Maybe (LHsKind RdrName)
          -> [LConDecl RdrName]
          -> Maybe [LHsType RdrName]
          -> P (LTyClDecl RdrName)
-mkTyData loc new_or_data is_family (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
+mkTyData loc new_or_data is_family cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
   = do { (tc, tparams) <- checkTyClHdr tycl_hdr
 
        ; checkDatatypeContext mcxt
        ; let cxt = fromMaybe (noLoc []) mcxt
        ; (tyvars, typats) <- checkTParams is_family tycl_hdr tparams
-       ; return (L loc (TyData { tcdND = new_or_data, tcdCtxt = cxt, tcdLName = tc,
+       ; return (L loc (TyData { tcdND = new_or_data, tcdCType = cType,
+                                 tcdCtxt = cxt, tcdLName = tc,
                                  tcdTyVars = tyvars, tcdTyPats = typats,
                                  tcdCons = data_cons,
                                  tcdKindSig = ksig, tcdDerivs = maybe_deriv })) }
 
 mkTySynonym :: SrcSpan
             -> Bool             -- True <=> type family instances
+            -> Maybe CType
             -> LHsType RdrName  -- LHS
             -> LHsType RdrName  -- RHS
             -> P (LTyClDecl RdrName)
-mkTySynonym loc is_family lhs rhs
+mkTySynonym loc is_family cType lhs rhs
   = do { (tc, tparams) <- checkTyClHdr lhs
        ; (tyvars, typats) <- checkTParams is_family lhs tparams
-       ; return (L loc (TySynonym tc tyvars typats rhs)) }
+       ; return (L loc (TySynonym tc cType tyvars typats rhs)) }
 
 mkTyFamily :: SrcSpan
            -> FamilyFlavour

compiler/prelude/ForeignCall.lhs

@@ -14,6 +14,8 @@ module ForeignCall (
         CCallSpec(..),
         CCallTarget(..), isDynamicTarget,
         CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,
+
+        CType(..),
     ) where
 
 import FastString
@@ -227,6 +229,12 @@ instance Outputable CCallSpec where
         = text "__dyn_ccall" <> gc_suf <+> text "\"\""
 \end{code}
 
+\begin{code}
+-- | A C type, used in CAPI FFI calls
+newtype CType = CType FastString
+    deriving (Data, Typeable)
+\end{code}
+
 
 %************************************************************************
 %*                                                                      *
@@ -308,4 +316,9 @@ instance Binary CCallConv where
               2 -> do return PrimCallConv
               3 -> do return CmmCallConv
               _ -> do return CApiConv
+
+instance Binary CType where
+    put_ bh (CType fs) = put_ bh fs
+    get bh = do fs <- get bh
+                return (CType fs)
 \end{code}

compiler/prelude/TysWiredIn.lhs

@@ -241,6 +241,7 @@ pcTyCon is_enum is_rec name tyvars cons
     tycon = mkAlgTyCon name
 		(mkArrowKinds (map tyVarKind tyvars) liftedTypeKind)
                 tyvars
+                Nothing
                 []		-- No stupid theta
 		(DataTyCon cons is_enum)
 		NoParentTyCon
@@ -406,6 +407,7 @@ mkIPName ip tycon_u datacon_u dc_wrk_u co_ax_u = name_ip
     tycon      = mkAlgTyCon tycon_name
                    (liftedTypeKind `mkArrowKind` constraintKind)
                    [alphaTyVar]
+                   Nothing
                    []      -- No stupid theta
                    (NewTyCon { data_con    = datacon, 
                                nt_rhs      = mkTyVarTy alphaTyVar,
@@ -432,6 +434,7 @@ eqTyCon :: TyCon
 eqTyCon = mkAlgTyCon eqTyConName
             (ForAllTy kv $ mkArrowKinds [k, k] constraintKind)
             [kv, a, b]
+            Nothing
             []      -- No stupid theta
             (DataTyCon [eqBoxDataCon] False)
             NoParentTyCon

compiler/rename/RnSource.lhs

@@ -799,7 +799,8 @@ rnTyClDecl mb_cls (TyFamily { tcdLName = tycon, tcdTyVars = tyvars
 
 -- "data", "newtype", "data instance, and "newtype instance" declarations
 -- both top level and (for an associated type) in an instance decl
-rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, 
+rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCType = cType,
+                                 tcdCtxt = context, 
 			   	 tcdLName = tycon, tcdTyVars = tyvars, 
 			   	 tcdTyPats = typats, tcdCons = condecls, 
 			   	 tcdKindSig = sig, tcdDerivs = derivs}
@@ -831,7 +832,8 @@ rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
 		-- No need to check for duplicate constructor decls
 		-- since that is done by RnNames.extendGlobalRdrEnvRn
 
-	; return (TyData {tcdND = new_or_data, tcdCtxt = context', 
+	; return (TyData {tcdND = new_or_data, tcdCType = cType,
+               tcdCtxt = context', 
 			   tcdLName = tycon', tcdTyVars = tyvars', 
 			   tcdTyPats = typats', tcdKindSig = sig',
 			   tcdCons = condecls', tcdDerivs = derivs'}, 
@@ -849,14 +851,16 @@ rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
 			     ; return (Just ds', extractHsTyNames_s ds') }
 
 -- "type" and "type instance" declarations
-rnTyClDecl mb_cls tydecl@(TySynonym { tcdTyVars = tyvars, tcdLName = name,
+rnTyClDecl mb_cls tydecl@(TySynonym { tcdTyVars = tyvars, tcdCType = cType,
+                          tcdLName = name,
 		  	              tcdTyPats = typats, tcdSynRhs = ty})
   = bindQTvs syn_doc mb_cls tyvars $ \ tyvars' -> do
     {    	 -- Checks for distinct tyvars
       name' <- lookupTcdName mb_cls tydecl
     ; (typats',fvs1) <- rnTyPats syn_doc name' typats
     ; (ty', fvs2)    <- rnHsTypeFVs syn_doc ty
-    ; return (TySynonym { tcdLName = name', tcdTyVars = tyvars'
+    ; return (TySynonym { tcdLName = name', tcdCType = cType
+                , tcdTyVars = tyvars'
     			, tcdTyPats = typats', tcdSynRhs = ty'}
              , extractHsTyVarBndrNames_s tyvars' (fvs1 `plusFV` fvs2)) }
   where

compiler/typecheck/TcGenGenerics.lhs

@@ -99,7 +99,7 @@ genGenericRepExtras tc mod =
                         | (u,n) <- zip us [0..] ] | (us,m) <- zip uniqsS [0..] ]
         
         mkTyCon name = ASSERT( isExternalName name )
-                       buildAlgTyCon name [] [] distinctAbstractTyConRhs
+                       buildAlgTyCon name [] Nothing [] distinctAbstractTyConRhs
                                           NonRecursive False NoParentTyCon
 
       let metaDTyCon  = mkTyCon d_name

compiler/typecheck/TcInstDcls.lhs

@@ -558,7 +558,8 @@ tcFamInstDecl1 fam_tc (decl@TySynonym {})
        ; return (mkSynFamInst rep_tc_name t_tvs fam_tc t_typats t_rhs) }
 
   -- "newtype instance" and "data instance"
-tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data, tcdCtxt = ctxt
+tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data, tcdCType = cType
+                                   , tcdCtxt = ctxt
                                    , tcdTyVars = tvs, tcdTyPats = Just pats
                                    , tcdCons = cons})
   = do { -- Check that the family declaration is for the right kind
@@ -595,7 +596,7 @@ tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data, tcdCtxt = ctxt
                                  mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons)
               ; let fam_inst = mkDataFamInst axiom_name tvs' fam_tc pats' rep_tc
                     parent   = FamInstTyCon (famInstAxiom fam_inst) fam_tc pats'
-                    rep_tc   = buildAlgTyCon rep_tc_name tvs' stupid_theta tc_rhs 
+                    rep_tc   = buildAlgTyCon rep_tc_name tvs' cType stupid_theta tc_rhs 
                                              Recursive h98_syntax parent
                  -- We always assume that indexed types are recursive.  Why?
                  -- (1) Due to their open nature, we can never be sure that a

compiler/typecheck/TcTyClsDecls.lhs

@@ -555,7 +555,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' SynFamilyTyCon kind parent
+  ; tycon <- buildSynTyCon tc_name tvs' Nothing SynFamilyTyCon kind parent
   ; return [ATyCon tycon] }
 
   -- "data family" declaration
@@ -566,24 +566,25 @@ tcTyClDecl1 parent _calc_isrec
   ; checkFamFlag tc_name
   ; extra_tvs <- tcDataKindSig kind
   ; let final_tvs = tvs' ++ extra_tvs    -- we may not need these
-        tycon = buildAlgTyCon tc_name final_tvs []
+        tycon = buildAlgTyCon tc_name final_tvs Nothing []
                               DataFamilyTyCon Recursive True parent
   ; return [ATyCon tycon] }
 
   -- "type" synonym declaration
 tcTyClDecl1 _parent _calc_isrec
-            (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
+            (TySynonym {tcdLName = L _ tc_name, tcdCType = cType, 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' (SynonymTyCon rhs_ty')
+    ; tycon <- buildSynTyCon tc_name tvs' cType (SynonymTyCon rhs_ty')
                  kind NoParentTyCon
     ; return [ATyCon tycon] }
 
   -- "newtype" and "data"
   -- NB: not used for newtype/data instances (whether associated or not)
 tcTyClDecl1 _parent calc_isrec
-              (TyData { tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs
+              (TyData { tcdND = new_or_data, tcdCType = cType
+                  , tcdCtxt = ctxt, tcdTyVars = tvs
 	              , tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons })
   = ASSERT( isNoParent _parent )
     let is_rec   = calc_isrec tc_name
@@ -613,7 +614,7 @@ tcTyClDecl1 _parent calc_isrec
 		   DataType -> return (mkDataTyConRhs data_cons)
 		   NewType  -> ASSERT( not (null data_cons) )
                                mkNewTyConRhs tc_name tycon (head data_cons)
-	; return (buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs
+	; return (buildAlgTyCon tc_name final_tvs cType stupid_theta tc_rhs
 	                        is_rec (not h98_syntax) NoParentTyCon) }
   ; return [ATyCon tycon] }
 

compiler/types/TyCon.lhs

@@ -60,6 +60,7 @@ module TyCon(
         tyConKind,
         tyConUnique,
         tyConTyVars,
+        tyConCType, tyConCType_maybe,
         tyConDataCons, tyConDataCons_maybe, tyConSingleDataCon_maybe,
         tyConFamilySize,
         tyConStupidTheta,
@@ -93,6 +94,7 @@ import {-# SOURCE #-} IParam  ( ipTyConName )
 import Var
 import Class
 import BasicTypes
+import ForeignCall
 import Name
 import PrelNames
 import Maybes
@@ -310,6 +312,9 @@ data TyCon
                                   -- 3. The family instance types if present
                                   --
                                   -- Note that it does /not/ scope over the data constructors.
+        tyConCType   :: Maybe CType, -- The C type that should be used
+                                     -- for this type when using the FFI
+                                     -- and CAPI
 
         algTcGadtSyntax  :: Bool,       -- ^ Was the data type declared with GADT syntax?
                                         -- If so, that doesn't mean it's a true GADT;
@@ -355,6 +360,9 @@ 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
@@ -838,19 +846,22 @@ mkAlgTyCon :: Name
            -> Kind              -- ^ Kind of the resulting 'TyCon'
            -> [TyVar]           -- ^ 'TyVar's scoped over: see 'tyConTyVars'.
                                 --   Arity is inferred from the length of this list
+           -> Maybe CType       -- ^ The C type this type corresponds to
+                                --   when using the CAPI FFI
            -> [PredType]        -- ^ Stupid theta: see 'algTcStupidTheta'
            -> AlgTyConRhs       -- ^ Information about dat aconstructors
            -> TyConParent
            -> RecFlag           -- ^ Is the 'TyCon' recursive?
            -> Bool              -- ^ Was the 'TyCon' declared with GADT syntax?
            -> TyCon
-mkAlgTyCon name kind tyvars stupid rhs parent is_rec gadt_syn
+mkAlgTyCon name kind tyvars cType stupid rhs parent is_rec gadt_syn
   = AlgTyCon {
         tyConName        = name,
         tyConUnique      = nameUnique name,
         tc_kind          = kind,
         tyConArity       = length tyvars,
         tyConTyVars      = tyvars,
+        tyConCType       = cType,
         algTcStupidTheta = stupid,
         algTcRhs         = rhs,
         algTcParent      = ASSERT2( okParent name parent, ppr name $$ ppr parent ) parent,
@@ -861,12 +872,12 @@ mkAlgTyCon name kind tyvars stupid rhs parent is_rec gadt_syn
 -- | Simpler specialization of 'mkAlgTyCon' for classes
 mkClassTyCon :: Name -> Kind -> [TyVar] -> AlgTyConRhs -> Class -> RecFlag -> TyCon
 mkClassTyCon name kind tyvars rhs clas is_rec =
-  mkAlgTyCon name kind tyvars [] rhs (ClassTyCon clas) is_rec False
+  mkAlgTyCon name kind tyvars Nothing [] rhs (ClassTyCon clas) is_rec False
 
 -- | Simpler specialization of 'mkAlgTyCon' for implicit paramaters
 mkIParamTyCon :: Name -> Kind -> TyVar -> AlgTyConRhs -> RecFlag -> TyCon
 mkIParamTyCon name kind tyvar rhs is_rec =
-  mkAlgTyCon name kind [tyvar] [] rhs NoParentTyCon is_rec False
+  mkAlgTyCon name kind [tyvar] Nothing [] rhs NoParentTyCon is_rec False
 
 mkTupleTyCon :: Name
              -> Kind    -- ^ Kind of the resulting 'TyCon'
@@ -935,14 +946,15 @@ mkPrimTyCon' name kind arity rep is_unlifted
     }
 
 -- | Create a type synonym 'TyCon'
-mkSynTyCon :: Name -> Kind -> [TyVar] -> SynTyConRhs -> TyConParent -> TyCon
-mkSynTyCon name kind tyvars rhs parent
+mkSynTyCon :: Name -> Kind -> [TyVar] -> Maybe CType -> SynTyConRhs -> TyConParent -> TyCon
+mkSynTyCon name kind tyvars cType rhs parent
   = SynTyCon {