From 5f0ee262e20f55951eb92a95b2925c0ab78914d8 Mon Sep 17 00:00:00 2001 From: David Waern Date: Thu, 9 Oct 2008 23:53:54 +0000 Subject: Interleave typechecking with interface creation At the same time, we fix a bug where the list of interfaces were processed in the wrong order, when building the links and renaming the interfaces. --- src/Haddock/GHC/Typecheck.hs | 3 +- src/Haddock/Interface.hs | 121 ++++++++++++++++++++++++++++++++----------- src/Main.hs | 16 +++--- 3 files changed, 100 insertions(+), 40 deletions(-) diff --git a/src/Haddock/GHC/Typecheck.hs b/src/Haddock/GHC/Typecheck.hs index dae7aa04..3f116fed 100644 --- a/src/Haddock/GHC/Typecheck.hs +++ b/src/Haddock/GHC/Typecheck.hs @@ -6,7 +6,8 @@ module Haddock.GHC.Typecheck ( - typecheckFiles + typecheckFiles, + mkGhcModule ) where diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs index 8b8d703d..eb9aca69 100644 --- a/src/Haddock/Interface.hs +++ b/src/Haddock/Interface.hs @@ -21,50 +21,113 @@ import Haddock.Interface.Rename import Haddock.Types import Haddock.Options import Haddock.GHC.Utils +import Haddock.GHC.Typecheck +import Haddock.Exception import qualified Data.Map as Map import Data.Map (Map) import Data.List import Control.Monad +import GHC import Name +import HscTypes ( msHsFilePath ) +import Digraph +import BasicTypes +import SrcLoc +import MonadUtils ( liftIO ) --- | Turn a topologically sorted list of GhcModules into interfaces. Also --- return the home link environment created in the process, and any error --- messages. -createInterfaces :: [GhcModule] -> LinkEnv -> [Flag] -> ([Interface], LinkEnv, [ErrMsg]) -createInterfaces modules externalLinks flags = (interfaces, homeLinks, messages) - where - ((interfaces, homeLinks), messages) = runWriter $ do +-- | Turn a topologically sorted list of module names/filenames into interfaces. Also +-- return the home link environment created in the process, and any error messages. +createInterfaces :: [String] -> LinkEnv -> [Flag] -> Ghc ([Interface], LinkEnv) +createInterfaces modules externalLinks flags = do - -- part 1, create the interfaces - interfaces <- createInterfaces' modules flags + -- part 1, create interfaces + interfaces <- createInterfaces' modules flags - -- part 2, build the link environment - let homeLinks = buildHomeLinks interfaces - let links = homeLinks `Map.union` externalLinks - let allNames = Map.keys links + -- part 2, build link environment + let homeLinks = buildHomeLinks interfaces + links = homeLinks `Map.union` externalLinks + allNames = Map.keys links - -- part 3, attach the instances - let interfaces' = attachInstances interfaces allNames - - -- part 3, rename the interfaces - let warnings = Flag_NoWarnings `notElem` flags - interfaces'' <- mapM (renameInterface links warnings) interfaces' + -- part 3, attach instances + let interfaces' = attachInstances interfaces allNames + + -- part 4, rename interfaces + let warnings = Flag_NoWarnings `notElem` flags + let (interfaces'', msgs) = + runWriter $ mapM (renameInterface links warnings) interfaces' + liftIO $ mapM_ putStrLn msgs - return (interfaces'', homeLinks) - + return (interfaces'', homeLinks) -createInterfaces' :: [GhcModule] -> [Flag] -> ErrMsgM [Interface] + +createInterfaces' :: [String] -> [Flag] -> Ghc [Interface] createInterfaces' modules flags = do - resultMap <- foldM addInterface Map.empty modules - return (Map.elems resultMap) - where - addInterface :: ModuleMap -> GhcModule -> ErrMsgM ModuleMap - addInterface map mod = do - interface <- createInterface mod flags map - return $ Map.insert (ifaceMod interface) interface map + targets <- mapM (\f -> guessTarget f Nothing) modules + setTargets targets + modgraph <- depanal [] False + let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph Nothing + (ifaces, _) <- foldM (\(ifaces, modMap) modsum -> do + interface <- processModule modsum flags modMap +{- liftIO $ do + putStrLn . ppModInfo $ ifaceInfo interface + putStrLn . show $ fmap pretty (ifaceDoc interface) + print (ifaceOptions interface) + mapM (putStrLn . pretty . fst) (Map.elems . ifaceDeclMap $ interface) + mapM (putStrLn . show . fmap pretty . snd) (Map.elems . ifaceDeclMap $ interface) + mapM (putStrLn . ppExportItem) (ifaceExportItems interface) + mapM (putStrLn . pretty) (ifaceLocals interface) + mapM (putStrLn . pretty) (ifaceExports interface) + mapM (putStrLn . pretty) (ifaceVisibleExports interface) + mapM (putStrLn . pretty) (ifaceInstances interface) + mapM (\(a,b) -> putStrLn $ pretty a ++ pretty b) (Map.toList $ ifaceSubMap interface) + mapM (putStrLn . pretty) (ifaceInstances interface)-} + return $ (interface : ifaces , Map.insert (ifaceMod interface) interface modMap) + ) ([], Map.empty) orderedMods + return (reverse ifaces) + +{- + +ppInsts = concatMap ppInst + +ppInst (a,b,c) = concatMap pretty a ++ pretty b ++ concatMap pretty c + + +ppExportItem (ExportDecl decl (Just doc) insts) = pretty decl ++ pretty doc ++ ppInsts insts +ppExportItem (ExportDecl decl Nothing insts) = pretty decl ++ ppInsts insts +ppExportItem (ExportNoDecl name name2 names) = pretty name ++ pretty name2 ++ pretty names +ppExportItem (ExportGroup level id doc) = show level ++ show id ++ pretty doc +ppExportItem (ExportDoc doc) = pretty doc +ppExportItem (ExportModule mod) = pretty mod + + +ppModInfo (HaddockModInfo a b c d) = show (fmap pretty a) ++ show b ++ show c ++ show d +-} + +processModule :: ModSummary -> [Flag] -> ModuleMap -> Ghc Interface +processModule modsum flags modMap = + + let handleSrcErrors action = flip handleSourceError action $ \err -> do + printExceptionAndWarnings err + throwE ("Failed to check module: " ++ moduleString (ms_mod modsum)) + + in handleSrcErrors $ do + let filename = msHsFilePath modsum + let dynflags = ms_hspp_opts modsum + tc_mod <- loadModule =<< typecheckModule =<< parseModule modsum + let Just renamed_src = renamedSource tc_mod + let ghcMod = mkGhcModule (ms_mod modsum, + filename, + (parsedSource tc_mod, + renamed_src, + typecheckedSource tc_mod, + moduleInfo tc_mod)) + dynflags + let (interface, msg) = runWriter $ createInterface ghcMod flags modMap + liftIO $ mapM_ putStrLn msg + return interface -- | Build a mapping which for each original name, points to the "best" diff --git a/src/Main.hs b/src/Main.hs index 3d0faa31..dce204d1 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -167,22 +167,18 @@ main = handleTopExceptions $ do -- get packages supplied with --read-interface packages <- readInterfaceFiles nameCacheFromGhc (ifacePairs flags) - -- typecheck argument modules using GHC - modules <- typecheckFiles fileArgs - -- combine the link envs of the external packages into one let extLinks = Map.unions (map (ifLinkEnv . fst) packages) - liftIO $ do -- create the interfaces -- this is the core part of Haddock - let (interfaces, homeLinks, messages) = createInterfaces modules extLinks flags - mapM_ putStrLn messages + (interfaces, homeLinks) <- createInterfaces fileArgs extLinks flags - -- render the interfaces - renderStep packages interfaces + liftIO $ do + -- render the interfaces + renderStep packages interfaces - -- last but not least, dump the interface file - dumpInterfaceFile (map toInstalledIface interfaces) homeLinks flags + -- last but not least, dump the interface file + dumpInterfaceFile (map toInstalledIface interfaces) homeLinks flags else do -- get packages supplied with --read-interface -- cgit v1.2.3