X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FRdrHsSyn.lhs;h=d18b8d8fd91ce989236c092efce6030664e2ad40;hp=51b77bc13de07af3f9f8123812bd81c0eb8cdf5c;hb=6e9c0431a7cf2bf1a48f01db48c6a1d41fe15a09;hpb=e5b79a6988880d8757634683eefe2f03e45cdfc6 diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 51b77bc..d18b8d8 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -10,25 +10,21 @@ module RdrHsSyn ( mkHsOpApp, mkHsIntegral, mkHsFractional, mkHsIsString, - mkHsDo, mkHsSplice, + mkHsDo, mkHsSplice, mkTopSpliceDecl, mkClassDecl, mkTyData, mkTyFamily, mkTySynonym, - splitCon, mkInlineSpec, + splitCon, mkInlinePragma, mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp cvBindGroup, cvBindsAndSigs, cvTopDecls, findSplice, checkDecBrGroup, + placeHolderPunRhs, -- Stuff to do with Foreign declarations - CallConv(..), - mkImport, -- CallConv -> Safety - -- -> (FastString, RdrName, RdrNameHsType) - -- -> P RdrNameHsDecl + mkImport, parseCImport, - mkExport, -- CallConv - -- -> (FastString, RdrName, RdrNameHsType) - -- -> P RdrNameHsDecl + mkExport, mkExtName, -- RdrName -> CLabelString mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName mkSimpleConDecl, @@ -42,7 +38,6 @@ module RdrHsSyn ( checkTyVars, -- [LHsType RdrName] -> P () checkKindSigs, -- [LTyClDecl RdrName] -> P () checkInstType, -- HsType -> P HsType - checkDerivDecl, -- LDerivDecl RdrName -> P (LDerivDecl RdrName) checkPattern, -- HsExp -> P HsPat bang_RDR, checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat] @@ -58,15 +53,12 @@ import HsSyn -- Lots of it import Class ( FunDep ) import TypeRep ( Kind ) import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, - isRdrDataCon, isUnqual, getRdrName, isQual, - setRdrNameSpace, showRdrName ) -import BasicTypes ( maxPrecedence, Activation, RuleMatchInfo, - InlinePragma(..), InlineSpec(..), - alwaysInlineSpec, neverInlineSpec ) + isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace ) +import BasicTypes ( maxPrecedence, Activation(..), RuleMatchInfo, + InlinePragma(..) ) import Lexer import TysWiredIn ( unitTyCon ) -import ForeignCall ( CCallConv(..), Safety, CCallTarget(..), CExportSpec(..), - DNCallSpec(..), DNKind(..), CLabelString ) +import ForeignCall import OccName ( srcDataName, varName, isDataOcc, isTcOcc, occNameString ) import PrelNames ( forall_tv_RDR ) @@ -81,7 +73,7 @@ import Maybes import Control.Applicative ((<$>)) import Text.ParserCombinators.ReadP as ReadP import Data.List ( nubBy ) -import Data.Char ( isAscii, isAlphaNum, isAlpha ) +import Data.Char #include "HsVersions.h" \end{code} @@ -135,7 +127,8 @@ extract_lty (L loc ty) acc HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc)) HsParTy ty -> extract_lty ty acc HsNumTy _ -> acc - HsSpliceTy _ -> acc -- Type splices mention no type variables + HsSpliceTy {} -> acc -- Type splices mention no type variables + HsSpliceTyOut {} -> acc -- Type splices mention no type variables HsKindSig ty _ -> extract_lty ty acc HsForAllTy _ [] cx ty -> extract_lctxt cx (extract_lty ty acc) HsForAllTy _ tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $ @@ -230,6 +223,20 @@ mkTyFamily loc flavour lhs ksig = do { (tc, tparams) <- checkTyClHdr lhs ; tyvars <- checkTyVars tparams ; return (L loc (TyFamily flavour tc tyvars ksig)) } + +mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName +-- If the user wrote +-- $(e) +-- then that's the splice, but if she wrote, say, +-- f x +-- then behave as if she'd written +-- $(f x) +mkTopSpliceDecl expr + = SpliceD (SpliceDecl expr') + where + expr' = case expr of + (L _ (HsSpliceE (HsSplice _ expr))) -> expr + _other -> expr \end{code} %************************************************************************ @@ -262,7 +269,7 @@ cvBindGroup binding ValBindsIn mbs sigs cvBindsAndSigs :: OrdList (LHsDecl RdrName) - -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl RdrName]) + -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl]) -- Input decls contain just value bindings and signatures -- and in case of class or instance declarations also -- associated type declarations. They might also contain Haddock comments. @@ -665,15 +672,6 @@ checkPred (L spn ty) "malformed class assertion" --------------------------------------------------------------------------- --- Checking stand-alone deriving declarations - -checkDerivDecl :: LDerivDecl RdrName -> P (LDerivDecl RdrName) -checkDerivDecl d@(L loc _) = - do stDerivOn <- extension standaloneDerivingEnabled - if stDerivOn then return d - else parseError loc "Illegal stand-alone deriving declaration (use -XStandaloneDeriving)" - ---------------------------------------------------------------------------- -- Checking statements in a do-expression -- We parse do { e1 ; e2 ; } -- as [ExprStmt e1, ExprStmt e2] @@ -734,11 +732,9 @@ checkPat loc _ _ checkAPat :: DynFlags -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName) checkAPat dynflags loc e = case e of - EWildPat -> return (WildPat placeHolderType) - HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: " - ++ showRdrName x) - | otherwise -> return (VarPat x) - HsLit l -> return (LitPat l) + EWildPat -> return (WildPat placeHolderType) + HsVar x -> return (VarPat x) + HsLit l -> return (LitPat l) -- Overloaded numeric patterns (e.g. f 0 x = x) -- Negation is recorded separately, so that the literal is zero or +ve @@ -798,9 +794,15 @@ checkAPat dynflags loc e = case e of HsType ty -> return (TypePat ty) _ -> patFail loc -plus_RDR, bang_RDR :: RdrName +placeHolderPunRhs :: HsExpr RdrName +-- The RHS of a punned record field will be filled in by the renamer +-- It's better not to make it an error, in case we want to print it when debugging +placeHolderPunRhs = HsVar pun_RDR + +plus_RDR, bang_RDR, pun_RDR :: RdrName plus_RDR = mkUnqual varName (fsLit "+") -- Hack bang_RDR = mkUnqual varName (fsLit "!") -- Hack +pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side") checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName)) checkPatField fld = do { p <- checkLPat (hsRecFieldArg fld) @@ -837,10 +839,6 @@ checkFunBind :: SrcSpan -> Located (GRHSs RdrName) -> P (HsBind RdrName) checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss) - | isQual (unLoc fun) - = parseErrorSDoc (getLoc fun) - (ptext (sLit "Qualified name in function definition:") <+> ppr (unLoc fun)) - | otherwise = do ps <- checkPatterns pats let match_span = combineSrcSpans lhs_loc rhs_span return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)]) @@ -961,40 +959,40 @@ mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg 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 -> RuleMatchInfo -> Bool -> InlineSpec --- The Maybe is becuase the user can omit the activation spec (and usually does) -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 +mkInlinePragma :: Maybe Activation -> RuleMatchInfo -> Bool -> InlinePragma +-- The Maybe is because the user can omit the activation spec (and usually does) +mkInlinePragma mb_act match_info inl + = InlinePragma { inl_inline = inl + , inl_act = act + , inl_rule = match_info } + where + act = case mb_act of + Just act -> act + Nothing | inl -> AlwaysActive + | otherwise -> NeverActive + -- If no specific phase is given then: + -- NOINLINE => NeverActive + -- INLINE => Active ----------------------------------------------------------------------------- -- utilities for foreign declarations --- supported calling conventions --- -data CallConv = CCall CCallConv -- ccall or stdcall - | DNCall -- .NET - -- construct a foreign import declaration -- -mkImport :: CallConv +mkImport :: CCallConv -> Safety -> (Located FastString, Located RdrName, LHsType RdrName) -> P (HsDecl RdrName) -mkImport (CCall cconv) safety (L loc entity, v, ty) +mkImport cconv safety (L loc entity, v, ty) | cconv == PrimCallConv = do - let funcTarget = CFunction (StaticTarget entity) + let funcTarget = CFunction (StaticTarget entity Nothing) importSpec = CImport PrimCallConv safety nilFS funcTarget return (ForD (ForeignImport v ty importSpec)) + | otherwise = do case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of Nothing -> parseError loc "Malformed entity string" Just importSpec -> return (ForD (ForeignImport v ty importSpec)) -mkImport (DNCall ) _ (entity, v, ty) = do - spec <- parseDImport entity - return $ ForD (ForeignImport v ty (DNImport spec)) -- the string "foo" is ambigous: either a header or a C identifier. The -- C identifier case comes first in the alternatives below, so we pick @@ -1005,21 +1003,27 @@ parseCImport cconv safety nm str = listToMaybe $ map fst $ filter (null.snd) $ readP_to_S parse str where - parse = choice [ + parse = do + skipSpaces + r <- choice [ string "dynamic" >> return (mk nilFS (CFunction DynamicTarget)), string "wrapper" >> return (mk nilFS CWrapper), optional (string "static" >> skipSpaces) >> (mk nilFS <$> cimp nm) +++ (do h <- munch1 hdr_char; skipSpaces; mk (mkFastString h) <$> cimp nm) - ] + ] + skipSpaces + return r mk = CImport cconv safety - hdr_char c = isAscii c && (isAlphaNum c || c `elem` "._") + 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 == '_' cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid) - +++ ((CFunction . StaticTarget) <$> cid) + +++ ((\c -> CFunction (StaticTarget c Nothing)) <$> cid) where cid = return nm +++ (do c <- satisfy (\c -> isAlpha c || c == '_') @@ -1027,56 +1031,16 @@ parseCImport cconv safety nm str = return (mkFastString (c:cs))) --- --- Unravel a dotnet spec string. --- -parseDImport :: Located FastString -> P DNCallSpec -parseDImport (L loc entity) = parse0 comps - where - comps = words (unpackFS entity) - - parse0 [] = d'oh - parse0 (x : xs) - | x == "static" = parse1 True xs - | otherwise = parse1 False (x:xs) - - parse1 _ [] = d'oh - parse1 isStatic (x:xs) - | x == "method" = parse2 isStatic DNMethod xs - | x == "field" = parse2 isStatic DNField xs - | x == "ctor" = parse2 isStatic DNConstructor xs - parse1 isStatic xs = parse2 isStatic DNMethod xs - - parse2 _ _ [] = d'oh - parse2 isStatic kind (('[':x):xs) = - case x of - [] -> d'oh - vs | last vs == ']' -> parse3 isStatic kind (init vs) xs - _ -> d'oh - parse2 isStatic kind xs = parse3 isStatic kind "" xs - - parse3 isStatic kind assem [x] = - return (DNCallSpec isStatic kind assem x - -- these will be filled in once known. - (error "FFI-dotnet-args") - (error "FFI-dotnet-result")) - parse3 _ _ _ _ = d'oh - - d'oh = parseError loc "Malformed entity string" - -- construct a foreign export declaration -- -mkExport :: CallConv +mkExport :: CCallConv -> (Located FastString, Located RdrName, LHsType RdrName) -> P (HsDecl RdrName) -mkExport (CCall cconv) (L _ entity, v, ty) = return $ +mkExport cconv (L _ entity, v, ty) = return $ ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv))) where entity' | nullFS entity = mkExtName (unLoc v) | otherwise = entity -mkExport DNCall (L _ _, v, _) = - parseError (getLoc v){-TODO: not quite right-} - "Foreign export is not yet supported for .NET" -- Supplying the ext_name in a foreign decl is optional; if it -- isn't there, the Haskell name is assumed. Note that no transformation