X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fparser%2FRdrHsSyn.lhs;h=687ffd2bbcf7d1da95a968210e38f2ac6a338cf3;hb=e3dd39bf230380f02d73efc287226117bb2eb47f;hp=7373ec09b5c8deaaf5e8978801d293e7f6b1b3b3;hpb=cb8044ebabb64a91d9bd7c857f0c60d8b034086d;p=ghc-hetmet.git diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 7373ec0..687ffd2 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -15,7 +15,7 @@ module RdrHsSyn ( mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp cvBindGroup, - cvBindsAndSigs, + cvBindsAndSigs, cvTopDecls, findSplice, mkGroup, @@ -42,6 +42,7 @@ module RdrHsSyn ( checkInstType, -- HsType -> P HsType checkDerivDecl, -- LDerivDecl RdrName -> P (LDerivDecl RdrName) checkPattern, -- HsExp -> P HsPat + bang_RDR, checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat] checkDo, -- [Stmt] -> P [Stmt] checkMDo, -- [Stmt] -> P [Stmt] @@ -96,8 +97,9 @@ extractHsRhoRdrTyVars ctxt ty extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt) -extract_pred (HsClassP cls tys) acc = foldr extract_lty acc tys -extract_pred (HsIParam n ty) acc = extract_lty ty acc +extract_pred (HsClassP cls tys) acc = foldr extract_lty acc tys +extract_pred (HsEqualP ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc) +extract_pred (HsIParam n ty ) acc = extract_lty ty acc extract_lty (L loc ty) acc = case ty of @@ -119,6 +121,7 @@ extract_lty (L loc ty) acc extract_lctxt cx (extract_lty ty [])) where locals = hsLTyVarNames tvs + HsDocTy ty doc -> extract_lty ty acc extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName] extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc @@ -155,12 +158,13 @@ Similarly for mkConDecl, mkClassOpSig and default-method names. *** See "THE NAMING STORY" in HsDecls **** \begin{code} -mkClassDecl (cxt, cname, tyvars) fds sigs mbinds ats +mkClassDecl (cxt, cname, tyvars) fds sigs mbinds ats docs = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, tcdMeths = mbinds, - tcdATs = ats + tcdATs = ats, + tcdDocs = docs } mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv @@ -203,29 +207,30 @@ 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 --- +-- Declaration list may only contain value bindings and signatures. cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName cvBindGroup binding = case cvBindsAndSigs binding of - (mbs, sigs, []) -> -- list of type decls *always* empty + (mbs, sigs, [], _) -> -- list of type decls *always* empty ValBindsIn mbs sigs cvBindsAndSigs :: OrdList (LHsDecl RdrName) - -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName]) + -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [DocEntity RdrName]) -- Input decls contain just value bindings and signatures -- and in case of class or instance declarations also --- associated type declarations +-- associated type declarations. They might also contain Haddock comments. cvBindsAndSigs fb = go (fromOL fb) where - 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) + go [] = (emptyBag, [], [], []) + go (L l x@(SigD s) : ds) = (bs, L l s : ss, ts, add_doc x docs) + where (bs, ss, ts, docs) = go ds + go (L l x@(ValD b) : ds) = (b' `consBag` bs, ss, ts, add_doc x docs) 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 + (bs, ss, ts, docs) = go ds' + go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs) + where (bs, ss, ts, docs) = go ds + go (L _ (DocD d) : ds) = (bs, ss, ts, DocEntity d : docs) + where (bs, ss, ts, docs) = go ds ----------------------------------------------------------------------------- -- Group function bindings into equation groups @@ -240,21 +245,28 @@ getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName] -- belong with b into a single MonoBinds, and ds' is the depleted -- list of parsed bindings. -- +-- All Haddock comments between equations inside the group are +-- discarded. +-- -- No AndMonoBinds or EmptyMonoBinds here; just single equations 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 + = go is_infix1 mtchs1 loc1 binds [] where go is_infix mtchs loc (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2, - fun_matches = MatchGroup mtchs2 _ })) : binds) + 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) + (combineSrcSpans loc loc2) binds [] + go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls + = let doc_decls' = doc_decl : doc_decls + in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls' + go is_infix mtchs loc binds doc_decls + = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds) -- Reverse the final matches, to get it back in the right order + -- Do the same thing with the trailing doc comments getMonoBind bind binds = (bind, binds) @@ -292,35 +304,50 @@ add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a] add gp l (SpliceD e) ds = (gp, Just (e, ds)) -- Class declarations: pull out the fixity signatures to the top -add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds +add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs, hs_docs = docs}) + l decl@(TyClD d) ds | isClassDecl d = let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in - addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs }) ds + addl (gp { hs_tyclds = L l d : ts, + hs_fixds = fsigs ++ fs, + hs_docs = add_doc decl docs}) ds + | isFamInstDecl d = + addl (gp { hs_tyclds = L l d : ts }) ds | otherwise = - addl (gp { hs_tyclds = L l d : ts }) ds + addl (gp { hs_tyclds = L l d : ts, + hs_docs = add_doc decl docs }) ds -- Signatures: fixity sigs go a different place than all others add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds = addl (gp {hs_fixds = L l f : ts}) ds -add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds - = addl (gp {hs_valds = add_sig (L l d) ts}) ds +add gp@(HsGroup {hs_valds = ts, hs_docs = docs}) l x@(SigD d) ds + = addl (gp {hs_valds = add_sig (L l d) ts, hs_docs = add_doc x docs}) ds -- Value declarations: use add_bind -add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds - = addl (gp { hs_valds = add_bind (L l d) ts }) ds +add gp@(HsGroup {hs_valds = ts, hs_docs = docs}) l x@(ValD d) ds + = addl (gp { hs_valds = add_bind (L l d) ts, hs_docs = add_doc x docs }) ds -- The rest are routine add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds = addl (gp { hs_instds = L l d : ts }) ds +add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds + = addl (gp { hs_derivds = L l d : ts }) ds add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds = addl (gp { hs_defds = L l d : ts }) ds -add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds - = addl (gp { hs_fords = L l d : ts }) ds +add gp@(HsGroup {hs_fords = ts, hs_docs = docs}) l x@(ForD d) ds + = addl (gp { hs_fords = L l d : ts, hs_docs = add_doc x docs }) ds add gp@(HsGroup {hs_depds = ts}) l (DeprecD d) ds = addl (gp { hs_depds = L l d : ts }) ds add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds = addl (gp { hs_ruleds = L l d : ts }) ds +add gp l (DocD d) ds + = addl (gp { hs_docs = DocEntity d : (hs_docs gp) }) ds + +add_doc decl docs = case getMainDeclBinder decl of + Just name -> DeclEntity name : docs + Nothing -> docs + add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) \end{code} @@ -351,11 +378,12 @@ mkPrefixCon ty tys return (data_con, PrefixCon ts) split (L l _) _ = parseError l "parse error in data/newtype declaration" -mkRecCon :: Located RdrName -> [([Located RdrName], LBangType RdrName)] - -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName)) +mkRecCon :: Located RdrName -> + [([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName))] -> + P (Located RdrName, HsConDetails RdrName (LBangType RdrName)) mkRecCon (L loc con) fields = do data_con <- tyConToDataCon loc con - return (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ]) + return (data_con, RecCon [ (HsRecField l t d) | (ls, t, d) <- fields, l <- ls ]) tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName) tyConToDataCon loc tc @@ -379,6 +407,15 @@ checkInstType (L l t) ty -> do dict_ty <- checkDictTy (L l ty) return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty)) +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 (HsAppTy l r) args = check (unLoc l) (r:args) + check (HsParTy t) args = check (unLoc t) args + check _ _ = parseError spn "Malformed instance header" + -- Check whether the given list of type parameters are all type variables -- (possibly with a kind signature). If the second argument is `False', -- only type variables are allowed and we raise an error on encountering a @@ -450,10 +487,12 @@ checkTyClHdr (L l cxt) ty 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, - -- even in Haskell 98. E.g. class (Monad m, Monad (t m)) => MonadT t m - chk_pred (L l (HsClassP _ args)) = return () + -- The predicates in a type or class decl must be class predicates or + -- equational constraints. They need not all have variable-only + -- arguments, even in Haskell 98. + -- E.g. class (Monad m, Monad (t m)) => MonadT t m + chk_pred (L l (HsClassP _ _)) = return () + chk_pred (L l (HsEqualP _ _)) = return () chk_pred (L l _) = parseError l "Malformed context in type or class declaration" @@ -509,7 +548,7 @@ checkKindSigs :: [LTyClDecl RdrName] -> P () checkKindSigs = mapM_ check where check (L l tydecl) - | isKindSigDecl tydecl + | isFamilyDecl tydecl || isSynDecl tydecl = return () | otherwise = parseError l "Type declaration in a class must be a kind signature or synonym default" @@ -544,22 +583,16 @@ checkPred (L spn ty) where checkl (L l ty) args = check l ty args + check _loc (HsPredTy pred@(HsEqualP _ _)) + args | null args + = return $ L spn pred check _loc (HsTyVar t) args | not (isRdrTyVar t) = return (L spn (HsClassP t args)) check _loc (HsAppTy l r) args = checkl l (r:args) check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args) check _loc (HsParTy t) args = checkl t args - check loc _ _ = parseError loc "malformed class assertion" - -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 (HsAppTy l r) args = check (unLoc l) (r:args) - check (HsParTy t) args = check (unLoc t) args - check _ _ = parseError spn "Malformed context in instance header" - + check loc _ _ = parseError loc + "malformed class assertion" --------------------------------------------------------------------------- -- Checking stand-alone deriving declarations @@ -680,7 +713,7 @@ checkAPat loc e = case e of return (TuplePat ps b placeHolderType) RecordCon c _ fs -> mapM checkPatField fs >>= \fs -> - return (ConPatIn c (RecCon fs)) + return (ConPatIn c (RecCon (map (uncurry mkRecField) fs))) -- Generics HsType ty -> return (TypePat ty) _ -> patFail loc @@ -731,7 +764,7 @@ 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 = idHsWrapper, bind_fvs = placeHolderNames } + fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing } checkPatBind lhs (L _ grhss) = do { lhs <- checkPattern lhs @@ -759,7 +792,8 @@ mk_gadt_con name qvars cxt ty , con_qvars = qvars , con_cxt = cxt , con_details = PrefixCon [] - , con_res = ResTyGADT ty } + , con_res = ResTyGADT ty + , con_doc = Nothing } -- NB: we put the whole constr type into the ResTyGADT for now; -- the renamer will unravel it once it has sorted out -- operator fixities