aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock')
-rw-r--r--src/Haddock/Html.hs3
-rw-r--r--src/Haddock/Typecheck.hs123
-rw-r--r--src/Haddock/Utils.hs15
-rw-r--r--src/Haddock/Utils/GHC.hs51
4 files changed, 167 insertions, 25 deletions
diff --git a/src/Haddock/Html.hs b/src/Haddock/Html.hs
index 79a2625f..74aa4e34 100644
--- a/src/Haddock/Html.hs
+++ b/src/Haddock/Html.hs
@@ -17,8 +17,9 @@ import Haddock.HH
import Haddock.HH2
import Haddock.ModuleTree
import Haddock.Types
-import Haddock.Utils
import Haddock.Version
+import Haddock.Utils
+import Haddock.Utils.GHC
import Haddock.Utils.Html
import qualified Haddock.Utils.Html as Html
diff --git a/src/Haddock/Typecheck.hs b/src/Haddock/Typecheck.hs
new file mode 100644
index 00000000..088ee8a1
--- /dev/null
+++ b/src/Haddock/Typecheck.hs
@@ -0,0 +1,123 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2003
+--
+
+
+module Haddock.Typecheck (
+ GhcModule(..),
+ typecheckFiles
+) where
+
+
+import Haddock.Exception
+import Haddock.Utils.GHC
+
+
+import Data.Maybe
+import Control.Monad
+import GHC
+import Digraph
+import BasicTypes
+import SrcLoc
+
+
+-- | This data structure collects all the information we want about a home
+-- package module that we can get from GHC's typechecker
+data GhcModule = GhcModule {
+ ghcModule :: Module,
+ ghcFilename :: FilePath,
+ ghcMbDocOpts :: Maybe String,
+ ghcHaddockModInfo :: HaddockModInfo Name,
+ ghcMbDoc :: Maybe (HsDoc Name),
+ ghcGroup :: HsGroup Name,
+ ghcMbExports :: Maybe [LIE Name],
+ ghcExportedNames :: [Name],
+ ghcNamesInScope :: [Name],
+ ghcInstances :: [Instance]
+}
+
+
+typecheckFiles :: Session -> [FilePath] -> IO [GhcModule]
+typecheckFiles session files = do
+ checkedMods <- sortAndCheckModules session files
+ return (map mkGhcModule checkedMods)
+
+
+-- | Get the sorted graph of all loaded modules and their dependencies
+getSortedModuleGraph :: Session -> IO [(Module, FilePath)]
+getSortedModuleGraph session = do
+ mbModGraph <- depanal session [] True
+ moduleGraph <- case mbModGraph of
+ Just mg -> return mg
+ Nothing -> throwE "Failed to load all modules"
+ let
+ getModFile = fromJust . ml_hs_file . ms_location
+ sortedGraph = topSortModuleGraph False moduleGraph Nothing
+ sortedModules = concatMap flattenSCC sortedGraph
+ modsAndFiles = [ (ms_mod modsum, getModFile modsum) |
+ modsum <- sortedModules ]
+ return modsAndFiles
+
+
+type CheckedMod = (Module, FilePath, FullyCheckedMod)
+
+
+type FullyCheckedMod = (ParsedSource,
+ RenamedSource,
+ TypecheckedSource,
+ ModuleInfo)
+
+
+-- TODO: make it handle cleanup
+sortAndCheckModules :: Session -> [FilePath] -> IO [CheckedMod]
+sortAndCheckModules session files = do
+
+ -- load all argument files
+
+ targets <- mapM (\f -> guessTarget f Nothing) files
+ setTargets session targets
+
+ -- compute the dependencies and load them as well
+
+ allMods <- getSortedModuleGraph session
+ targets' <- mapM (\(_, f) -> guessTarget f Nothing) allMods
+ setTargets session targets'
+
+ flag <- load session LoadAllTargets
+ when (failed flag) $
+ throwE "Failed to load all needed modules"
+
+ -- typecheck the argument modules
+
+ let argMods = filter ((`elem` files) . snd) allMods
+
+ checkedMods <- forM argMods $ \(mod, file) -> do
+ mbMod <- checkModule session (moduleName mod) False
+ case mbMod of
+ Just (CheckedModule a (Just b) (Just c) (Just d) _)
+ -> return (mod, file, (a,b,c,d))
+ _ -> throwE ("Failed to check module: " ++ moduleString mod)
+
+ return checkedMods
+
+
+-- | Dig out what we want from the typechecker output
+mkGhcModule :: CheckedMod -> GhcModule
+mkGhcModule (mod, file, checkedMod) = GhcModule {
+ ghcModule = mod,
+ ghcFilename = file,
+ ghcMbDocOpts = mbOpts,
+ ghcHaddockModInfo = info,
+ ghcMbDoc = mbDoc,
+ ghcGroup = group,
+ ghcMbExports = mbExports,
+ ghcExportedNames = modInfoExports modInfo,
+ ghcNamesInScope = fromJust $ modInfoTopLevelScope modInfo,
+ ghcInstances = modInfoInstances modInfo
+}
+ where
+ HsModule _ _ _ _ _ mbOpts _ _ = unLoc parsed
+ (group, _, mbExports, mbDoc, info) = renamed
+ (parsed, renamed, _, modInfo) = checkedMod
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs
index a7f5f8a9..52618c30 100644
--- a/src/Haddock/Utils.hs
+++ b/src/Haddock/Utils.hs
@@ -20,8 +20,7 @@ module Haddock.Utils (
-- * Miscellaneous utilities
getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr,
- isConSym, isVarSym, nameOccString, moduleString, mkModuleNoPkg,
-
+
-- * HTML cross reference mapping
html_xrefs_ref,
@@ -231,18 +230,6 @@ escapeStr = flip escapeString unreserved
escapeStr = escapeURIString isUnreserved
#endif
--- there should be a better way to check this using the GHC API
-isConSym n = head (nameOccString n) == ':'
-isVarSym n = fstChar /= '_' && not (isConSym n) && (not . isLetter) fstChar
- where fstChar = head (nameOccString n)
-
-nameOccString = occNameString . nameOccName
-
-moduleString :: Module -> String
-moduleString = moduleNameString . moduleName
-
-mkModuleNoPkg :: String -> Module
-mkModuleNoPkg str = mkModule (stringToPackageId "") (mkModuleName str)
-----------------------------------------------------------------------------
-- HTML cross references
diff --git a/src/Haddock/Utils/GHC.hs b/src/Haddock/Utils/GHC.hs
index 8393cbb2..3ac90d77 100644
--- a/src/Haddock/Utils/GHC.hs
+++ b/src/Haddock/Utils/GHC.hs
@@ -4,9 +4,12 @@
-- (c) Simon Marlow 2003
--
+
module Haddock.Utils.GHC where
+
import Debug.Trace
+import Data.Char
import GHC
import HsSyn
@@ -17,6 +20,42 @@ import Packages
import UniqFM
import Name
+
+-- names
+
+nameOccString = occNameString . nameOccName
+
+
+nameSetMod n newMod =
+ mkExternalName (nameUnique n) newMod (nameOccName n) (nameSrcSpan n)
+
+
+nameSetPkg pkgId n =
+ mkExternalName (nameUnique n) (mkModule pkgId (moduleName mod))
+ (nameOccName n) (nameSrcSpan n)
+ where mod = nameModule n
+
+
+-- modules
+
+
+moduleString :: Module -> String
+moduleString = moduleNameString . moduleName
+
+
+mkModuleNoPkg :: String -> Module
+mkModuleNoPkg str = mkModule (stringToPackageId "") (mkModuleName str)
+
+
+-- misc
+
+
+-- there should be a better way to check this using the GHC API
+isConSym n = head (nameOccString n) == ':'
+isVarSym n = fstChar /= '_' && not (isConSym n) && (not . isLetter) fstChar
+ where fstChar = head (nameOccString n)
+
+
getMainDeclBinder :: HsDecl name -> Maybe name
getMainDeclBinder (TyClD d) = Just (tcdName d)
getMainDeclBinder (ValD d)
@@ -28,18 +67,10 @@ getMainDeclBinder (ForD (ForeignImport name _ _)) = Just (unLoc name)
getMainDeclBinder (ForD (ForeignExport name _ _)) = Nothing
getMainDeclBinder _ = Nothing
+
-- To keep if if minf_iface is re-introduced
--modInfoName = moduleName . mi_module . minf_iface
--modInfoMod = mi_module . minf_iface
-trace_ppr x y = trace (showSDoc (ppr x)) y
--- names
-
-nameSetMod n newMod =
- mkExternalName (nameUnique n) newMod (nameOccName n) (nameSrcSpan n)
-
-nameSetPkg pkgId n =
- mkExternalName (nameUnique n) (mkModule pkgId (moduleName mod))
- (nameOccName n) (nameSrcSpan n)
- where mod = nameModule n
+trace_ppr x y = trace (showSDoc (ppr x)) y
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-24 10:36:54 +0000