X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Fparser%2FRdrHsSyn.lhs;h=cd82da1be4e2b7423a0a8968433939db07143335;hb=16513d4899e167d20e120c2b3907230b7ff9dd83;hp=9a3c70a50ebc53e85c6c3c0a2ef91e07485bfc6c;hpb=c2a3f5861959f9b80ee65c16212447788217223d;p=ghc-hetmet.git diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 9a3c70a..cd82da1 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -231,15 +231,18 @@ getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName] -- -- No AndMonoBinds or EmptyMonoBinds here; just single equations -getMonoBind (L loc bind@(FunBind { fun_id = L _ f, fun_matches = MatchGroup mtchs _ })) binds - | has_args mtchs - = go mtchs loc binds +getMonoBind (L loc1 bind@(FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1, + fun_matches = MatchGroup mtchs1 _ })) binds + | has_args mtchs1 + = go is_infix1 mtchs1 loc1 binds where - 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 (bind { fun_matches = mkMatchGroup (reverse mtchs1) }), binds) + go is_infix mtchs loc + (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2, + fun_matches = MatchGroup mtchs2 _ })) : binds) + | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs) + (combineSrcSpans loc loc2) binds + go is_infix mtchs loc binds + = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), binds) -- Reverse the final matches, to get it back in the right order getMonoBind bind binds = (bind, binds) @@ -603,12 +606,16 @@ checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss) | 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 }) + return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)]) -- The span of the match covers the entire equation. -- That isn't quite right, but it'll do for now. +makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id +-- Like HsUtils.mkFunBind, but we need to be able to set the fixity too +makeFunBind fn is_infix ms + = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms, + fun_co_fn = idCoercion, bind_fvs = placeHolderNames } + checkPatBind lhs (L _ grhss) = do { lhs <- checkPattern lhs ; return (PatBind lhs grhss placeHolderType placeHolderNames) } @@ -623,30 +630,22 @@ checkValSig (L l (HsVar v)) ty checkValSig (L l other) ty = parseError l "Invalid type signature" -mkGadtDecl - :: Located RdrName - -> LHsType RdrName -- assuming HsType - -> ConDecl RdrName -mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = ConDecl - { con_name = name - , con_explicit = Implicit - , con_qvars = qvars - , con_cxt = cxt - , con_details = PrefixCon args - , con_res = ResTyGADT res - } - where - (args, res) = splitHsFunType ty -mkGadtDecl name ty = ConDecl - { con_name = name - , con_explicit = Implicit - , con_qvars = [] - , con_cxt = noLoc [] - , con_details = PrefixCon args - , con_res = ResTyGADT res - } - where - (args, res) = splitHsFunType ty +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 + +mk_gadt_con name qvars cxt ty + = ConDecl { con_name = name + , con_explicit = Implicit + , con_qvars = qvars + , con_cxt = cxt + , con_details = PrefixCon [] + , con_res = ResTyGADT ty } + -- NB: we put the whole constr type into the ResTyGADT for now; + -- the renamer will unravel it once it has sorted out + -- operator fixities -- A variable binding is parsed as a FunBind. @@ -672,15 +671,29 @@ isFunLhs e = go e [] | 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 + + -- For infix function defns, there should be only one infix *function* + -- (though there may be infix *datacons* involved too). So we don't + -- need fixity info to figure out which function is being defined. + -- a `K1` b `op` c `K2` d + -- must parse as + -- (a `K1` b) `op` (c `K2` d) + -- The renamer checks later that the precedences would yield such a parse. + -- + -- There is a complication to deal with bang patterns. + -- + -- ToDo: what about this? + -- x + 1 `op` y = ... + 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) + | not (isRdrDataCon op) -- We have found the function! = return (Just (L loc' op, True, (l:r:es))) - | otherwise + | otherwise -- Infix data con; keep going = do { mb_l <- go l es ; case mb_l of Just (op', True, j : k : es') @@ -734,10 +747,10 @@ mkImport :: CallConv -> P (HsDecl RdrName) mkImport (CCall cconv) safety (entity, v, ty) = do importSpec <- parseCImport entity cconv safety v - return (ForD (ForeignImport v ty importSpec False)) + return (ForD (ForeignImport v ty importSpec)) mkImport (DNCall ) _ (entity, v, ty) = do spec <- parseDImport entity - return $ ForD (ForeignImport v ty (DNImport spec) False) + return $ ForD (ForeignImport v ty (DNImport spec)) -- parse the entity string of a foreign import declaration for the `ccall' or -- `stdcall' calling convention' @@ -838,7 +851,7 @@ mkExport :: CallConv -> (Located FastString, Located RdrName, LHsType RdrName) -> P (HsDecl RdrName) mkExport (CCall cconv) (L loc entity, v, ty) = return $ - ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False) + ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv))) where entity' | nullFS entity = mkExtName (unLoc v) | otherwise = entity