X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FRdrHsSyn.lhs;h=8d59e2b22ce3a40db205647e4329afdec991477f;hb=5d3051c66796dcf884b052f9e4afc3ed19b9f514;hp=2d18d6d5df9e838ccbe2b93d36f0acf9f724248b;hpb=87998bebdee5e97a19c52a2e33cd394cdf9c0c57;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 2d18d6d..8d59e2b 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -54,12 +54,12 @@ import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc, isRdrDataCon, isUnqual, getRdrName, isQual, setRdrNameSpace ) import BasicTypes ( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec ) -import Lexer ( P, failSpanMsgP ) +import Lexer ( P, failSpanMsgP, extension, bangPatEnabled ) import TysWiredIn ( unitTyCon ) import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..), DNCallSpec(..), DNKind(..), CLabelString ) import OccName ( srcDataName, varName, isDataOcc, isTcOcc, - occNameUserString ) + occNameString ) import SrcLoc import OrdList ( OrdList, fromOL ) import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag ) @@ -126,8 +126,8 @@ extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName] extractGenericPatTyVars binds = nubBy eqLocated (foldrBag get [] binds) where - get (L _ (FunBind _ _ (MatchGroup ms _) _)) acc = foldr (get_m.unLoc) acc ms - get other acc = acc + get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms + get other acc = acc get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc get_m other acc = acc @@ -231,15 +231,15 @@ getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName] -- -- No AndMonoBinds or EmptyMonoBinds here; just single equations -getMonoBind (L loc (FunBind lf@(L _ f) inf (MatchGroup mtchs _) _)) binds +getMonoBind (L loc bind@(FunBind { fun_id = L _ f, fun_matches = MatchGroup mtchs _ })) binds | has_args mtchs = go mtchs loc binds where - go mtchs1 loc1 (L loc2 (ValD (FunBind f2 inf2 (MatchGroup mtchs2 _) _)) : binds) - | f == unLoc f2 = go (mtchs2++mtchs1) loc binds + go mtchs1 loc1 (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_matches = MatchGroup mtchs2 _ })) : binds) + | f == f2 = go (mtchs2++mtchs1) loc binds where loc = combineSrcSpans loc1 loc2 go mtchs1 loc binds - = (L loc (FunBind lf inf (mkMatchGroup (reverse mtchs1)) placeHolderNames), binds) + = (L loc (bind { fun_matches = mkMatchGroup (reverse mtchs1) }), binds) -- Reverse the final matches, to get it back in the right order getMonoBind bind binds = (bind, binds) @@ -499,12 +499,16 @@ checkLPat e@(L l _) = checkPat l e [] checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName) checkPat loc (L l (HsVar c)) args | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args))) -checkPat loc (L _ (HsApp f x)) args = do - x <- checkLPat x - checkPat loc f (x:args) -checkPat loc (L _ e) [] = do - p <- checkAPat loc e - return (L loc p) +checkPat loc e args -- OK to let this happen even if bang-patterns + -- are not enabled, because there is no valid + -- non-bang-pattern parse of (C ! e) + | Just (e', args') <- splitBang e + = do { args'' <- checkPatterns args' + ; checkPat loc e' (args'' ++ args) } +checkPat loc (L _ (HsApp f x)) args + = do { x <- checkLPat x; checkPat loc f (x:args) } +checkPat loc (L _ e) [] + = do { p <- checkAPat loc e; return (L loc p) } checkPat loc pat _some_args = patFail loc @@ -523,8 +527,10 @@ checkAPat loc e = case e of NegApp (L _ (HsOverLit pos_lit)) _ -> return (mkNPat pos_lit (Just noSyntaxExpr)) - ELazyPat e -> checkLPat e >>= (return . LazyPat) - EAsPat n e -> checkLPat e >>= (return . AsPat n) + SectionR (L _ (HsVar bang)) e + | bang == bang_RDR -> checkLPat e >>= (return . BangPat) + ELazyPat e -> checkLPat e >>= (return . LazyPat) + EAsPat n e -> checkLPat e >>= (return . AsPat n) ExprWithTySig e t -> checkLPat e >>= \e -> -- Pattern signatures are parsed as sigtypes, -- but they aren't explicit forall points. Hence @@ -540,8 +546,6 @@ checkAPat loc e = case e of (L _ (HsOverLit lit@(HsIntegral _ _))) | plus == plus_RDR -> return (mkNPlusKPat (L nloc n) lit) - where - plus_RDR = mkUnqual varName FSLIT("+") -- Hack OpApp l op fix r -> checkLPat l >>= \l -> checkLPat r >>= \r -> @@ -557,7 +561,7 @@ checkAPat loc e = case e of return (PArrPat ps placeHolderType) ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps -> - return (TuplePat ps b) + return (TuplePat ps b placeHolderType) RecordCon c _ fs -> mapM checkPatField fs >>= \fs -> return (ConPatIn c (RecCon fs)) @@ -565,6 +569,10 @@ checkAPat loc e = case e of HsType ty -> return (TypePat ty) _ -> patFail loc +plus_RDR, bang_RDR :: RdrName +plus_RDR = mkUnqual varName FSLIT("+") -- Hack +bang_RDR = mkUnqual varName FSLIT("!") -- Hack + checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName) checkPatField (n,e) = do p <- checkLPat e @@ -576,34 +584,44 @@ patFail loc = parseError loc "Parse error in pattern" --------------------------------------------------------------------------- -- Check Equation Syntax -checkValDef - :: LHsExpr RdrName - -> Maybe (LHsType RdrName) - -> Located (GRHSs RdrName) - -> P (HsBind RdrName) - -checkValDef lhs opt_sig (L rhs_span grhss) - | Just (f,inf,es) <- isFunLhs lhs [] - = if isQual (unLoc f) - then parseError (getLoc f) ("Qualified name in function definition: " ++ - showRdrName (unLoc f)) - else do ps <- checkPatterns es - let match_span = combineSrcSpans (getLoc lhs) rhs_span - matches = mkMatchGroup [L match_span (Match ps opt_sig grhss)] - return (FunBind f inf matches placeHolderNames) +checkValDef :: LHsExpr RdrName + -> Maybe (LHsType RdrName) + -> Located (GRHSs RdrName) + -> P (HsBind RdrName) + +checkValDef lhs opt_sig grhss + = do { mb_fun <- isFunLhs lhs + ; case mb_fun of + Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs) + fun is_infix pats opt_sig grhss + Nothing -> checkPatBind lhs grhss } + +checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss) + | isQual (unLoc fun) + = parseError (getLoc fun) ("Qualified name in function definition: " ++ + showRdrName (unLoc fun)) + | otherwise + = do ps <- checkPatterns pats + let match_span = combineSrcSpans lhs_loc rhs_span + matches = mkMatchGroup [L match_span (Match ps opt_sig grhss)] + return (FunBind { fun_id = fun, fun_infix = is_infix, fun_matches = matches, + fun_co_fn = idCoercion, bind_fvs = placeHolderNames }) -- The span of the match covers the entire equation. -- That isn't quite right, but it'll do for now. - | otherwise = do - lhs <- checkPattern lhs - return (PatBind lhs grhss placeHolderType placeHolderNames) + +checkPatBind lhs (L _ grhss) + = do { lhs <- checkPattern lhs + ; return (PatBind lhs grhss placeHolderType placeHolderNames) } checkValSig :: LHsExpr RdrName -> LHsType RdrName -> P (Sig RdrName) -checkValSig (L l (HsVar v)) ty | isUnqual v = return (TypeSig (L l v) ty) +checkValSig (L l (HsVar v)) ty + | isUnqual v && not (isDataOcc (rdrNameOcc v)) + = return (TypeSig (L l v) ty) checkValSig (L l other) ty - = parseError l "Type signature given for an expression" + = parseError l "Invalid type signature" mkGadtDecl :: Located RdrName @@ -632,23 +650,45 @@ mkGadtDecl name ty = ConDecl -- A variable binding is parsed as a FunBind. -isFunLhs :: LHsExpr RdrName -> [LHsExpr RdrName] - -> Maybe (Located RdrName, Bool, [LHsExpr RdrName]) -isFunLhs (L loc e) = isFunLhs' loc e + + -- The parser left-associates, so there should + -- not be any OpApps inside the e's +splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName]) +-- Splits (f ! g a b) into (f, [(! g), a, g]) +splitBang (L loc (OpApp l_arg bang@(L loc' (HsVar op)) _ r_arg)) + | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns) + where + (arg1,argns) = split_bang r_arg [] + split_bang (L _ (HsApp f e)) es = split_bang f (e:es) + split_bang e es = (e,es) +splitBang other = Nothing + +isFunLhs :: LHsExpr RdrName + -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName])) +-- Just (fun, is_infix, arg_pats) if e is a function LHS +isFunLhs e = go e [] where - isFunLhs' loc (HsVar f) es - | not (isRdrDataCon f) = Just (L loc f, False, es) - isFunLhs' loc (HsApp f e) es = isFunLhs f (e:es) - isFunLhs' loc (HsPar e) es@(_:_) = isFunLhs e es - isFunLhs' loc (OpApp l (L loc' (HsVar op)) fix r) es - | not (isRdrDataCon op) = Just (L loc' op, True, (l:r:es)) - | otherwise = - case isFunLhs l es of - Just (op', True, j : k : es') -> - Just (op', True, - j : L loc (OpApp k (L loc' (HsVar op)) fix r) : es') - _ -> Nothing - isFunLhs' _ _ _ = Nothing + go (L loc (HsVar f)) es + | not (isRdrDataCon f) = return (Just (L loc f, False, es)) + go (L _ (HsApp f e)) es = go f (e:es) + go (L _ (HsPar e)) es@(_:_) = go e es + go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es + | Just (e',es') <- splitBang e + = do { bang_on <- extension bangPatEnabled + ; if bang_on then go e' (es' ++ es) + else return (Just (L loc' op, True, (l:r:es))) } + -- No bangs; behave just like the next case + | not (isRdrDataCon op) + = return (Just (L loc' op, True, (l:r:es))) + | otherwise + = do { mb_l <- go l es + ; case mb_l of + Just (op', True, j : k : es') + -> return (Just (op', True, j : op_app : es')) + where + op_app = L loc (OpApp k (L loc' (HsVar op)) fix r) + _ -> return Nothing } + go _ _ = return Nothing --------------------------------------------------------------------------- -- Miscellaneous utilities @@ -800,8 +840,8 @@ mkExport :: CallConv mkExport (CCall cconv) (L loc entity, v, ty) = return $ ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False) where - entity' | nullFastString entity = mkExtName (unLoc v) - | otherwise = entity + entity' | nullFS entity = mkExtName (unLoc v) + | otherwise = entity mkExport DNCall (L loc entity, v, ty) = parseError (getLoc v){-TODO: not quite right-} "Foreign export is not yet supported for .NET" @@ -811,10 +851,9 @@ mkExport DNCall (L loc entity, v, ty) = -- of the Haskell name is then performed, so if you foreign export (++), -- it's external name will be "++". Too bad; it's important because we don't -- want z-encoding (e.g. names with z's in them shouldn't be doubled) --- (This is why we use occNameUserString.) -- mkExtName :: RdrName -> CLabelString -mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm)) +mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm)) \end{code}