From da6d68163ee3744ea8db66702b6937ebe57c86b2 Mon Sep 17 00:00:00 2001 From: David Waern Date: Tue, 27 Dec 2011 20:50:26 +0100 Subject: Complete support for inferring types for top-level bindings. --- src/Haddock/Interface/Create.hs | 76 ++++++++++++++++++++++++----------------- 1 file changed, 44 insertions(+), 32 deletions(-) (limited to 'src') diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index f89bcbc0..408e37d1 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -390,10 +390,10 @@ mkExportItems mkExportItems modMap thisMod gre exportedNames decls0 docMap argMap subMap declMap optExports _ instIfaceMap dflags = case optExports of - Nothing -> liftErrMsg $ fullContentsOfThisModule dflags gre docMap argMap subMap decls + Nothing -> fullContentsOfThisModule dflags gre docMap argMap subMap declMap decls Just exports -> liftM (nubBy commaDeclared . concat) $ mapM lookupExport exports where - decls = filter (\(L _ d) -> not (isInstD d || isValD d)) decls0 + decls = filter (not . isInstD . unLoc) decls0 -- A type signature can have multiple names, like: -- foo, bar :: Types.. @@ -409,7 +409,7 @@ mkExportItems modMap thisMod gre exportedNames decls0 docMap argMap subMap declM lookupExport (IEThingAll t) = declWith t lookupExport (IEThingWith t _) = declWith t lookupExport (IEModuleContents m) = - moduleExports thisMod m dflags gre exportedNames decls modMap instIfaceMap docMap argMap subMap + moduleExports thisMod m dflags gre exportedNames decls modMap instIfaceMap docMap argMap subMap declMap lookupExport (IEGroup lev docStr) = liftErrMsg $ ifDoc (lexParseRnHaddockComment dflags DocSectionComment gre docStr) (\doc -> return [ ExportGroup lev "" doc ]) @@ -431,15 +431,12 @@ mkExportItems modMap thisMod gre exportedNames decls0 docMap argMap subMap declM declWith :: Name -> ErrMsgGhc [ ExportItem Name ] declWith t = - let doc = (M.lookup t docMap, maybe M.empty id (M.lookup t argMap)) in + let (doc, subs) = exportDecl t docMap argMap subMap in case findDecl t of [L _ (ValD _)] -> do -- Top-level binding without type signature - mayDecl <- ifaceDecl t - case mayDecl of - Nothing -> return [ ExportNoDecl t [] ] - Just decl -> return [ ExportDecl decl doc [] [] ] - + export <- hiValExportItem t doc + return [export] ds | decl : _ <- filter (not . isValD . unLoc) ds -> let declNames = getMainDeclBinder (unL decl) in case () of @@ -462,7 +459,7 @@ mkExportItems modMap thisMod gre exportedNames decls0 docMap argMap subMap declM return [] -- normal case - | otherwise -> return [ mkExportDecl t newDecl (exportDecl t newDecl docMap argMap subMap) ] + | otherwise -> return [ mkExportDecl t newDecl (doc, subs) ] where -- Since a single signature might refer to many names, we -- need to filter the ones that are actually exported. This @@ -477,7 +474,7 @@ mkExportItems modMap thisMod gre exportedNames decls0 docMap argMap subMap declM -- Declaration from another package [] -> do - mayDecl <- ifaceDecl t + mayDecl <- hiDecl t case mayDecl of Nothing -> return [ ExportNoDecl t [] ] Just decl -> do @@ -487,10 +484,10 @@ mkExportItems modMap thisMod gre exportedNames decls0 docMap argMap subMap declM Nothing -> do liftErrMsg $ tell ["Warning: Couldn't find .haddock for export " ++ pretty t] - let subs = [ (n, noDocForDecl) | (n, _, _) <- subordinates (unLoc decl) ] - return [ mkExportDecl t decl (noDocForDecl, subs) ] + let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates (unLoc decl) ] + return [ mkExportDecl t decl (noDocForDecl, subs_) ] Just iface -> do - return [ mkExportDecl t decl (exportDecl t decl (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] + return [ mkExportDecl t decl (exportDecl t (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] _ -> return [] @@ -508,17 +505,16 @@ mkExportItems modMap thisMod gre exportedNames decls0 docMap argMap subMap declM findDecl :: Name -> [Decl] - findDecl n - | m == thisMod = maybe [] id (M.lookup n declMap) - | otherwise = case M.lookup m modMap of - Just iface -> maybe [] id (M.lookup n (ifaceDeclMap iface)) - Nothing -> [] + findDecl name + | mdl == thisMod = maybe [] id (M.lookup name declMap) + | Just iface <- M.lookup mdl modMap = maybe [] id (M.lookup name (ifaceDeclMap iface)) + | otherwise = [] where - m = nameModule n + mdl = nameModule name -ifaceDecl :: Name -> ErrMsgGhc (Maybe (LHsDecl Name)) -ifaceDecl t = do +hiDecl :: Name -> ErrMsgGhc (Maybe (LHsDecl Name)) +hiDecl t = do mayTyThing <- liftGhcToErrMsgGhc $ lookupName t case mayTyThing of Nothing -> do @@ -527,8 +523,16 @@ ifaceDecl t = do Just x -> return (Just (tyThingToLHsDecl x)) -exportDecl :: Name -> Decl -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)]) -exportDecl name _ docMap argMap subMap = +hiValExportItem :: Name -> DocForDecl Name -> ErrMsgGhc (ExportItem Name) +hiValExportItem name doc = do + mayDecl <- hiDecl name + case mayDecl of + Nothing -> return (ExportNoDecl name []) + Just decl -> return (ExportDecl decl doc [] []) + + +exportDecl :: Name -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)]) +exportDecl name docMap argMap subMap = let lookupArgMap x = maybe M.empty id (M.lookup x argMap) in let doc = (M.lookup name docMap, lookupArgMap name) in let subs = [ (sub, (M.lookup sub docMap, lookupArgMap sub)) | sub <- maybe [] id (M.lookup name subMap) ] in @@ -559,9 +563,10 @@ moduleExports :: Module -- ^ Module A -> DocMap Name -> ArgMap Name -> SubMap + -> DeclMap -> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items -moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap docMap argMap subMap - | m == thisMod = liftErrMsg $ fullContentsOfThisModule dflags gre docMap argMap subMap decls +moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap docMap argMap subMap declMap + | m == thisMod = fullContentsOfThisModule dflags gre docMap argMap subMap declMap decls | otherwise = case M.lookup m ifaceMap of Just iface @@ -599,21 +604,28 @@ moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap doc -- (For more information, see Trac #69) -fullContentsOfThisModule :: DynFlags -> GlobalRdrEnv -> DocMap Name -> ArgMap Name -> SubMap -> [Decl] -> ErrMsgM [ExportItem Name] -fullContentsOfThisModule dflags gre docMap argMap subMap decls = liftM catMaybes $ mapM mkExportItem decls +fullContentsOfThisModule :: DynFlags -> GlobalRdrEnv -> DocMap Name -> ArgMap Name -> SubMap -> DeclMap -> [Decl] -> ErrMsgGhc [ExportItem Name] +fullContentsOfThisModule dflags gre docMap argMap subMap declMap decls = liftM catMaybes $ mapM mkExportItem decls where mkExportItem (L _ (DocD (DocGroup lev docStr))) = do - mbDoc <- lexParseRnHaddockComment dflags DocSectionComment gre docStr + mbDoc <- liftErrMsg $ lexParseRnHaddockComment dflags DocSectionComment gre docStr return $ fmap (ExportGroup lev "") mbDoc mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do - mbDoc <- lexParseRnHaddockComment dflags NormalHaddockComment gre docStr + mbDoc <- liftErrMsg $ lexParseRnHaddockComment dflags NormalHaddockComment gre docStr return $ fmap ExportDoc mbDoc + mkExportItem (L _ (ValD d)) + | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap = + -- Top-level binding without type signature + let (doc, _) = exportDecl name docMap argMap subMap in + fmap Just (hiValExportItem name doc) + | otherwise = return Nothing mkExportItem decl - | name : _ <- getMainDeclBinder (unLoc decl) = - let (doc, subs) = exportDecl name decl docMap argMap subMap in + | name:_ <- getMainDeclBinder (unLoc decl) = + let (doc, subs) = exportDecl name docMap argMap subMap in return $ Just (ExportDecl decl doc subs []) | otherwise = return Nothing + -- | Sometimes the declaration we want to export is not the "main" declaration: -- it might be an individual record selector or a class method. In these -- cases we have to extract the required declaration (and somehow cobble -- cgit v1.2.3