X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FRdrHsSyn.lhs;h=777ff64d8c42d1921f0dc0d037ea1b32b682b8cd;hp=8d59e2b22ce3a40db205647e4329afdec991477f;hb=afef39736dcde6f4947a6f362f9e6b3586933db4;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 8d59e2b..777ff64 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -8,7 +8,7 @@ module RdrHsSyn ( extractHsTyRdrTyVars, extractHsRhoRdrTyVars, extractGenericPatTyVars, - mkHsOpApp, mkClassDecl, + mkHsOpApp, mkClassDecl, mkHsNegApp, mkHsIntegral, mkHsFractional, mkHsDo, mkHsSplice, mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec, @@ -36,7 +36,9 @@ module RdrHsSyn ( checkContext, -- HsType -> P HsContext checkPred, -- HsType -> P HsPred checkTyClHdr, -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName]) + checkTyVars, -- [LHsType RdrName] -> P () checkSynHdr, -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName]) + checkTopTyClD, -- LTyClDecl RdrName -> P (HsDecl RdrName) checkInstType, -- HsType -> P HsType checkPattern, -- HsExp -> P HsPat checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat] @@ -155,12 +157,13 @@ mkClassDecl (cxt, cname, tyvars) fds sigs mbinds = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, - tcdMeths = mbinds + tcdMeths = mbinds, + tcdATs = ats } -mkTyData new_or_data (context, tname, tyvars) ksig data_cons maybe_deriv +mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname, - tcdTyVars = tyvars, tcdCons = data_cons, + tcdTyVars = tyvars, tcdTyPats = typats, tcdCons = data_cons, tcdKindSig = ksig, tcdDerivs = maybe_deriv } \end{code} @@ -198,23 +201,29 @@ cvTopDecls decls = go (fromOL decls) where (L l' b', ds') = getMonoBind (L l b) ds go (d : ds) = d : go ds +-- Declaration list may only contain value bindings and signatures +-- cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName cvBindGroup binding - = case (cvBindsAndSigs binding) of { (mbs, sigs) -> - ValBindsIn mbs sigs - } + = case cvBindsAndSigs binding of + (mbs, sigs, []) -> -- list of type decls *always* empty + ValBindsIn mbs sigs cvBindsAndSigs :: OrdList (LHsDecl RdrName) - -> (Bag (LHsBind RdrName), [LSig RdrName]) + -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName]) -- Input decls contain just value bindings and signatures +-- and in case of class or instance declarations also +-- associated data or synonym definitions cvBindsAndSigs fb = go (fromOL fb) where - go [] = (emptyBag, []) - go (L l (SigD s) : ds) = (bs, L l s : ss) - where (bs,ss) = go ds - go (L l (ValD b) : ds) = (b' `consBag` bs, ss) - where (b',ds') = getMonoBind (L l b) ds - (bs,ss) = go ds' + go [] = (emptyBag, [], []) + go (L l (SigD s) : ds) = (bs, L l s : ss, ts) + where (bs, ss, ts) = go ds + go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts) + where (b', ds') = getMonoBind (L l b) ds + (bs, ss, ts) = go ds' + go (L l (TyClD t): ds) = (bs, ss, L l t : ts) + where (bs, ss, ts) = go ds ----------------------------------------------------------------------------- -- Group function bindings into equation groups @@ -222,7 +231,7 @@ cvBindsAndSigs fb = go (fromOL fb) getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName] -> (LHsBind RdrName, [LHsDecl RdrName]) -- Suppose (b',ds') = getMonoBind b ds --- ds is a *reversed* list of parsed bindings +-- ds is a list of parsed bindings -- b is a MonoBinds that has just been read off the front -- Then b' is the result of grouping more equations from ds that @@ -231,15 +240,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) @@ -365,44 +377,61 @@ checkInstType (L l t) ty -> do dict_ty <- checkDictTy (L l ty) return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty)) -checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName] -checkTyVars tvs - = mapM chk tvs +-- Check that the given list of type parameters are all type variables +-- (possibly with a kind signature). +-- +checkTyVars :: [LHsType RdrName] -> P () +checkTyVars tvs = mapM_ chk tvs where - -- Check that the name space is correct! + -- Check that the name space is correct! chk (L l (HsKindSig (L _ (HsTyVar tv)) k)) - | isRdrTyVar tv = return (L l (KindedTyVar tv k)) + | isRdrTyVar tv = return () chk (L l (HsTyVar tv)) - | isRdrTyVar tv = return (L l (UserTyVar tv)) + | isRdrTyVar tv = return () chk (L l other) = parseError l "Type found where type variable expected" checkSynHdr :: LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName]) -checkSynHdr ty = do { (_, tc, tvs) <- checkTyClHdr (noLoc []) ty +checkSynHdr ty = do { (_, tc, tvs, Just tparms) <- checkTyClHdr (noLoc []) ty + ; checkTyVars tparms ; return (tc, tvs) } checkTyClHdr :: LHsContext RdrName -> LHsType RdrName - -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName]) + -> P (LHsContext RdrName, -- the type context + Located RdrName, -- the head symbol (type or class name) + [LHsTyVarBndr RdrName], -- free variables of the non-context part + Maybe [LHsType RdrName]) -- parameters of head symbol; wrapped into + -- 'Maybe' for 'mkTyData' -- The header of a type or class decl should look like -- (C a, D b) => T a b -- or T a b -- or a + b -- etc +-- With associated types, we can also have non-variable parameters; ie, +-- T Int [a] +-- The unaltered parameter list is returned in the fourth component of the +-- result. Eg, for +-- T Int [a] +-- we return +-- ('()', 'T', ['a'], Just ['Int', '[a]']) checkTyClHdr (L l cxt) ty - = do (tc, tvs) <- gol ty [] + = do (tc, tvs, parms) <- gol ty [] mapM_ chk_pred cxt - return (L l cxt, tc, tvs) + return (L l cxt, tc, tvs, Just parms) where gol (L l ty) acc = go l ty acc go l (HsTyVar tc) acc - | not (isRdrTyVar tc) = checkTyVars acc >>= \ tvs -> - return (L l tc, tvs) - go l (HsOpTy t1 tc t2) acc = checkTyVars (t1:t2:acc) >>= \ tvs -> - return (tc, tvs) + | not (isRdrTyVar tc) = do + tvs <- extractTyVars acc + return (L l tc, tvs, acc) + go l (HsOpTy t1 tc t2) acc = do + tvs <- extractTyVars (t1:t2:acc) + return (tc, tvs, acc) go l (HsParTy ty) acc = gol ty acc go l (HsAppTy t1 t2) acc = gol t1 (t2:acc) - go l other acc = parseError l "Malformed LHS to type of class declaration" + go l other acc = + parseError l "Malformed head of type or class declaration" -- The predicates in a type or class decl must all -- be HsClassPs. They need not all be type variables, @@ -411,7 +440,63 @@ checkTyClHdr (L l cxt) ty chk_pred (L l _) = parseError l "Malformed context in type or class declaration" - +-- Extract the type variables of a list of type parameters. +-- +-- * Type arguments can be complex type terms (needed for associated type +-- declarations). +-- +extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName] +extractTyVars tvs = collects [] tvs + where + -- Collect all variables (1st arg serves as an accumulator) + collect tvs (L l (HsForAllTy _ _ _ _)) = + parseError l "Forall type not allowed as type parameter" + collect tvs (L l (HsTyVar tv)) + | isRdrTyVar tv = return $ L l (UserTyVar tv) : tvs + | otherwise = return tvs + collect tvs (L l (HsBangTy _ _ )) = + parseError l "Bang-style type annotations not allowed as type parameter" + collect tvs (L l (HsAppTy t1 t2 )) = do + tvs' <- collect tvs t2 + collect tvs' t1 + collect tvs (L l (HsFunTy t1 t2 )) = do + tvs' <- collect tvs t2 + collect tvs' t1 + collect tvs (L l (HsListTy t )) = collect tvs t + collect tvs (L l (HsPArrTy t )) = collect tvs t + collect tvs (L l (HsTupleTy _ ts )) = collects tvs ts + collect tvs (L l (HsOpTy t1 _ t2 )) = do + tvs' <- collect tvs t2 + collect tvs' t1 + collect tvs (L l (HsParTy t )) = collect tvs t + collect tvs (L l (HsNumTy t )) = return tvs + collect tvs (L l (HsPredTy t )) = + parseError l "Predicate not allowed as type parameter" + collect tvs (L l (HsKindSig (L _ (HsTyVar tv)) k)) + | isRdrTyVar tv = + return $ L l (KindedTyVar tv k) : tvs + | otherwise = + parseError l "Kind signature only allowed for type variables" + collect tvs (L l (HsSpliceTy t )) = + parseError l "Splice not allowed as type parameter" + + -- Collect all variables of a list of types + collects tvs [] = return tvs + collects tvs (t:ts) = do + tvs' <- collects tvs ts + collect tvs' t + +-- Wrap a toplevel type or class declaration into 'TyClDecl' after ensuring +-- that all type parameters are variables only (which is in contrast to +-- associated type declarations). +-- +checkTopTyClD :: LTyClDecl RdrName -> P (HsDecl RdrName) +checkTopTyClD (L _ d@TyData {tcdTyPats = Just typats}) = + do + checkTyVars typats + return $ TyClD d {tcdTyPats = Nothing} +checkTopTyClD (L _ d) = return $ TyClD d + checkContext :: LHsType RdrName -> P (LHsContext RdrName) checkContext (L l t) = check t @@ -527,8 +612,12 @@ checkAPat loc e = case e of NegApp (L _ (HsOverLit pos_lit)) _ -> return (mkNPat pos_lit (Just noSyntaxExpr)) - SectionR (L _ (HsVar bang)) e - | bang == bang_RDR -> checkLPat e >>= (return . BangPat) + SectionR (L _ (HsVar bang)) e -- (! x) + | bang == bang_RDR + -> do { bang_on <- extension bangPatEnabled + ; if bang_on then checkLPat e >>= (return . BangPat) + else parseError loc "Illegal bang-pattern (use -fbang-patterns)" } + ELazyPat e -> checkLPat e >>= (return . LazyPat) EAsPat n e -> checkLPat e >>= (return . AsPat n) ExprWithTySig e t -> checkLPat e >>= \e -> @@ -589,6 +678,10 @@ checkValDef :: LHsExpr RdrName -> Located (GRHSs RdrName) -> P (HsBind RdrName) +checkValDef lhs (Just sig) grhss + -- x :: ty = rhs parses as a *pattern* binding + = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss + checkValDef lhs opt_sig grhss = do { mb_fun <- isFunLhs lhs ; case mb_fun of @@ -603,12 +696,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 +720,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 +761,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 +837,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 +941,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