From 546dd4f219ba05880e252e7fee6a2037a50ed3b3 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Wed, 15 Feb 2012 14:55:23 +0000 Subject: 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/parser/Lexer.x | 4 +++- compiler/parser/Parser.y.pp | 53 +++++++++++++++++++++++--------------------- compiler/parser/RdrHsSyn.lhs | 11 +++++---- 3 files changed, 38 insertions(+), 30 deletions(-) (limited to 'compiler/parser') diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 6e74cfbc4a..74da99a005 100644 --- a/compiler/parser/Lexer.x +++ b/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)), diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index c05f2e1e6b..f590f1c647 100644 --- a/compiler/parser/Parser.y.pp +++ b/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 diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 14778171f5..56c643d190 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/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 -- cgit v1.2.1 From ef796d1b58f1cfa8867c7b14bd78e2d770d092a3 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Thu, 16 Feb 2012 19:31:06 +0000 Subject: Fix parsing regression in CTYPE patch --- compiler/parser/Parser.y.pp | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) (limited to 'compiler/parser') diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index f590f1c647..f29364a872 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -682,10 +682,13 @@ 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' capi_ctype type '=' ctype -- cgit v1.2.1 From 7b24c3fffecbf9fc219c10f24d1472d0d03da6a1 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Fri, 17 Feb 2012 15:50:59 +0000 Subject: Allow a header to be specified in a CTYPE pragma You can now say data {-# CTYPE "some_header.h" "the C type" #-} Foo = ... I think it's rare that this will actually be needed. If the header for a CAPI FFI import includes a void f(ctype x); prototype then ctype must already be defined. However, if the header only has #define f(p) p->j then the type need not be defined. But either way, it seems good practice for us to specify the header that we need. --- compiler/parser/Parser.y.pp | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'compiler/parser') diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index f29364a872..bb370978c4 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -741,8 +741,9 @@ tycl_hdr :: { Located (Maybe (LHsContext RdrName), LHsType RdrName) } | type { L1 (Nothing, $1) } capi_ctype :: { Maybe CType } -capi_ctype : '{-# CTYPE' STRING '#-}' { Just (CType (getSTRING $2)) } - | { Nothing } +capi_ctype : '{-# CTYPE' STRING STRING '#-}' { Just (CType (Just (getSTRING $2)) (getSTRING $3)) } + | '{-# CTYPE' STRING '#-}' { Just (CType Nothing (getSTRING $2)) } + | { Nothing } ----------------------------------------------------------------------------- -- Stand-alone deriving -- cgit v1.2.1 From 1b7dfd7f50fb16e30b6f3512f2ad4e1946a458ee Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Fri, 17 Feb 2012 20:56:11 +0000 Subject: Small refactoring: Use (Maybe Header) rather than FastString --- compiler/parser/Parser.y.pp | 4 ++-- compiler/parser/RdrHsSyn.lhs | 10 +++++----- 2 files changed, 7 insertions(+), 7 deletions(-) (limited to 'compiler/parser') diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index bb370978c4..62fdeddf28 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -741,8 +741,8 @@ tycl_hdr :: { Located (Maybe (LHsContext RdrName), LHsType RdrName) } | type { L1 (Nothing, $1) } capi_ctype :: { Maybe CType } -capi_ctype : '{-# CTYPE' STRING STRING '#-}' { Just (CType (Just (getSTRING $2)) (getSTRING $3)) } - | '{-# CTYPE' STRING '#-}' { Just (CType Nothing (getSTRING $2)) } +capi_ctype : '{-# CTYPE' STRING STRING '#-}' { Just (CType (Just (Header (getSTRING $2))) (getSTRING $3)) } + | '{-# CTYPE' STRING '#-}' { Just (CType Nothing (getSTRING $2)) } | { Nothing } ----------------------------------------------------------------------------- diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 56c643d190..890c3794d1 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -916,7 +916,7 @@ mkImport :: CCallConv mkImport cconv safety (L loc entity, v, ty) | cconv == PrimCallConv = do let funcTarget = CFunction (StaticTarget entity Nothing) - importSpec = CImport PrimCallConv safety nilFS funcTarget + importSpec = CImport PrimCallConv safety Nothing funcTarget return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec)) | otherwise = do @@ -936,11 +936,11 @@ parseCImport cconv safety nm str = parse = do skipSpaces r <- choice [ - string "dynamic" >> return (mk nilFS (CFunction DynamicTarget)), - string "wrapper" >> return (mk nilFS CWrapper), + string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)), + string "wrapper" >> return (mk Nothing CWrapper), optional (string "static" >> skipSpaces) >> - (mk nilFS <$> cimp nm) +++ - (do h <- munch1 hdr_char; skipSpaces; mk (mkFastString h) <$> cimp nm) + (mk Nothing <$> cimp nm) +++ + (do h <- munch1 hdr_char; skipSpaces; mk (Just (Header (mkFastString h))) <$> cimp nm) ] skipSpaces return r -- cgit v1.2.1 From 544926d7c6fe5823eb12b7907853e34ad7444b9b Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Tue, 21 Feb 2012 23:03:41 +0000 Subject: 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. --- compiler/parser/Parser.y.pp | 23 ++++++++++------------- compiler/parser/RdrHsSyn.lhs | 5 ++--- 2 files changed, 12 insertions(+), 16 deletions(-) (limited to 'compiler/parser') diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 62fdeddf28..ff98b748c9 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -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 diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 890c3794d1..c20ce1ac17 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -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 -- cgit v1.2.1 From 9065bdbf5299097263c35f6e389b018806f6753e Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Sat, 25 Feb 2012 19:13:55 +0000 Subject: Fix parsing of FFI import decls We no longer parse "staticfoo" as "static foo". --- compiler/parser/RdrHsSyn.lhs | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) (limited to 'compiler/parser') diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index c20ce1ac17..3ba967352f 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -937,25 +937,33 @@ parseCImport cconv safety nm str = r <- choice [ string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)), string "wrapper" >> return (mk Nothing CWrapper), - optional (string "static" >> skipSpaces) >> + optional (token "static" >> skipSpaces) >> (mk Nothing <$> cimp nm) +++ (do h <- munch1 hdr_char; skipSpaces; mk (Just (Header (mkFastString h))) <$> cimp nm) ] skipSpaces return r + token str = do _ <- string str + toks <- look + case toks of + c : _ + | id_char c -> pfail + _ -> return () + mk = CImport cconv safety hdr_char c = not (isSpace c) -- header files are filenames, which can contain -- pretty much any char (depending on the platform), -- so just accept any non-space character - id_char c = isAlphaNum c || c == '_' + id_first_char c = isAlpha c || c == '_' + id_char c = isAlphaNum c || c == '_' cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid) +++ ((\c -> CFunction (StaticTarget c Nothing)) <$> cid) where cid = return nm +++ - (do c <- satisfy (\c -> isAlpha c || c == '_') + (do c <- satisfy id_first_char cs <- many (satisfy id_char) return (mkFastString (c:cs))) -- cgit v1.2.1 From ae04bd43a2640e17a9035f170d76dae356082f88 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Sun, 26 Feb 2012 01:46:06 +0000 Subject: Implement "value" imports with the CAPI This allows us to import values (i.e. non-functions) with the CAPI. This means we can access values even if (on some or all platforms) they are simple #defines. --- compiler/parser/ParserCore.y | 2 +- compiler/parser/RdrHsSyn.lhs | 20 +++++++++++++++----- 2 files changed, 16 insertions(+), 6 deletions(-) (limited to 'compiler/parser') diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y index 3a786ea04b..80d49430eb 100644 --- a/compiler/parser/ParserCore.y +++ b/compiler/parser/ParserCore.y @@ -278,7 +278,7 @@ exp :: { IfaceExpr } -- "InlineMe" -> IfaceNote IfaceInlineMe $3 -- } | '%external' STRING aty { IfaceFCall (ForeignCall.CCall - (CCallSpec (StaticTarget (mkFastString $2) Nothing) + (CCallSpec (StaticTarget (mkFastString $2) Nothing True) CCallConv PlaySafe)) $3 } diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 3ba967352f..59e6727535 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -914,7 +914,7 @@ mkImport :: CCallConv -> P (HsDecl RdrName) mkImport cconv safety (L loc entity, v, ty) | cconv == PrimCallConv = do - let funcTarget = CFunction (StaticTarget entity Nothing) + let funcTarget = CFunction (StaticTarget entity Nothing True) importSpec = CImport PrimCallConv safety Nothing funcTarget return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec)) @@ -937,9 +937,11 @@ parseCImport cconv safety nm str = r <- choice [ string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)), string "wrapper" >> return (mk Nothing CWrapper), - optional (token "static" >> skipSpaces) >> - (mk Nothing <$> cimp nm) +++ - (do h <- munch1 hdr_char; skipSpaces; mk (Just (Header (mkFastString h))) <$> cimp nm) + do optional (token "static" >> skipSpaces) + ((mk Nothing <$> cimp nm) +++ + (do h <- munch1 hdr_char + skipSpaces + mk (Just (Header (mkFastString h))) <$> cimp nm)) ] skipSpaces return r @@ -960,7 +962,15 @@ parseCImport cconv safety nm str = id_char c = isAlphaNum c || c == '_' cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid) - +++ ((\c -> CFunction (StaticTarget c Nothing)) <$> cid) + +++ (do isFun <- case cconv of + CApiConv -> + option True + (do token "value" + skipSpaces + return False) + _ -> return True + cid' <- cid + return (CFunction (StaticTarget cid' Nothing isFun))) where cid = return nm +++ (do c <- satisfy id_first_char -- cgit v1.2.1 From 3bf54e78cfd4b94756e3f21c00ae187f80c3341d Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Fri, 2 Mar 2012 16:32:58 +0000 Subject: Hurrah! This major commit adds support for scoped kind variables, which (finally) fills out the functionality of polymorphic kinds. It also fixes numerous bugs. Main changes are: Renaming stuff ~~~~~~~~~~~~~~ * New type in HsTypes: data HsBndrSig sig = HsBSig sig [Name] which is used for type signatures in patterns, and kind signatures in types. So when you say f (x :: [a]) = x ++ x or data T (f :: k -> *) (x :: *) = MkT (f x) the signatures in both cases are a HsBndrSig. * The [Name] in HsBndrSig records the variables bound by the pattern, that is 'a' in the first example, 'k' in the second, and nothing in the third. The renamer initialises the field. * As a result I was able to get rid of RnHsSyn.extractHsTyNames :: LHsType Name -> NameSet and its friends altogether. Deleted the entire module! This led to some knock-on refactoring; in particular the type renamer now returns the free variables just like the term renamer. Kind-checking types: mainly TcHsType ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A major change is that instead of kind-checking types in two passes, we now do one. Under the old scheme, the first pass did kind-checking and (hackily) annotated the HsType with the inferred kinds; and the second pass desugared the HsType to a Type. But now that we have kind variables inside types, the first pass (TcHsType.tc_hs_type) can go straight to Type, and zonking will squeeze out any kind unification variables later. This is much nicer, but it was much more fiddly than I had expected. The nastiest corner is this: it's very important that tc_hs_type uses lazy constructors to build the returned type. See Note [Zonking inside the knot] in TcHsType. Type-checking type and class declarations: mainly TcTyClsDecls ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ I did tons of refactoring in TcTyClsDecls. Simpler and nicer now. Typechecking bindings: mainly TcBinds ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ I rejigged (yet again) the handling of type signatures in TcBinds. It's a bit simpler now. The main change is that tcTySigs goes right through to a TcSigInfo in one step; previously it was split into two, part here and part later. Unsafe coercions ~~~~~~~~~~~~~~~~ Usually equality coercions have exactly the same kind on both sides. But we do allow an *unsafe* coercion between Int# and Bool, say, used in case error Bool "flah" of { True -> 3#; False -> 0# } --> (error Bool "flah") |> unsafeCoerce Bool Int# So what is the instantiation of (~#) here? unsafeCoerce Bool Int# :: (~#) ??? Bool Int# I'm using OpenKind here for now, but it's un-satisfying that the lhs and rhs of the ~ don't have precisely the same kind. More minor ~~~~~~~~~~ * HsDecl.TySynonym has its free variables attached, which makes the cycle computation in TcTyDecls.mkSynEdges easier. * Fixed a nasty reversed-comparison bug in FamInstEnv: @@ -490,7 +490,7 @@ lookup_fam_inst_env' match_fun one_sided ie fam tys n_tys = length tys extra_tys = drop arity tys (match_tys, add_extra_tys) - | arity > n_tys = (take arity tys, \res_tys -> res_tys ++ extra_tys) + | arity < n_tys = (take arity tys, \res_tys -> res_tys ++ extra_tys) | otherwise = (tys, \res_tys -> res_tys) --- compiler/parser/Parser.y.pp | 5 +++-- compiler/parser/ParserCore.y | 4 +++- compiler/parser/RdrHsSyn.lhs | 8 +++++--- 3 files changed, 11 insertions(+), 6 deletions(-) (limited to 'compiler/parser') diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index ff98b748c9..8de1e0b03f 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -871,7 +871,7 @@ rule_var_list :: { [RuleBndr RdrName] } rule_var :: { RuleBndr RdrName } : varid { RuleBndr $1 } - | '(' varid '::' ctype ')' { RuleBndrSig $2 $4 } + | '(' varid '::' ctype ')' { RuleBndrSig $2 (HsBSig $4 placeHolderBndrs) } ----------------------------------------------------------------------------- -- Warnings and deprecations (c.f. rules) @@ -1102,7 +1102,7 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] } tv_bndr :: { LHsTyVarBndr RdrName } : tyvar { L1 (UserTyVar (unLoc $1) placeHolderKind) } - | '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) $4 placeHolderKind) } + | '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) (HsBSig $4 placeHolderBndrs) placeHolderKind) } fds :: { Located [Located (FunDep RdrName)] } : {- empty -} { noLoc [] } @@ -1135,6 +1135,7 @@ akind :: { LHsKind RdrName } : '*' { L1 $ HsTyVar (nameRdrName liftedTypeKindTyConName) } | '(' kind ')' { LL $ HsParTy $2 } | pkind { $1 } + | tyvar { L1 $ HsTyVar (unLoc $1) } pkind :: { LHsKind RdrName } -- promoted type, see Note [Promotion] : qtycon { L1 $ HsTyVar $ unLoc $1 } diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y index 80d49430eb..872bcdefc0 100644 --- a/compiler/parser/ParserCore.y +++ b/compiler/parser/ParserCore.y @@ -375,7 +375,9 @@ ifaceUnliftedTypeKind = ifaceTcType (IfaceTc unliftedTypeKindTyConName) ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2 toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName -toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) (toHsKind k) placeHolderKind +toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) bsig placeHolderKind + where + bsig = HsBSig (toHsKind k) placeHolderBndrs ifaceExtRdrName :: Name -> RdrName ifaceExtRdrName name = mkOrig (nameModule name) (nameOccName name) diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 59e6727535..be1f5c4f4b 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -218,7 +218,9 @@ mkTySynonym :: SrcSpan mkTySynonym loc is_family 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 { tcdLName = tc + , tcdTyVars = tyvars, tcdTyPats = typats + , tcdSynRhs = rhs, tcdFVs = placeHolderNames })) } mkTyFamily :: SrcSpan -> FamilyFlavour @@ -499,7 +501,7 @@ checkTyVars tycl_hdr tparms = mapM chk tparms where -- Check that the name space is correct! chk (L l (HsKindSig (L _ (HsTyVar tv)) k)) - | isRdrTyVar tv = return (L l (KindedTyVar tv k placeHolderKind)) + | isRdrTyVar tv = return (L l (KindedTyVar tv (HsBSig k placeHolderBndrs) placeHolderKind)) chk (L l (HsTyVar tv)) | isRdrTyVar tv = return (L l (UserTyVar tv placeHolderKind)) chk t@(L l _) @@ -636,7 +638,7 @@ checkAPat dynflags loc e0 = case e0 of let t' = case t of L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty other -> other - return (SigPatIn e t') + return (SigPatIn e (HsBSig t' placeHolderBndrs)) -- n+k patterns OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _ -- cgit v1.2.1