diff options
Diffstat (limited to 'src/Main.hs')
| -rw-r--r-- | src/Main.hs | 267 |
1 files changed, 246 insertions, 21 deletions
diff --git a/src/Main.hs b/src/Main.hs index b2ea7709..dfc5ee99 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -7,24 +7,19 @@ module Main (main) where -import Binary -import Digraph ---import HaddockDB -- not compiling +import HsSyn2 import HaddockHtml import HaddockHoogle -import HaddockLex -import HaddockParse import HaddockRename import HaddockTypes import HaddockUtil import HaddockVersion -import HsParseMonad -import HsParser -import HsSyn -import Map ( Map ) -import qualified Map hiding ( Map ) import Set import Paths_haddock ( getDataDir ) +import Binary2 +import Digraph2 +import HsParser +import HsParseMonad import Control.Exception ( bracket ) import Control.Monad ( when ) @@ -41,6 +36,10 @@ import System.IO ( stderr, IOMode(..), openFile, hClose, hGetContents, hPutStrLn import Foreign import Foreign.C #endif +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Maybe + #if __GLASGOW_HASKELL__ >= 603 import System.Process @@ -51,6 +50,10 @@ import System.Directory ( doesDirectoryExist, doesFileExist ) import Control.Concurrent #endif +import qualified GHC as GHC +import Outputable +import SrcLoc + ----------------------------------------------------------------------------- -- Top-level stuff main :: IO () @@ -96,6 +99,7 @@ data Flag | Flag_IgnoreAllExports | Flag_HideModule String | Flag_UsePackage String + | Flag_GHCFlag String deriving (Eq) options :: Bool -> [OptDescr Flag] @@ -161,17 +165,21 @@ options backwardsCompat = Option [] ["hide"] (ReqArg Flag_HideModule "MODULE") "behave as if MODULE has the hide attribute", Option [] ["use-package"] (ReqArg Flag_UsePackage "PACKAGE") - "the modules being processed depend on PACKAGE" + "the modules being processed depend on PACKAGE", + Option [] ["ghc-flag"] (ReqArg Flag_GHCFlag "FLAG") + "send a one-word FLAG to the Glasgow Haskell Compiler" ] run :: [Flag] -> [FilePath] -> IO () run flags files = do - when (Flag_Help `elem` flags) $ do + + whenFlag Flag_Help $ do prog <- getProgramName bye (usageInfo (usageHeader prog) (options False)) - when (Flag_Version `elem` flags) $ - bye ("Haddock version " ++ projectVersion ++ ", (c) Simon Marlow 2003\n") + whenFlag Flag_Version $ + bye ("Haddock version " ++ projectVersion ++ + ", (c) Simon Marlow 2003; port to GHC-api by David Waern 2006\n") let title = case [str | Flag_Heading str <- flags] of [] -> "" @@ -249,12 +257,12 @@ run flags files = do && Flag_Html `elem` flags) $ die ("-h cannot be used with --gen-index or --gen-contents") - when (Flag_GenContents `elem` flags) $ do +{- when (Flag_GenContents `elem` flags) $ do ppHtmlContents odir title package maybe_html_help_format maybe_index_url maybe_source_urls maybe_wiki_urls visible_read_ifaces prologue copyHtmlBits odir libdir css_file - +-} when (Flag_GenIndex `elem` flags) $ do ppHtmlIndex odir title package maybe_html_help_format maybe_contents_url maybe_source_urls maybe_wiki_urls @@ -264,7 +272,41 @@ run flags files = do when (Flag_GenContents `elem` flags && Flag_GenIndex `elem` flags) $ do ppHtmlHelpFiles title package visible_read_ifaces odir maybe_html_help_format pkg_paths - parsed_mods <- mapM parse_file files + GHC.init (Just "/home/davve/dev/lib/ghc-6.5.20060608") + let ghcMode = GHC.JustTypecheck + session <- GHC.newSession ghcMode + ghcFlags <- GHC.getSessionDynFlags session + ghcFlags' <- GHC.initPackages ghcFlags + + let haddockGhcFlags = [ f | Flag_GHCFlag f <- flags ] + (ghcFlags'', rest) <- GHC.parseDynamicFlags ghcFlags' haddockGhcFlags + when (not (null rest)) (die $ "The following flags are not GHC flags: " ++ pprList rest ++ "\n") + + GHC.defaultErrorHandler ghcFlags'' $ do + GHC.setSessionDynFlags session ghcFlags'' + targets <- mapM (\s -> GHC.guessTarget s Nothing) files + GHC.setTargets session targets + + -- find out the module names of the targets, and topologically sort those modules + maybe_module_graph <- GHC.depanal session [] True + module_graph <- case maybe_module_graph of + Just module_graph -> return module_graph + Nothing -> die "Failed to load modules" + let sorted_modules = flattenSCC (topSortModuleGraph False module_graph Nothing) + let modules = [ GHC.ms_mod modsum | modsum <- sorted_modules, GHC.ms_hspp_file modsum `elem` files ] + mb_checked_modules <- mapM (GHC.checkModule session) modules + let checked_modules = catMaybes mb_checked_modules + +{- let parsed_source = unLoc $ GHC.parsedSource (head checked_modules) + printSDoc (ppr parsed_source) defaultUserStyle +-} + + return () + -- case successFlag of + -- GHC.Succeeded -> bye "Succeeded" + -- GHC.Failed -> bye "Could not load all targets" + +{- parsed_mods <- mapM parse_file files sorted_mod_files <- sortModules (zip parsed_mods files) -- emits an error message if there are recursive modules @@ -330,7 +372,15 @@ run flags files = do -- dump an interface if requested case dump_iface of Nothing -> return () - Just fn -> dumpInterfaces these_ifaces this_doc_env fn + Just fn -> dumpInterfaces these_ifaces this_doc_env fn -} + where + whenFlag flag action = when (flag `elem` flags) action + + pprList [] = [] + pprList [x] = show x + pprList (x:xs) = show x ++ ", " ++ pprList xs + +--moduleFromFilename filename = parseIfaceOption :: String -> (FilePath,FilePath) parseIfaceOption s = @@ -359,6 +409,7 @@ parse_file file = do Failed err -> die (file ++ ':':err ++ "\n") ) +{- getPrologue :: [Flag] -> IO (Maybe Doc) getPrologue flags = case [filename | Flag_Prologue filename <- flags ] of @@ -369,6 +420,18 @@ getPrologue flags Left err -> dieMsg err Right doc -> return (Just doc) _otherwise -> dieMsg "multiple -p/--prologue options" +-} + +getPrologue :: [Flag] -> IO (Maybe (GHC.HsDoc GHC.RdrName)) +getPrologue flags + = case [filename | Flag_Prologue filename <- flags ] of + [] -> return Nothing + [filename] -> do + str <- readFile filename + case GHC.parseHaddockComment str of + Left err -> dieMsg err + Right doc -> return (Just doc) + _otherwise -> dieMsg "multiple -p/--prologue options" -- --------------------------------------------------------------------------- -- External packages @@ -437,7 +500,7 @@ getPackageIfaces flags verbose = -- -- 2. Convert all the entity references to "doc names". These are -- the names we want to link to in the documentation. - +{- mkInterfacePhase1 :: [Flag] -> Bool -- verbose @@ -598,6 +661,7 @@ mkInterfacePhase2 verbose iface gbl_doc_env = iface_doc = orig_module_doc } -> let + -- [ The export list from the renamed output (sort of) ] exported_visible_names = [orig | (nm,orig) <- Map.toAscList env, nm `notElem` reexports ] @@ -719,12 +783,113 @@ derivedInstances mdl decl = case decl of unknownConstraint :: HsQName unknownConstraint = UnQual (HsTyClsName (HsIdent "???")) +-} -- ----------------------------------------------------------------------------- -- Build the list of items that will become the documentation, from the -- export list. At this point, the list of ExportItems is in terms of -- original names. mkExportItems + :: ModuleMap2 + -> GHC.Module -- this module + -> GHC.NameSet -- exported names (orig) + -> Map GHC.Name (GHC.HsDecl GHC.Name) -- maps local names to declarations + -> Map GHC.Name [GHC.Name] -- sub-map for this module + -> [GHC.HsDecl GHC.Name] -- decls in the current module + -> [DocOption] + -> Maybe [GHC.IE Name] + -> Bool -- --ignore-all-exports flag + -> ErrMsgM [ExportItem] + +mkExportItems mod_map this_mod exported_names decl_map sub_map decls + opts maybe_exps ignore_all_exports + | isNothing maybe_exps || ignore_all_exports || OptIgnoreExports `elem` opts + = everything_local_exported + | Just specs <- maybe_exps = do + exps <- mapM lookupExport specs + return (concat exps) + where + everything_local_exported = -- everything exported + return (fullContentsOfThisModule this_mod decls) + + lookupExport (GHC.IEVar x) = declWith x + lookupExport (GHC.IEThingAbs t) = declWith t + lookupExport (GHC.IEThingAll t) = declWith t + lookupExport (GHC.IEThingWith t cs) = declWith t + lookupExport (GHC.IEModuleContents m) = fullContentsOf m + lookupExport (GHC.IEGroup lev doc) = return [ ExportGroup lev "" doc ] + lookupExport (GHC.IEDoc doc) = return [ ExportDoc doc ] + lookupExport (GHC.IEDocNamed str) + = do r <- findNamedDoc str decls + case r of + Nothing -> return [] + Just found -> return [ ExportDoc found ] + + -- NOTE: I'm unsure about this. Currently only "External" names are considered. + declWith :: GHC.Name -> ErrMsgM [ ExportItem ] + declWith t | not (isExternalName t) = return [] + declWith t + | Just decl <- findDecl t + = return [ ExportDecl t (restrictTo subs (extractDecl x mdl decl)) [] ] + | otherwise + = return [ ExportNoDecl t t (map (Qual mdl) subs) ] + -- can't find the decl (it might be from another package), but let's + -- list the entity anyway. Later on, the renamer will change the + -- orig name into the import name, so we get a proper link to + -- the doc for this entity. + where + Just mdl = nameModule t + x = nameOccName + subs = map nameOfQName subs_qnames + subs_qnames = filter (`elem` exported_names) all_subs_qnames + + all_subs_qnames = map (Qual mdl) all_subs + + all_subs | mdl == this_mod = Map.findWithDefault [] x sub_map + | otherwise = all_subs_of_qname mod_map t + + fullContentsOf m + | m == this_mod = return (fullContentsOfThisModule this_mod decls) + | otherwise = + case Map.lookup m mod_map of + Just hmod + | OptHide `elem` hmod_options hmod + -> return (hmod_orig_exports hmod) + | otherwise -> return [ ExportModule m ] + Nothing -> return [] -- already emitted a warning in exportedNames + + findDecl :: GHC.Name -> Maybe (GHC.HsDecl GHC.Name) + findDecl n | not (isExternalName n) = Nothing + findDecl n = + | m == this_mod = Map.lookup n decl_map + | otherwise = + case Map.lookup m mod_map of + Just hmod -> Map.lookup n (hmod_decls hmod) + Nothing -> Nothing + where + m = nameModule n + +fullContentsOfThisModule :: GHC.Module -> [GHC.HsDecl GHC.Name] -> [ExportItem] +fullContentsOfThisModule mdl decls = + map mkExportItem (filter keepDecl decls) + where mkExportItem (DocD (DocGroup lev doc)) = ExportGroup lev "" doc + mkExportItem decl = ExportDecl x decl [] -- NOTE: will this work? is x qualified correctly? + where Just x = GHC.getDeclMainBinder decl + +keepDecl :: GHC.HsDecl -> Bool +keepDecl (GHC.SigD _) = True +keepDecl (GHC.TyClD _) = True +keepDecl (GHC.DocD _) = True +keepDecl (GHC.ForD (GHC.ForeignImport _ _ _ _)) = True +keepDecl _ = False + +{- +--< ----------------------------------------------------------------------------- +-- Build the list of items that will become the documentation, from the +-- export list. At this point, the list of ExportItems is in terms of +-- original names. + +mkExportItems :: ModuleMap -> Module -- this module -> [HsQName] -- exported names (orig) @@ -803,6 +968,7 @@ mkExportItems mod_map this_mod exported_names decl_map sub_map decls Just iface -> Map.lookup n (iface_decls iface) Nothing -> Nothing + fullContentsOfThisModule :: Module -> [HsDecl] -> [ExportItem] fullContentsOfThisModule mdl decls = map mkExportItem (filter keepDecl decls) @@ -820,11 +986,70 @@ keepDecl HsDocGroup{} = True keepDecl HsForeignImport{} = True keepDecl _ = False +-} + -- 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 -- together a type signature for it...) +-- We put noSrcLoc everywhere in the cobbled together type signatures since +-- they aren't actually located in the soure code. + +extractDecl :: GHC.Name -> GHC.Module -> GHC.HsDecl GHC.Name -> GHC.HsDecl GHC.Name +extractDecl name mdl decl + | Just n <- getDeclMainBinder decl, n == name = decl + | otherwise = + case decl of + GHC.TyClD d | GHC.isClassDecl d -> + let matching_sigs = [ sig | sig <- GHC.tcdSigs d, GHC.sigName sig == Just name ] + in case matching_sigs of + [s0] -> let (n, tyvar_names) = name_and_tyvars d + in SigD (extractClassDecl n mdl tyvar_names s0) + _ -> error "internal: extractDecl" + GHC.TyClD d | GHC.isDataDecl d -> + let (n, tyvar_names) = name_and_tyvars d + in SigD (extractRecSel name mdl n tyvar_names (GHC.tcdCons d)) + _ -> error "internal: extractDecl" + where + name_and_tyvars d = (GHC.unLoc (GHC.tcdLName d), hsLTyVarLocNames (GHC.tcdTyVars d)) + +toTypeNoLoc :: Located GHC.Name -> LHsType GHC.Name +toTypeNoLoc lname = mkNoLoc (GHC.HsTyVar (unLoc lname)) +mkNoLoc :: a -> Located a +mkNoLoc a = Located noSrcLoc a + +-- originally expected unqualified 1:st name, now it doesn't +extractClassDecl :: GHC.Name -> GHC.Module -> [GHC.Located GHC.Name] -> GHC.LSig GHC.Name -> GHC.Sig GHC.Name +extractClassDecl c mdl tvs0 (GHC.Located p (GHC.TypeSig lname ltype)) = case ltype of + GHC.Located _ (GHC.HsForAllTy exp tvs (GHC.Located p'' preds) ty) -> + GHC.TypeSig lname (mkNoLoc (GHC.HsForAllTy exp tvs lctxt ty)) + _ -> GHC.TypeSig lname (mkNoLoc (GHC.HsForAllTy exp [] lctxt ltype)) + where + lctxt = mkNoLoc ctxt + ctxt = [mkNoLoc (GHC.HsClassP c (map toTypeNoLoc tvs0))] ++ preds + +extractClassDecl _ _ _ d = error $ "Main.extractClassDecl: unexpected decl" + +extractRecSel :: GHC.Located GHC.Name -> GHC.Module -> GHC.Name -> [GHC.Located GHC.Name] -> [GHC.LConDecl GHC.Name] + -> GHC.Sig Ghc.Name +extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found" + +-- originally expected unqualified 3:rd name, now it doesn't +extractRecSel nm mdl t tvs (Located _ con : rest) = + case GHC.con_details con of + GHC.RecCon fields | (GHC.HsRecField n ty _ : _) <- matching_fields fields -> + GHC.TypeSig nm (mkNoLoc (GHC.HsFunTy data_ty (GHC.getBangType ty))) + _ -> extractRecSel nm mdl t tvs rest + where + matching_fields flds = [ f | HsRecField n _ _ <- flds, n == nm ] + data_ty = mkNoLoc (foldl HsAppTy (mkNoLoc (HsTyVar t)) (map toTypeNoLoc tvs)) + +-- 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 +-- together a type signature for it...) +{- extractDecl :: HsName -> Module -> HsDecl -> HsDecl extractDecl name mdl decl | Just n <- declMainBinder decl, n == name = decl @@ -870,7 +1095,7 @@ extractRecSel nm mdl t tvs (HsRecDecl loc _ _tvs _ fields _mb_doc : rest) nm `elem` ns ] data_ty = foldl HsTyApp (HsTyCon (Qual mdl t)) (map HsTyVar tvs) - +-} -- ----------------------------------------------------------------------------- -- Pruning @@ -1170,7 +1395,7 @@ findNamedDoc name decls = search decls where search [] = do tell ["Cannot find documentation for: $" ++ name] return Nothing - search (HsDocCommentNamed _ name' doc : rest) + search ((DocD (DocCommentNamed name' doc)):rest) | name == name' = return (Just doc) | otherwise = search rest search (_other_decl : rest) = search rest |