X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FRdrHsSyn.lhs;h=b86068cf0f314f453e5292a2e024fa3d36d6f8ac;hp=a299dc5f3c0e21ada1a102354f38a35c32982b7d;hb=3ddb6bb4edf70b2456d789f34d3f56541818a696;hpb=21c5c9c09a8d36b4ae8a83b17b543c332bc9cb0c diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index a299dc5..b86068c 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -10,9 +10,9 @@ 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, @@ -54,9 +54,8 @@ import Class ( FunDep ) import TypeRep ( Kind ) import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace ) -import BasicTypes ( maxPrecedence, Activation, RuleMatchInfo, - InlinePragma(..), InlineSpec(..), - alwaysInlineSpec, neverInlineSpec ) +import BasicTypes ( maxPrecedence, Activation(..), RuleMatchInfo, + InlinePragma(..) ) import Lexer import TysWiredIn ( unitTyCon ) import ForeignCall @@ -74,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} @@ -128,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) $ @@ -223,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} %************************************************************************ @@ -255,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. @@ -535,12 +549,14 @@ checkInstType (L l t) checkDictTy :: LHsType RdrName -> P (LHsType RdrName) checkDictTy (L spn ty) = check ty [] where - check (HsTyVar t) args | not (isRdrTyVar t) - = return (L spn (HsPredTy (HsClassP t args))) + check (HsTyVar tc) args | isRdrTc tc = done tc args + check (HsOpTy t1 (L _ tc) t2) args | isRdrTc tc = done tc (t1:t2:args) check (HsAppTy l r) args = check (unLoc l) (r:args) check (HsParTy t) args = check (unLoc t) args check _ _ = parseError spn "Malformed instance header" + done tc args = return (L spn (HsPredTy (HsClassP tc args))) + checkTParams :: Bool -- Type/data family -> [LHsType RdrName] -> P ([LHsTyVarBndr RdrName], Maybe [LHsType RdrName]) @@ -851,8 +867,20 @@ checkValSig checkValSig (L l (HsVar v)) ty | isUnqual v && not (isDataOcc (rdrNameOcc v)) = return (TypeSig (L l v) ty) -checkValSig (L l _) _ - = parseError l "Invalid type signature" +checkValSig lhs@(L l _) _ + | looks_like_foreign lhs + = parseError l "Invalid type signature; perhaps you meant to use -XForeignFunctionInterface?" + | otherwise + = parseError l "Invalid type signature: should be of form :: " + where + -- A common error is to forget the ForeignFunctionInterface flag + -- so check for that, and suggest. cf Trac #3805 + -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword + looks_like_foreign (L _ (HsVar v)) = v == foreign_RDR + looks_like_foreign (L _ (HsApp lhs _)) = looks_like_foreign lhs + looks_like_foreign _ = False + + foreign_RDR = mkUnqual varName (fsLit "foreign") \end{code} @@ -945,13 +973,21 @@ 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_sat = Nothing + , 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 @@ -964,9 +1000,10 @@ mkImport :: CCallConv -> P (HsDecl RdrName) 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" @@ -981,21 +1018,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 == '_')