Commit 4c29dcb6 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Merge branch 'master' of http://darcs.haskell.org/ghc

parents 1bc80144 6f4a073e
......@@ -7,7 +7,6 @@
A ``lint'' pass to check for Core correctness
\begin{code}
{-# OPTIONS_GHC -fprof-auto #-}
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
......@@ -15,6 +14,10 @@ A ``lint'' pass to check for Core correctness
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details
#if __GLASGOW_HASKELL__ >= 704
{-# OPTIONS_GHC -fprof-auto #-}
#endif
module CoreLint ( lintCoreBindings, lintUnfolding ) where
#include "HsVersions.h"
......
......@@ -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,35 @@ 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) of (FunPtr t), then we need to
-- convert t to a C type and put a * after it. If we don't
-- know a type for t, then "void" is fine, though.
| Just (ptr, [t']) <- splitTyConApp_maybe t
, tyConName ptr `elem` [ptrTyConName, funPtrTyConName]
= 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
......
......@@ -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]
......
......@@ -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]
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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),
......
......@@ -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
......
......@@ -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)),
......
......@@ -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)) } }
......@@ -683,16 +682,19 @@ inst_decl :: { LInstDecl RdrName }
--
at_decl_cls :: { LTyClDecl RdrName }
-- type family declarations
: 'type' type opt_kind_sig
: 'type' capi_ctype type opt_kind_sig
-- Note the use of type for the head; this allows
-- infix type constructors to be declared
{% mkTyFamily (comb3 $1 $2 $3) TypeFamily $2 (unLoc $3) }
-- 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) }
-- 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 +704,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 +740,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
......
......@@ -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
......
......@@ -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}
......@@ -96,6 +96,7 @@ import RdrName
import Name
import BasicTypes ( TupleSort(..), tupleSortBoxity, IPName(..),
Arity, RecFlag(..), Boxity(..), HsBang(..) )
import ForeignCall
import Unique ( incrUnique, mkTupleTyConUnique,
mkTupleDataConUnique, mkPArrDataConUnique )
import Data.Array
......@@ -229,18 +230,19 @@ eqTyCon_RDR = nameRdrName eqTyConName
%************************************************************************
\begin{code}
pcNonRecDataTyCon :: Name -> [TyVar] -> [DataCon] -> TyCon
pcNonRecDataTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
pcNonRecDataTyCon = pcTyCon False NonRecursive
pcRecDataTyCon :: Name -> [TyVar] -> [DataCon] -> TyCon
pcRecDataTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
pcRecDataTyCon = pcTyCon False Recursive
pcTyCon :: Bool -> RecFlag -> Name -> [TyVar] -> [DataCon] -> TyCon
pcTyCon is_enum is_rec name tyvars cons
pcTyCon :: Bool -> RecFlag -> Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
pcTyCon is_enum is_rec name cType tyvars cons
= tycon
where
tycon = mkAlgTyCon name
(mkArrowKinds (map tyVarKind tyvars) liftedTypeKind)
tyvars
cType
[] -- No stupid theta
(DataTyCon cons is_enum)
NoParentTyCon
......@@ -406,6 +408,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 +435,7 @@ eqTyCon :: TyCon
eqTyCon = mkAlgTyCon eqTyConName
(ForAllTy kv $ mkArrowKinds [k, k] constraintKind)
[kv, a, b]
Nothing
[] -- No stupid theta
(DataTyCon [eqBoxDataCon] False)
NoParentTyCon
......@@ -456,7 +460,8 @@ charTy :: Type
charTy = mkTyConTy charTyCon
charTyCon :: TyCon
charTyCon = pcNonRecDataTyCon charTyConName [] [charDataCon]
charTyCon = pcNonRecDataTyCon charTyConName (Just (CType (fsLit "HsChar")))
[] [charDataCon]
charDataCon :: DataCon
charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon
......@@ -468,7 +473,7 @@ stringTy = mkListTy charTy -- convenience only
integerTyCon :: TyCon
integerTyCon = case cIntegerLibraryType of
IntegerGMP ->
pcNonRecDataTyCon integerRealTyConName []
pcNonRecDataTyCon integerRealTyConName Nothing []
[integerGmpSDataCon, integerGmpJDataCon]
_ ->
panic "Evaluated integerTyCon, but not using IntegerGMP"
......@@ -491,7 +496,7 @@ intTy :: Type
intTy = mkTyConTy intTyCon
intTyCon :: TyCon
intTyCon = pcNonRecDataTyCon intTyConName [] [intDataCon]
intTyCon = pcNonRecDataTyCon intTyConName (Just (CType (fsLit "HsInt"))) [] [intDataCon]
intDataCon :: DataCon
intDataCon = pcDataCon intDataConName [] [intPrimTy] intTyCon
\end{code}
......@@ -501,7 +506,7 @@ wordTy :: Type
wordTy = mkTyConTy wordTyCon