-- -> (FastString, RdrName, RdrNameHsType)
-- -> P RdrNameHsDecl
mkExtName, -- RdrName -> CLabelString
- mkGadtDecl, -- Located RdrName -> LHsType RdrName -> ConDecl RdrName
+ mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
-- Bunch of functions in the parser monad for
-- checking and constructing values
checkMDo, -- [Stmt] -> P [Stmt]
checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
- parseError, -- String -> Pa
+ parseError,
+ parseErrorSDoc,
) where
import HsSyn -- Lots of it
import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
isRdrDataCon, isUnqual, getRdrName, isQual,
setRdrNameSpace, showRdrName )
-import BasicTypes ( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec )
+import BasicTypes ( maxPrecedence, Activation, RuleMatchInfo,
+ InlinePragma(..), InlineSpec(..),
+ alwaysInlineSpec, neverInlineSpec )
import Lexer ( P, failSpanMsgP, extension, standaloneDerivingEnabled, bangPatEnabled )
import TysWiredIn ( unitTyCon )
-import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
+import ForeignCall ( CCallConv(..), Safety, CCallTarget(..), CExportSpec(..),
DNCallSpec(..), DNKind(..), CLabelString )
import OccName ( srcDataName, varName, isDataOcc, isTcOcc,
occNameString )
checkValSig (L l _) _
= parseError l "Invalid type signature"
-mkGadtDecl :: Located RdrName
+mkGadtDecl :: [Located RdrName]
-> LHsType RdrName -- assuming HsType
- -> ConDecl RdrName
-mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = mk_gadt_con name qvars cxt ty
-mkGadtDecl name ty = mk_gadt_con name [] (noLoc []) ty
+ -> [ConDecl RdrName]
+-- We allow C,D :: ty
+-- and expand it as if it had been
+-- C :: ty; D :: ty
+-- (Just like type signatures in general.)
+mkGadtDecl names ty
+ = [mk_gadt_con name qvars cxt tau | name <- names]
+ where
+ (qvars,cxt,tau) = case ty of
+ L _ (HsForAllTy _ qvars cxt tau) -> (qvars, cxt, tau)
+ _ -> ([], noLoc [], ty)
mk_gadt_con :: Located RdrName
-> [LHsTyVarBndr RdrName]
mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
-mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec
+mkInlineSpec :: Maybe Activation -> RuleMatchInfo -> Bool -> InlineSpec
-- The Maybe is becuase the user can omit the activation spec (and usually does)
-mkInlineSpec Nothing True = alwaysInlineSpec -- INLINE
-mkInlineSpec Nothing False = neverInlineSpec -- NOINLINE
-mkInlineSpec (Just act) inl = Inline act inl
+mkInlineSpec Nothing match_info True = alwaysInlineSpec match_info
+ -- INLINE
+mkInlineSpec Nothing match_info False = neverInlineSpec match_info
+ -- NOINLINE
+mkInlineSpec (Just act) match_info inl = Inline (InlinePragma act match_info) inl
-----------------------------------------------------------------------------
-> Safety
-> (Located FastString, Located RdrName, LHsType RdrName)
-> P (HsDecl RdrName)
-mkImport (CCall cconv) safety (entity, v, ty) = do
- importSpec <- parseCImport entity cconv safety v
+mkImport (CCall cconv) safety (entity, v, ty)
+ | cconv == PrimCallConv = do
+ let funcTarget = CFunction (StaticTarget (unLoc entity))
+ importSpec = CImport PrimCallConv safety nilFS funcTarget
return (ForD (ForeignImport v ty importSpec))
+ | otherwise = do
+ importSpec <- parseCImport entity cconv safety v
+ return (ForD (ForeignImport v ty importSpec))
mkImport (DNCall ) _ (entity, v, ty) = do
spec <- parseDImport entity
return $ ForD (ForeignImport v ty (DNImport spec))
parseCImport (L loc entity) cconv safety v
-- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
| entity == fsLit "dynamic" =
- return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
+ return $ CImport cconv safety nilFS (CFunction DynamicTarget)
| entity == fsLit "wrapper" =
- return $ CImport cconv safety nilFS nilFS CWrapper
+ return $ CImport cconv safety nilFS CWrapper
| otherwise = parse0 (unpackFS entity)
where
-- using the static keyword?
parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
parse0 rest = parse1 rest
-- check for header file name
- parse1 "" = parse4 "" nilFS False nilFS
+ parse1 "" = parse4 "" nilFS False
parse1 (' ':rest) = parse1 rest
parse1 str@('&':_ ) = parse2 str nilFS
- parse1 str@('[':_ ) = parse3 str nilFS False
parse1 str
| ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
- | otherwise = parse4 str nilFS False nilFS
+ | otherwise = parse4 str nilFS False
where
- (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
+ (first, rest) = break (\c -> c == ' ' || c == '&') str
-- check for address operator (indicating a label import)
- parse2 "" header = parse4 "" header False nilFS
+ parse2 "" header = parse4 "" header False
parse2 (' ':rest) header = parse2 rest header
- parse2 ('&':rest) header = parse3 rest header True
- parse2 str@('[':_ ) header = parse3 str header False
- parse2 str header = parse4 str header False nilFS
- -- check for library object name
- parse3 (' ':rest) header isLbl = parse3 rest header isLbl
- parse3 ('[':rest) header isLbl =
- case break (== ']') rest of
- (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
- _ -> parseError loc "Missing ']' in entity"
- parse3 str header isLbl = parse4 str header isLbl nilFS
+ parse2 ('&':rest) header = parse3 rest header
+ parse2 str header = parse4 str header False
+ -- eat spaces after '&'
+ parse3 (' ':rest) header = parse3 rest header
+ parse3 str header = parse4 str header True
-- check for name of C function
- parse4 "" header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
- parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
- parse4 str header isLbl lib
- | all (== ' ') rest = build (mkFastString first) header isLbl lib
- | otherwise = parseError loc "Malformed entity string"
+ parse4 "" header isLbl = build (mkExtName (unLoc v)) header isLbl
+ parse4 (' ':rest) header isLbl = parse4 rest header isLbl
+ parse4 str header isLbl
+ | all (== ' ') rest = build (mkFastString first) header isLbl
+ | otherwise = parseError loc "Malformed entity string"
where
(first, rest) = break (== ' ') str
--
- build cid header False lib = return $
- CImport cconv safety header lib (CFunction (StaticTarget cid))
- build cid header True lib = return $
- CImport cconv safety header lib (CLabel cid )
+ build cid header False = return $
+ CImport cconv safety header (CFunction (StaticTarget cid))
+ build cid header True = return $
+ CImport cconv safety header (CLabel cid )
--
-- Unravel a dotnet spec string.
projects / ghc-hetmet.git / blobdiff