From e3fc750872a65ba6cc7c859172f433cc31a89dd7 Mon Sep 17 00:00:00 2001 From: David Waern Date: Tue, 16 Nov 2010 00:17:21 +0000 Subject: Make a little more use of DoAndIfThenElse --- src/Haddock/Interface.hs | 42 +++++++++---------- src/Haddock/Interface/Create.hs | 93 ++++++++++++++++++++--------------------- 2 files changed, 66 insertions(+), 69 deletions(-) (limited to 'src') diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs index 865183cd..276621d2 100644 --- a/src/Haddock/Interface.hs +++ b/src/Haddock/Interface.hs @@ -102,12 +102,11 @@ createIfaces0 verbosity modules flags instIfaceMap = -- resulting ModSummaries. (if useTempDir then withTempOutputDir else id) $ do modGraph <- depAnalysis - if needsTemplateHaskell modGraph - then do - modGraph' <- enableCompilation modGraph - createIfaces verbosity flags instIfaceMap modGraph' - else - createIfaces verbosity flags instIfaceMap modGraph + if needsTemplateHaskell modGraph then do + modGraph' <- enableCompilation modGraph + createIfaces verbosity flags instIfaceMap modGraph' + else + createIfaces verbosity flags instIfaceMap modGraph where useTempDir :: Bool @@ -157,22 +156,21 @@ processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap - processModule verbosity modsum flags modMap instIfaceMap = do out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..." tm <- loadModule =<< typecheckModule =<< parseModule modsum - if not $ isBootSummary modsum - then do - out verbosity verbose "Creating interface..." - (interface, msg) <- runWriterGhc $ createInterface tm flags modMap instIfaceMap - liftIO $ mapM_ putStrLn msg - let (haddockable, haddocked) = ifaceHaddockCoverage interface - percentage = round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) :: Int - coveragemsg = printf "haddock coverage for %s: %7s %3d%%" - (ifaceOrigFilename interface) - (printf "%d/%d" haddocked haddockable :: String) - percentage - out verbosity normal coveragemsg - interface' <- liftIO $ evaluate interface - return (Just interface') - else - return Nothing + if not $ isBootSummary modsum then do + out verbosity verbose "Creating interface..." + (interface, msg) <- runWriterGhc $ createInterface tm flags modMap instIfaceMap + liftIO $ mapM_ putStrLn msg + let (haddockable, haddocked) = ifaceHaddockCoverage interface + percentage = round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) :: Int + coveragemsg = printf "haddock coverage for %s: %7s %3d%%" + (ifaceOrigFilename interface) + (printf "%d/%d" haddocked haddockable :: String) + percentage + out verbosity normal coveragemsg + interface' <- liftIO $ evaluate interface + return (Just interface') + else + return Nothing -------------------------------------------------------------------------------- diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index db2ec05c..d651fe75 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -573,53 +573,52 @@ mkExportItems modMap this_mod gre exported_names decls declMap -- those exported type-inferenced values. isLocalAndTypeInferenced <- liftGhcToErrMsgGhc $ do let mdl = nameModule t - if modulePackageId mdl == thisPackage dflags - then isLoaded (moduleName mdl) - else return False - - if isLocalAndTypeInferenced - then do - -- I don't think there can be any subs in this case, - -- currently? But better not to rely on it. - let subs = subordinatesWithNoDocs (unLoc hsdecl) - return [ mkExportDecl t (hsdecl, noDocForDecl, subs) ] - else - -- We try to get the subs and docs - -- from the installed interface of that package. - case Map.lookup (nameModule t) instIfaceMap of - -- It's Nothing in the cases where I thought - -- Haddock has already warned the user: "Warning: The - -- documentation for the following packages are not - -- installed. No links will be generated to these packages: - -- ..." - -- But I guess it was Cabal creating that warning. Anyway, - -- this is more serious than links: it's exported decls where - -- we don't have the docs that they deserve! - - -- We could use 'subordinates' to find the Names of the subs - -- (with no docs). Is that necessary? Yes it is, otherwise - -- e.g. classes will be shown without their exported subs. - Nothing -> do - liftErrMsg $ tell - ["Warning: Couldn't find .haddock for exported " - ++ exportInfoString] - let subs = subordinatesWithNoDocs (unLoc hsdecl) - return [ mkExportDecl t (hsdecl, noDocForDecl, subs) ] - Just iface -> do - let subs = case Map.lookup t (instSubMap iface) of - Nothing -> [] - Just x -> x - return [ mkExportDecl t - ( hsdecl - , fromMaybe noDocForDecl $ - Map.lookup t (instDocMap iface) - , map (\subt -> - ( subt , - fromMaybe noDocForDecl $ - Map.lookup subt (instDocMap iface) - ) - ) subs - )] + if modulePackageId mdl == thisPackage dflags then + isLoaded (moduleName mdl) + else return False + + if isLocalAndTypeInferenced then do + -- I don't think there can be any subs in this case, + -- currently? But better not to rely on it. + let subs = subordinatesWithNoDocs (unLoc hsdecl) + return [ mkExportDecl t (hsdecl, noDocForDecl, subs) ] + else + -- We try to get the subs and docs + -- from the installed interface of that package. + case Map.lookup (nameModule t) instIfaceMap of + -- It's Nothing in the cases where I thought + -- Haddock has already warned the user: "Warning: The + -- documentation for the following packages are not + -- installed. No links will be generated to these packages: + -- ..." + -- But I guess it was Cabal creating that warning. Anyway, + -- this is more serious than links: it's exported decls where + -- we don't have the docs that they deserve! + + -- We could use 'subordinates' to find the Names of the subs + -- (with no docs). Is that necessary? Yes it is, otherwise + -- e.g. classes will be shown without their exported subs. + Nothing -> do + liftErrMsg $ tell + ["Warning: Couldn't find .haddock for exported " + ++ exportInfoString] + let subs = subordinatesWithNoDocs (unLoc hsdecl) + return [ mkExportDecl t (hsdecl, noDocForDecl, subs) ] + Just iface -> do + let subs = case Map.lookup t (instSubMap iface) of + Nothing -> [] + Just x -> x + return [ mkExportDecl t + ( hsdecl + , fromMaybe noDocForDecl $ + Map.lookup t (instDocMap iface) + , map (\subt -> + ( subt , + fromMaybe noDocForDecl $ + Map.lookup subt (instDocMap iface) + ) + ) subs + )] mkExportDecl :: Name -> DeclInfo -> ExportItem Name -- cgit v1.2.3