aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Haddock/GHC.hs108
-rw-r--r--src/Haddock/Interface/AttachInstances.hs134
-rw-r--r--src/Haddock/Interface/Create.hs578
-rw-r--r--src/Haddock/Interface/Rename.hs404
4 files changed, 1224 insertions, 0 deletions
diff --git a/src/Haddock/GHC.hs b/src/Haddock/GHC.hs
new file mode 100644
index 00000000..b4b9dd3f
--- /dev/null
+++ b/src/Haddock/GHC.hs
@@ -0,0 +1,108 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2003
+--
+
+
+module Haddock.GHC (
+ startGhc,
+ loadPackages,
+ tryParseStaticFlags,
+ parseGhcFlags,
+ module Haddock.GHC.Typecheck,
+ module Haddock.GHC.Utils
+) where
+
+
+import Haddock.GHC.Typecheck
+import Haddock.GHC.Utils
+import Haddock.Exception
+import Haddock.Options
+
+import Data.Foldable (foldlM)
+import Data.Maybe
+import Control.Monad
+
+import GHC
+import DynFlags hiding (Option)
+import Packages hiding (package)
+import StaticFlags
+
+
+-- | Start a GHC session with the -haddock flag set. Also turn off
+-- compilation and linking.
+startGhc :: String -> IO (Session, DynFlags)
+startGhc libDir = do
+ session <- newSession (Just libDir)
+ flags <- getSessionDynFlags session
+ let flags' = dopt_set flags Opt_Haddock
+ let flags'' = flags' {
+ hscTarget = HscNothing,
+ ghcMode = CompManager,
+ ghcLink = NoLink
+ }
+ setSessionDynFlags session flags''
+ return (session, flags'')
+
+
+-- | Expose the list of packages to GHC. Then initialize GHC's package state
+-- and get the name of the actually loaded packages matching the supplied
+-- list of packages. The matching packages might be newer versions of the
+-- supplied ones. For each matching package, return its InstalledPackageInfo.
+
+loadPackages :: Session -> [String] -> IO [InstalledPackageInfo]
+
+-- It would be better to try to get the "in scope" packages from GHC instead.
+-- This would make the -use-package flag unnecessary. But currently it
+-- seems all you can get from the GHC api is all packages that are linked in
+-- (i.e the closure of the "in scope" packages).
+
+loadPackages session pkgStrs = do
+
+ -- expose the packages
+
+ dfs <- getSessionDynFlags session
+ let dfs' = dfs { packageFlags = packageFlags dfs ++ map ExposePackage pkgStrs }
+ setSessionDynFlags session dfs'
+
+ -- try to parse the packages and get their names, without versions
+ pkgNames <- mapM (handleParse . unpackPackageId . stringToPackageId) pkgStrs
+
+ -- init GHC's package state
+ (dfs'', depPackages) <- initPackages dfs'
+
+ -- compute the pkgIds of the loaded packages matching the
+ -- supplied ones
+
+ let depPkgs = map (fromJust . unpackPackageId) depPackages
+ matchingPackages = [ mkPackageId pkg | pkg <- depPkgs,
+ pkgName pkg `elem` pkgNames ]
+
+ -- get InstalledPackageInfos for each package
+ let pkgInfos = map (getPackageDetails (pkgState dfs'')) matchingPackages
+
+ return pkgInfos
+ where
+ handleParse (Just pkg) = return (pkgName pkg)
+ handleParse Nothing = throwE "Could not parse package identifier"
+
+
+-- | Filter out the GHC specific flags and try to parse and set them as static
+-- flags. Return a list of flags that couldn't be parsed.
+tryParseStaticFlags flags = do
+ let ghcFlags = [ str | Flag_GhcFlag str <- flags ]
+ parseStaticFlags ghcFlags
+
+
+-- | Try to parse dynamic GHC flags
+parseGhcFlags session ghcFlags = do
+ dflags <- getSessionDynFlags session
+ foldlM parseFlag dflags (map words ghcFlags)
+ where
+ -- try to parse a flag as either a dynamic or static GHC flag
+ parseFlag dynflags ghcFlag = do
+ (dynflags', rest) <- parseDynamicFlags dynflags ghcFlag
+ when (rest == ghcFlag) $
+ throwE ("Couldn't parse GHC flag: " ++ (unwords ghcFlag))
+ return dynflags'
diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs
new file mode 100644
index 00000000..51c531e1
--- /dev/null
+++ b/src/Haddock/Interface/AttachInstances.hs
@@ -0,0 +1,134 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2003
+--
+
+
+module Haddock.Interface.AttachInstances (attachInstances) where
+
+
+import Haddock.Types
+
+import qualified Data.Map as Map
+import Data.Map (Map)
+import Data.List
+
+import GHC
+import Name
+import SrcLoc
+import InstEnv
+import Class
+import TypeRep
+import Var hiding (varName)
+import TyCon
+import PrelNames
+import HscTypes
+import FastString
+#define FSLIT(x) (mkFastString# (x#))
+
+
+attachInstances :: [Interface] -> [Interface]
+attachInstances modules = map attach modules
+ where
+ instMap = fmap (map toHsInstHead . sortImage instHead) $ collectInstances modules
+ attach mod = mod { hmod_export_items = newItems }
+ where
+ newItems = map attachExport (hmod_export_items mod)
+
+ attachExport (ExportDecl n decl doc _) =
+ ExportDecl n decl doc (case Map.lookup n instMap of
+ Nothing -> []
+ Just instheads -> instheads)
+ attachExport otherExport = otherExport
+
+
+-- | Simplified type for sorting types, ignoring qualification (not visible
+-- in Haddock output) and unifying special tycons with normal ones.
+data SimpleType = SimpleType Name [SimpleType] deriving (Eq,Ord)
+
+
+collectInstances
+ :: [Interface]
+ -> Map Name [([TyVar], [PredType], Class, [Type])] -- maps class/type names to instances
+
+collectInstances modules
+ = Map.fromListWith (flip (++)) tyInstPairs `Map.union`
+ Map.fromListWith (flip (++)) classInstPairs
+ where
+ allInstances = concat (map hmod_instances modules)
+ classInstPairs = [ (is_cls inst, [instanceHead inst]) |
+ inst <- allInstances ]
+ tyInstPairs = [ (tycon, [instanceHead inst]) | inst <- allInstances,
+ Just tycon <- nub (is_tcs inst) ]
+
+
+instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType])
+instHead (_, _, cls, args)
+ = (map argCount args, className cls, map simplify args)
+ where
+ argCount (AppTy t _) = argCount t + 1
+ argCount (TyConApp _ ts) = length ts
+ argCount (FunTy _ _ ) = 2
+ argCount (ForAllTy _ t) = argCount t
+ argCount (NoteTy _ t) = argCount t
+ argCount _ = 0
+
+ simplify (ForAllTy _ t) = simplify t
+ simplify (FunTy t1 t2) =
+ SimpleType funTyConName [simplify t1, simplify t2]
+ simplify (AppTy t1 t2) = SimpleType s (args ++ [simplify t2])
+ where (SimpleType s args) = simplify t1
+ simplify (TyVarTy v) = SimpleType (tyVarName v) []
+ simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts)
+ simplify (NoteTy _ t) = simplify t
+ simplify _ = error "simplify"
+
+
+-- sortImage f = sortBy (\x y -> compare (f x) (f y))
+sortImage :: Ord b => (a -> b) -> [a] -> [a]
+sortImage f xs = map snd $ sortBy cmp_fst [(f x, x) | x <- xs]
+ where cmp_fst (x,_) (y,_) = compare x y
+
+
+funTyConName = mkWiredInName gHC_PRIM
+ (mkOccNameFS tcName FSLIT("(->)"))
+ funTyConKey
+ (ATyCon funTyCon) -- Relevant TyCon
+ BuiltInSyntax
+
+
+toHsInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name
+toHsInstHead (_, preds, cls, ts) = (map toHsPred preds, className cls, map toHsType ts)
+
+
+--------------------------------------------------------------------------------
+-- Type -> HsType conversion
+--------------------------------------------------------------------------------
+
+
+toHsPred :: PredType -> HsPred Name
+toHsPred (ClassP cls ts) = HsClassP (className cls) (map toLHsType ts)
+toHsPred (IParam n t) = HsIParam n (toLHsType t)
+
+
+toLHsType = noLoc . toHsType
+
+
+toHsType :: Type -> HsType Name
+toHsType t = case t of
+ TyVarTy v -> HsTyVar (tyVarName v)
+ AppTy a b -> HsAppTy (toLHsType a) (toLHsType b)
+ TyConApp tc ts -> case ts of
+ [] -> HsTyVar (tyConName tc)
+ _ -> app (tycon tc) ts
+ FunTy a b -> HsFunTy (toLHsType a) (toLHsType b)
+ ForAllTy v t -> cvForAll [v] t
+ PredTy p -> HsPredTy (toHsPred p)
+ NoteTy _ t -> toHsType t
+ where
+ tycon tc = HsTyVar (tyConName tc)
+ app tc ts = foldl (\a b -> HsAppTy (noLoc a) (noLoc b)) tc (map toHsType ts)
+ cvForAll vs (ForAllTy v t) = cvForAll (v:vs) t
+ cvForAll vs t = mkExplicitHsForAllTy (tyvarbinders vs) (noLoc []) (toLHsType t)
+ tyvarbinders vs = map (noLoc . UserTyVar . tyVarName) vs
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
new file mode 100644
index 00000000..161b2851
--- /dev/null
+++ b/src/Haddock/Interface/Create.hs
@@ -0,0 +1,578 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2003
+--
+
+
+module Haddock.Interface.Create (createInterface) where
+
+
+import Haddock.Types
+import Haddock.Options
+import Haddock.GHC.Utils
+import Haddock.Utils
+
+import qualified Data.Map as Map
+import Data.Map (Map)
+import Data.List
+import Data.Maybe
+import Data.Char
+import Data.Ord
+import Control.Monad.Writer
+
+import GHC
+import Outputable
+import SrcLoc
+import Name
+import Module
+import InstEnv
+import Class
+import TypeRep
+import Var hiding (varName)
+import TyCon
+import PrelNames
+import Bag
+import HscTypes
+import Util (handleDyn)
+import ErrUtils (printBagOfErrors)
+import FastString
+#define FSLIT(x) (mkFastString# (x#))
+
+
+type LookupMod = (Module -> Maybe Interface)
+
+
+-- | Process the data in the GhcModule to produce an interface.
+-- To do this, we need access to already processed modules in the topological
+-- sort. That's what's in the module map.
+createInterface :: GhcModule -> [Flag] -> ModuleMap -> ErrMsgM Interface
+createInterface ghcMod flags modMap = do
+
+ let mod = ghcModule ghcMod
+
+ opts <- mkDocOpts (ghcMbDocOpts ghcMod) flags mod
+
+ let group = ghcGroup ghcMod
+ entities = (nubBy sameName . getTopEntities) group
+ exports = fmap (reverse . map unLoc) (ghcMbExports ghcMod)
+ entityNames_ = entityNames entities
+ subNames = allSubNames group
+ localNames = entityNames_ ++ subNames
+ subMap = mkSubMap group
+ expDeclMap = mkDeclMap (ghcExportedNames ghcMod) group
+ localDeclMap = mkDeclMap entityNames_ group
+ docMap = mkDocMap group
+ ignoreExps = Flag_IgnoreAllExports `elem` flags
+ lookupMod m = Map.lookup mod modMap
+
+ visibleNames <- mkVisibleNames mod lookupMod localNames
+ (ghcNamesInScope ghcMod)
+ subMap exports opts localDeclMap
+
+ exportItems <- mkExportItems lookupMod mod (ghcExportedNames ghcMod)
+ expDeclMap localDeclMap subMap entities
+ opts exports ignoreExps docMap
+
+ -- prune the export list to just those declarations that have
+ -- documentation, if the 'prune' option is on.
+ let
+ prunedExportItems
+ | OptPrune `elem` opts = pruneExportItems exportItems
+ | otherwise = exportItems
+
+ return Interface {
+ hmod_mod = mod,
+ hmod_orig_filename = ghcFilename ghcMod,
+ hmod_info = ghcHaddockModInfo ghcMod,
+ hmod_doc = ghcMbDoc ghcMod,
+ hmod_rn_doc = Nothing,
+ hmod_options = opts,
+ hmod_locals = localNames,
+ hmod_doc_map = docMap,
+ hmod_rn_doc_map = Map.empty,
+ hmod_sub_map = subMap,
+ hmod_export_items = prunedExportItems,
+ hmod_rn_export_items = [],
+ hmod_exports = ghcExportedNames ghcMod,
+ hmod_visible_exports = visibleNames,
+ hmod_exported_decl_map = expDeclMap,
+ hmod_instances = ghcInstances ghcMod
+ }
+
+
+-------------------------------------------------------------------------------
+-- Doc options
+--
+-- Haddock options that are embedded in the source file
+-------------------------------------------------------------------------------
+
+
+mkDocOpts :: Maybe String -> [Flag] -> Module -> ErrMsgM [DocOption]
+mkDocOpts mbOpts flags mod = do
+ opts <- case mbOpts of
+ Just opts -> processOptions opts
+ Nothing -> return []
+ let opts' = if Flag_HideModule (moduleString mod) `elem` flags
+ then OptHide : opts
+ else opts
+ return opts'
+
+
+processOptions_ str = let (opts, msg) = runWriter (processOptions str)
+ in print msg >> return opts
+
+
+processOptions :: String -> ErrMsgM [DocOption]
+processOptions str = do
+ case break (== ',') str of
+ (this, ',':rest) -> do
+ opt <- parseOption this
+ opts <- processOptions rest
+ return (maybeToList opt ++ opts)
+ (this, _)
+ | all isSpace this -> return []
+ | otherwise -> do opt <- parseOption this; return (maybeToList opt)
+
+
+parseOption :: String -> ErrMsgM (Maybe DocOption)
+parseOption "hide" = return (Just OptHide)
+parseOption "prune" = return (Just OptPrune)
+parseOption "ignore-exports" = return (Just OptIgnoreExports)
+parseOption "not-home" = return (Just OptNotHome)
+parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing
+
+
+--------------------------------------------------------------------------------
+-- Source code entities
+--
+-- An entity is a Haskell declaration or a Haddock comment. We need to extract
+-- entities out of classes and top levels since we need them in the interface.
+--------------------------------------------------------------------------------
+
+
+data Entity = DocEntity (DocDecl Name) | DeclEntity Name
+data LEntity = Located Entity
+
+sameName (DocEntity _) _ = False
+sameName (DeclEntity _) (DocEntity _) = False
+sameName (DeclEntity a) (DeclEntity b) = a == b
+
+
+sortByLoc = map unLoc . sortBy (comparing getLoc)
+
+
+-- | Get all the entities in a class. The entities are sorted by their
+-- SrcLoc.
+getClassEntities tcd = sortByLoc (docs ++ meths ++ sigs)
+ where
+ docs = [ L l (DocEntity d) | L l d <- tcdDocs tcd ]
+ meths =
+ let bindings = bagToList (tcdMeths tcd)
+ bindingName = unLoc . fun_id
+ in [ L l (DeclEntity (bindingName b)) | L l b <- bindings ]
+ sigs =
+ let sigName = fromJust . sigNameNoLoc
+ in [ L l (DeclEntity (sigName sig)) | L l sig <- tcdSigs tcd ]
+
+
+-- | Get all the top level entities in a module. The entities are sorted by
+-- their SrcLoc.
+getTopEntities :: HsGroup Name -> [Entity]
+getTopEntities group = sortByLoc (docs ++ declarations)
+ where
+ docs = [ L l (DocEntity d) | L l d <- hs_docs group ]
+
+ declarations = [ L l (DeclEntity n) | (l, n) <- valds ++ tyclds ++ fords ]
+ where
+ valds = let ValBindsOut _ sigs = hs_valds group
+ -- we just use the sigs here for now.
+ -- TODO: collect from the bindings as well
+ -- (needed for docs to work for inferred entities)
+ in [ (l, fromJust (sigNameNoLoc s)) | L l s <- sigs ]
+ tyclds = [ (l, tcdName t) | L l t <- hs_tyclds group ]
+ fords = [ (l, forName f) | L l f <- hs_fords group ]
+ where
+ forName (ForeignImport name _ _) = unLoc name
+ forName (ForeignExport name _ _) = unLoc name
+
+
+--------------------------------------------------------------------------------
+-- Collect docs
+--
+-- To be able to attach the right Haddock comment to the right declaration,
+-- we sort the entities by their SrcLoc and "collect" the docs for each
+-- declaration.
+--------------------------------------------------------------------------------
+
+
+-- | Collect the docs and attach them to the right name
+collectDocs :: [Entity] -> [(Name, HsDoc Name)]
+collectDocs entities = collect Nothing DocEmpty entities
+
+
+collect :: Maybe Entity -> HsDoc Name -> [Entity] -> [(Name, HsDoc Name)]
+collect d doc_so_far [] =
+ case d of
+ Nothing -> []
+ Just d0 -> finishedDoc d0 doc_so_far []
+
+collect d doc_so_far (e:es) =
+ case e of
+ DocEntity (DocCommentNext str) ->
+ case d of
+ Nothing -> collect d (docAppend doc_so_far str) es
+ Just d0 -> finishedDoc d0 doc_so_far (collect Nothing str es)
+
+ DocEntity (DocCommentPrev str) -> collect d (docAppend doc_so_far str) es
+
+ _ -> case d of
+ Nothing -> collect (Just e) doc_so_far es
+ Just d0
+ | sameName d0 e -> collect d doc_so_far es
+ | otherwise -> finishedDoc d0 doc_so_far (collect (Just e) DocEmpty es)
+
+
+finishedDoc :: Entity -> HsDoc Name -> [(Name, HsDoc Name)] ->
+ [(Name, HsDoc Name)]
+finishedDoc d DocEmpty rest = rest
+finishedDoc (DeclEntity name) doc rest = (name, doc) : rest
+finishedDoc _ _ rest = rest
+
+
+-------------------------------------------------------------------------------
+--
+-------------------------------------------------------------------------------
+
+
+-- This map includes everything that can be exported separately,
+-- that means: top declarations, class methods and record selectors
+-- TODO: merge this with mkDeclMap and the extractXXX functions
+mkDocMap :: HsGroup Name -> Map Name (HsDoc Name)
+mkDocMap group = Map.fromList (topDeclDocs ++ classMethDocs ++ recordFieldDocs)
+ where
+ tyclds = map unLoc (hs_tyclds group)
+ classes = filter isClassDecl tyclds
+ datadecls = filter isDataDecl tyclds
+ constrs = [ con | d <- datadecls, L _ con <- tcdCons d ]
+ fields = concat [ fields | RecCon fields <- map con_details constrs]
+
+ topDeclDocs = collectDocs (getTopEntities group)
+ classMethDocs = concatMap (collectDocs . getClassEntities) classes
+
+ recordFieldDocs = [ (unLoc lname, doc) |
+ ConDeclField lname _ (Just (L _ doc)) <- fields ]
+
+
+allSubNames :: HsGroup Name -> [Name]
+allSubNames group =
+ concat [ tail (map unLoc (tyClDeclNames tycld)) | L _ tycld <- hs_tyclds group ]
+
+
+mkSubMap :: HsGroup Name -> Map Name [Name]
+mkSubMap group = Map.fromList [ (name, subs) | L _ tycld <- hs_tyclds group,
+ let name:subs = map unLoc (tyClDeclNames tycld) ]
+
+
+mkDeclMap :: [Name] -> HsGroup Name -> Map Name (LHsDecl Name)
+mkDeclMap names group = Map.fromList [ (n,d) | (n,Just d) <- maybeDecls ]
+ where
+ maybeDecls = [ (name, getDeclFromGroup group name) | name <- names ]
+
+
+entityNames :: [Entity] -> [Name]
+entityNames entities = [ name | DeclEntity name <- entities ]
+{-
+getValSig :: Name -> HsValBinds Name -> TypeEnv -> Maybe (LSig Name)
+getValSig name (ValBindsOut recsAndBinds _) typEnv = case matchingBinds of
+ [bind] -> -- OK we have found a binding that matches. Now look up the
+ -- type, even though it may be present in the ValBindsOut
+ let tything = lookupTypeEnv typeEnv name
+ _ -> Nothing
+ where
+ binds = snd $ unzip recsAndBinds
+ matchingBinds = Bag.filter matchesName binds
+ matchesName (L _ bind) = fun_id bind == name
+getValSig _ _ _ = error "getValSig"
+-}
+
+
+getDeclFromGroup :: HsGroup Name -> Name -> Maybe (LHsDecl Name)
+getDeclFromGroup group name =
+ case catMaybes [ getDeclFromVals (hs_valds group),
+ getDeclFromTyCls (hs_tyclds group),
+ getDeclFromFors (hs_fords group) ] of
+ [decl] -> Just decl
+ _ -> Nothing
+ where
+ getDeclFromVals (ValBindsOut _ lsigs) = case matching of
+ [lsig] -> Just (L (getLoc lsig) (SigD (unLoc lsig)))
+ _ -> Nothing
+ where
+ matching = [ lsig | lsig <- lsigs, let Just n = sigName lsig, n == name,
+ isNormal (unLoc lsig) ]
+ isNormal (TypeSig _ _) = True
+ isNormal _ = False
+
+ getDeclFromVals _ = error "getDeclFromVals: illegal input"
+
+{- getDeclFromVals (ValBindsOut recsAndbinds _) =
+ let binds = snd $ unzip recsAndBinds
+ matchingBinds = Bag.filter matchesName binds
+ matchesName (L _ bind) = fun_id bind == name
+ in case matchingBinds of
+ [bind] -> -- OK we have found a binding that matches. Now look up the
+ -- type, even though it may be present in the ValBindsOut
+
+ _ -> Nothing
+ where
+ matching = [ lsig | lsig <- lsigs, let Just n = sigName lsig, n == name ]
+ getDeclFromVals _ = error "getDeclFromVals: illegal input"
+ -}
+ getDeclFromTyCls ltycls = case matching of
+ [ltycl] -> Just (L (getLoc ltycl) (TyClD (unLoc ltycl)))
+ _ -> Nothing
+ where
+ matching = [ ltycl | ltycl <- ltycls,
+ name `elem` map unLoc (tyClDeclNames (unLoc ltycl))]
+
+ getDeclFromFors lfors = case matching of
+ [for] -> Just (L (getLoc for) (ForD (unLoc for)))
+ _ -> Nothing
+ where
+ matching = [ for | for <- lfors, forName (unLoc for) == name ]
+ forName (ForeignExport n _ _) = unLoc n
+ forName (ForeignImport n _ _) = unLoc n
+
+
+-- | 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
+ :: LookupMod
+ -> Module -- this module
+ -> [Name] -- exported names (orig)
+ -> Map Name (LHsDecl Name) -- maps exported names to declarations
+ -> Map Name (LHsDecl Name) -- maps local names to declarations
+ -> Map Name [Name] -- sub-map for this module
+ -> [Entity] -- entities in the current module
+ -> [DocOption]
+ -> Maybe [IE Name]
+ -> Bool -- --ignore-all-exports flag
+ -> Map Name (HsDoc Name)
+ -> ErrMsgM [ExportItem Name]
+
+mkExportItems lookupMod this_mod exported_names exportedDeclMap localDeclMap sub_map entities
+ opts maybe_exps ignore_all_exports docMap
+ | 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 entities localDeclMap docMap)
+
+ packageId = modulePackageId this_mod
+
+ lookupExport (IEVar x) = declWith x
+ lookupExport (IEThingAbs t) = declWith t
+ lookupExport (IEThingAll t) = declWith t
+ lookupExport (IEThingWith t cs) = declWith t
+ lookupExport (IEModuleContents m) = fullContentsOf (mkModule packageId m)
+ lookupExport (IEGroup lev doc) = return [ ExportGroup lev "" doc ]
+ lookupExport (IEDoc doc) = return [ ExportDoc doc ]
+ lookupExport (IEDocNamed str)
+ = do r <- findNamedDoc str entities
+ case r of
+ Nothing -> return []
+ Just found -> return [ ExportDoc found ]
+
+ declWith :: Name -> ErrMsgM [ ExportItem Name ]
+ declWith t
+ | (Just decl, maybeDoc) <- findDecl t
+ = return [ ExportDecl t (restrictTo subs (extractDecl t mdl decl)) maybeDoc [] ]
+ | otherwise
+ = return []
+ where
+ mdl = nameModule t
+ subs = filter (`elem` exported_names) all_subs
+ all_subs | mdl == this_mod = Map.findWithDefault [] t sub_map
+ | otherwise = allSubsOfName lookupMod t
+
+ fullContentsOf m
+ | m == this_mod = return (fullContentsOfThisModule this_mod entities localDeclMap docMap)
+ | otherwise =
+ case lookupMod m of
+ Just hmod
+ | OptHide `elem` hmod_options hmod
+ -> return (hmod_export_items hmod)
+ | otherwise -> return [ ExportModule m ]
+ Nothing -> return [] -- already emitted a warning in visibleNames
+
+ findDecl :: Name -> (Maybe (LHsDecl Name), Maybe (HsDoc Name))
+ findDecl n | not (isExternalName n) = error "This shouldn't happen"
+ findDecl n
+ | m == this_mod = (Map.lookup n exportedDeclMap, Map.lookup n docMap)
+ | otherwise =
+ case lookupMod m of
+ Just hmod -> (Map.lookup n (hmod_exported_decl_map hmod),
+ Map.lookup n (hmod_doc_map hmod))
+ Nothing -> (Nothing, Nothing)
+ where
+ m = nameModule n
+
+
+fullContentsOfThisModule :: Module -> [Entity] -> Map Name (LHsDecl Name) ->
+ Map Name (HsDoc Name) -> [ExportItem Name]
+fullContentsOfThisModule module_ entities declMap docMap
+ = catMaybes (map mkExportItem entities)
+ where
+ mkExportItem (DocEntity (DocGroup lev doc)) = Just (ExportGroup lev "" doc)
+ mkExportItem (DeclEntity name) = fmap mkExport (Map.lookup name declMap)
+ where mkExport decl = ExportDecl name decl (Map.lookup name docMap) []
+ mkExportItem _ = 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
+-- together a type signature for it...)
+extractDecl :: Name -> Module -> LHsDecl Name -> LHsDecl Name
+extractDecl name mdl decl
+ | Just n <- getMainDeclBinder (unLoc decl), n == name = decl
+ | otherwise =
+ case unLoc decl of
+ TyClD d | isClassDecl d ->
+ let matches = [ sig | sig <- tcdSigs d, sigName sig == Just name ]
+ in case matches of
+ [s0] -> let (n, tyvar_names) = name_and_tyvars d
+ L pos sig = extractClassDecl n mdl tyvar_names s0
+ in L pos (SigD sig)
+ _ -> error "internal: extractDecl"
+ TyClD d | isDataDecl d ->
+ let (n, tyvar_names) = name_and_tyvars d
+ L pos sig = extractRecSel name mdl n tyvar_names (tcdCons d)
+ in L pos (SigD sig)
+ _ -> error "internal: extractDecl"
+ where
+ name_and_tyvars d = (unLoc (tcdLName d), hsLTyVarLocNames (tcdTyVars d))
+
+
+toTypeNoLoc :: Located Name -> LHsType Name
+toTypeNoLoc lname = noLoc (HsTyVar (unLoc lname))
+
+
+rmLoc :: Located a -> Located a
+rmLoc a = noLoc (unLoc a)
+
+
+extractClassDecl :: Name -> Module -> [Located Name] -> LSig Name -> LSig Name
+extractClassDecl c mdl tvs0 (L pos (TypeSig lname ltype)) = case ltype of
+ L _ (HsForAllTy exp tvs (L _ preds) ty) ->
+ L pos (TypeSig lname (noLoc (HsForAllTy exp tvs (lctxt preds) ty)))
+ _ -> L pos (TypeSig lname (noLoc (mkImplicitHsForAllTy (lctxt []) ltype)))
+ where
+ lctxt preds = noLoc (ctxt preds)
+ ctxt preds = [noLoc (HsClassP c (map toTypeNoLoc tvs0))] ++ preds
+
+extractClassDecl _ _ _ d = error $ "extractClassDecl: unexpected decl"
+
+
+extractRecSel :: Name -> Module -> Name -> [Located Name] -> [LConDecl Name]
+ -> LSig Name
+extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
+
+extractRecSel nm mdl t tvs (L _ con : rest) =
+ case con_details con of
+ RecCon fields | (ConDeclField n ty _ : _) <- matching_fields fields ->
+ L (getLoc n) (TypeSig (noLoc nm) (noLoc (HsFunTy data_ty (getBangType ty))))
+ _ -> extractRecSel nm mdl t tvs rest
+ where
+ matching_fields flds = [ f | f@(ConDeclField n _ _) <- flds, (unLoc n) == nm ]
+ data_ty = foldl (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) (map toTypeNoLoc tvs)
+
+
+-- Pruning
+pruneExportItems :: [ExportItem Name] -> [ExportItem Name]
+pruneExportItems items = filter hasDoc items
+ where hasDoc (ExportDecl _ _ d _) = isJust d
+ hasDoc _ = True
+
+
+-- | Gather a list of original names exported from this module
+mkVisibleNames :: Module
+ -> LookupMod
+ -> [Name]
+ -> [Name]
+ -> Map Name [Name]
+ -> Maybe [IE Name]
+ -> [DocOption]
+ -> Map Name (LHsDecl Name)
+ -> ErrMsgM [Name]
+
+mkVisibleNames mdl lookupMod localNames scope subMap maybeExps opts declMap
+ -- if no export list, just return all local names
+ | Nothing <- maybeExps = return (filter hasDecl localNames)
+ | OptIgnoreExports `elem` opts = return localNames
+ | Just expspecs <- maybeExps = do
+ visibleNames <- mapM extract expspecs
+ return $ filter isNotPackageName (concat visibleNames)
+ where
+ hasDecl name = isJust (Map.lookup name declMap)
+ isNotPackageName name = nameMod == mdl || isJust (lookupMod nameMod)
+ where nameMod = nameModule name
+
+ extract e =
+ case e of
+ IEVar x -> return [x]
+ IEThingAbs t -> return [t]
+ IEThingAll t -> return (t : all_subs)
+ where
+ all_subs | nameModule t == mdl = Map.findWithDefault [] t subMap
+ | otherwise = allSubsOfName lookupMod t
+
+ IEThingWith t cs -> return (t : cs)
+
+ IEModuleContents m
+ | mkModule (modulePackageId mdl) m == mdl -> return localNames
+ | otherwise -> let m' = mkModule (modulePackageId mdl) m in
+ case lookupMod m' of
+ Just mod
+ | OptHide `elem` hmod_options mod ->
+ return (filter (`elem` scope) (hmod_exports mod))
+ | otherwise -> return []
+ Nothing
+ -> tell (exportModuleMissingErr mdl m') >> return []
+
+ _ -> return []
+
+
+exportModuleMissingErr this mdl
+ = ["Warning: in export list of " ++ show (moduleString this)
+ ++ ": module not found: " ++ show (moduleString mdl)]
+
+
+-- | For a given entity, find all the names it "owns" (ie. all the
+-- constructors and field names of a tycon, or all the methods of a
+-- class).
+allSubsOfName :: LookupMod -> Name -> [Name]
+allSubsOfName lookupMod name
+ | isExternalName name =
+ case lookupMod (nameModule name) of
+ Just hmod -> Map.findWithDefault [] name (hmod_sub_map hmod)
+ Nothing -> []
+ | otherwise = error $ "Main.allSubsOfName: unexpected unqual'd name"
+
+
+-- Named documentation
+
+findNamedDoc :: String -> [Entity] -> ErrMsgM (Maybe (HsDoc Name))
+findNamedDoc name entities = search entities
+ where search [] = do
+ tell ["Cannot find documentation for: $" ++ name]
+ return Nothing
+ search ((DocEntity (DocCommentNamed name' doc)):rest)
+ | name == name' = return (Just doc)
+ | otherwise = search rest
+ search (_other_decl : rest) = search rest
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
new file mode 100644
index 00000000..a0b92fab
--- /dev/null
+++ b/src/Haddock/Interface/Rename.hs
@@ -0,0 +1,404 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2003
+--
+
+
+module Haddock.Interface.Rename (renameInterface) where
+
+
+import Haddock.Types
+import Haddock.GHC.Utils
+
+import GHC hiding (NoLink)
+import Name
+import BasicTypes
+import SrcLoc
+import Bag (emptyBag)
+import Outputable
+
+import Data.List
+import Data.Map (Map)
+import qualified Data.Map as Map hiding ( Map )
+import Prelude hiding (mapM)
+import Data.Traversable (mapM)
+import Control.Arrow
+import Control.Monad hiding (mapM)
+import Control.Monad.Writer hiding (mapM)
+
+
+renameInterface :: LinkEnv -> Interface -> ErrMsgM Interface
+renameInterface renamingEnv mod =
+
+ -- first create the local env, where every name exported by this module
+ -- is mapped to itself, and everything else comes from the global renaming
+ -- env
+ let localEnv = foldl fn renamingEnv (hmod_visible_exports mod)
+ where fn env name = Map.insert name (nameSetMod name (hmod_mod mod)) env
+
+ docs = Map.toList (hmod_doc_map mod)
+ renameMapElem (k,d) = do d' <- renameDoc d; return (k, d')
+
+ -- rename names in the exported declarations to point to things that
+ -- are closer to, or maybe even exported by, the current module.
+ (renamedExportItems, missingNames1)
+ = runRnFM localEnv (renameExportItems (hmod_export_items mod))
+
+ (rnDocMap, missingNames2)
+ = runRnFM localEnv (liftM Map.fromList (mapM renameMapElem docs))
+
+ (finalModuleDoc, missingNames3)
+ = runRnFM localEnv (renameMaybeDoc (hmod_doc mod))
+
+ -- combine the missing names and filter out the built-ins, which would
+ -- otherwise allways be missing.
+ missingNames = nub $ filter isExternalName
+ (missingNames1 ++ missingNames2 ++ missingNames3)
+
+ -- filter out certain built in type constructors using their string
+ -- representation. TODO: use the Name constants from the GHC API.
+ strings = filter (`notElem` ["()", "[]", "(->)"])
+ (map (showSDoc . ppr) missingNames)
+
+ in do
+ -- report things that we couldn't link to. Only do this for non-hidden
+ -- modules.
+ when (OptHide `notElem` hmod_options mod && not (null strings)) $
+ tell ["Warning: " ++ show (ppr (hmod_mod mod) defaultUserStyle) ++
+ ": could not find link destinations for:\n"++
+ " " ++ concat (map (' ':) strings) ]
+
+ return $ mod { hmod_rn_doc = finalModuleDoc,
+ hmod_rn_doc_map = rnDocMap,
+ hmod_rn_export_items = renamedExportItems }
+
+
+--------------------------------------------------------------------------------
+-- Monad for renaming
+--
+-- The monad does two things for us: it passes around the environment for
+-- renaming, and it returns a list of names which couldn't be found in
+-- the environment.
+--------------------------------------------------------------------------------
+
+
+newtype GenRnM n a =
+ RnM { unRn :: (n -> (Bool, DocName)) -- name lookup function
+ -> (a,[n])
+ }
+
+type RnM a = GenRnM Name a
+
+instance Monad (GenRnM n) where
+ (>>=) = thenRn
+ return = returnRn
+
+returnRn :: a -> GenRnM n a
+returnRn a = RnM (\_ -> (a,[]))
+thenRn :: GenRnM n a -> (a -> GenRnM n b) -> GenRnM n b
+m `thenRn` k = RnM (\lkp -> case unRn m lkp of
+ (a,out1) -> case unRn (k a) lkp of
+ (b,out2) -> (b,out1++out2))
+
+getLookupRn :: RnM (Name -> (Bool, DocName))
+getLookupRn = RnM (\lkp -> (lkp,[]))
+outRn :: Name -> RnM ()
+outRn name = RnM (\_ -> ((),[name]))
+
+lookupRn :: (DocName -> a) -> Name -> RnM a
+lookupRn and_then name = do
+ lkp <- getLookupRn
+ case lkp name of
+ (False,maps_to) -> do outRn name; return (and_then maps_to)
+ (True, maps_to) -> return (and_then maps_to)
+
+newtype OrdName = MkOrdName Name
+
+instance Eq OrdName where
+ (MkOrdName a) == (MkOrdName b) = a == b
+
+instance Ord OrdName where
+ (MkOrdName a) `compare` (MkOrdName b) = nameOccName a `compare` nameOccName b
+
+runRnFM :: LinkEnv -> RnM a -> (a,[Name])
+runRnFM env rn = unRn rn lkp
+ where
+ lkp n = case Map.lookup (MkOrdName n) ordEnv of
+ Nothing -> (False, NoLink n)
+ Just (MkOrdName q) -> (True, Link q)
+
+ ordEnv = Map.fromList . map (MkOrdName *** MkOrdName) . Map.toList $ env
+
+
+--------------------------------------------------------------------------------
+-- Renaming
+--------------------------------------------------------------------------------
+
+
+keep n = NoLink n
+keepL (L loc n) = L loc (NoLink n)
+
+
+rename = lookupRn id
+renameL (L loc name) = return . L loc =<< rename name
+
+
+renameExportItems :: [ExportItem Name] -> RnM [ExportItem DocName]
+renameExportItems items = mapM renameExportItem items
+
+
+renameMaybeDoc :: Maybe (HsDoc Name) -> RnM (Maybe (HsDoc DocName))
+renameMaybeDoc mbDoc = mapM renameDoc mbDoc
+
+
+renameLDoc (L loc doc) = return . L loc =<< renameDoc doc
+
+
+renameDoc :: HsDoc Name -> RnM (HsDoc DocName)
+renameDoc doc = case doc of
+ DocEmpty -> return DocEmpty
+ DocAppend a b -> do
+ a' <- renameDoc a
+ b' <- renameDoc b
+ return (DocAppend a' b')
+ DocString str -> return (DocString str)
+ DocParagraph doc -> do
+ doc' <- renameDoc doc
+ return (DocParagraph doc')
+ DocIdentifier ids -> do
+ lkp <- getLookupRn
+ case [ n | (True, n) <- map lkp ids ] of
+ ids'@(_:_) -> return (DocIdentifier ids')
+ [] -> return (DocIdentifier (map NoLink ids))
+ DocModule str -> return (DocModule str)
+ DocEmphasis doc -> do
+ doc' <- renameDoc doc
+ return (DocEmphasis doc')
+ DocMonospaced doc -> do
+ doc' <- renameDoc doc
+ return (DocMonospaced doc')
+ DocUnorderedList docs -> do
+ docs' <- mapM renameDoc docs
+ return (DocUnorderedList docs')
+ DocOrderedList docs -> do
+ docs' <- mapM renameDoc docs
+ return (DocOrderedList docs')
+ DocDefList docs -> do
+ docs' <- mapM (\(a,b) -> do
+ a' <- renameDoc a
+ b' <- renameDoc b
+ return (a',b')) docs
+ return (DocDefList docs')
+ DocCodeBlock doc -> do
+ doc' <- renameDoc doc
+ return (DocCodeBlock doc')
+ DocURL str -> return (DocURL str)
+ DocAName str -> return (DocAName str)
+
+
+renameLPred (L loc p) = return . L loc =<< renamePred p
+
+
+renamePred :: HsPred Name -> RnM (HsPred DocName)
+renamePred (HsClassP name types) = do
+ name' <- rename name
+ types' <- mapM renameLType types
+ return (HsClassP name' types')
+renamePred (HsIParam (IPName name) t) = do
+ name' <- rename name
+ t' <- renameLType t
+ return (HsIParam (IPName name') t')
+
+
+renameLType (L loc t) = return . L loc =<< renameType t
+
+
+renameType t = case t of
+ HsForAllTy expl tyvars lcontext ltype -> do
+ tyvars' <- mapM renameLTyVarBndr tyvars
+ lcontext' <- renameLContext lcontext
+ ltype' <- renameLType ltype
+ return (HsForAllTy expl tyvars' lcontext' ltype')
+
+ HsTyVar n -> return . HsTyVar =<< rename n
+ HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype
+
+ HsAppTy a b -> do
+ a' <- renameLType a
+ b' <- renameLType b
+ return (HsAppTy a' b')
+
+ HsFunTy a b -> do
+ a' <- renameLType a
+ b' <- renameLType b
+ return (HsFunTy a' b')
+
+ HsListTy t -> return . HsListTy =<< renameLType t
+ HsPArrTy t -> return . HsPArrTy =<< renameLType t
+
+ HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts
+
+ HsOpTy a (L loc op) b -> do
+ op' <- rename op
+ a' <- renameLType a
+ b' <- renameLType b
+ return (HsOpTy a' (L loc op') b')
+
+ HsParTy t -> return . HsParTy =<< renameLType t
+
+ HsNumTy n -> return (HsNumTy n)
+
+ HsPredTy p -> return . HsPredTy =<< renamePred p
+
+ HsKindSig t k -> do
+ t' <- renameLType t
+ return (HsKindSig t' k)
+
+ HsDocTy t doc -> do
+ t' <- renameLType t
+ doc' <- renameLDoc doc
+ return (HsDocTy t' doc')
+
+ _ -> error "renameType"
+
+
+renameLTyVarBndr (L loc tv) = do
+ name' <- rename (hsTyVarName tv)
+ return $ L loc (replaceTyVarName tv name')
+
+
+renameLContext (L loc context) = do
+ context' <- mapM renameLPred context
+ return (L loc context')
+
+
+renameInstHead :: InstHead Name -> RnM (InstHead DocName)
+renameInstHead (preds, className, types) = do
+ preds' <- mapM renamePred preds
+ className' <- rename className
+ types' <- mapM renameType types
+ return (preds', className', types')
+
+
+renameLDecl (L loc d) = return . L loc =<< renameDecl d
+
+
+renameDecl d = case d of
+ TyClD d -> do
+ d' <- renameTyClD d
+ return (TyClD d')
+ SigD s -> do
+ s' <- renameSig s
+ return (SigD s')
+ ForD d -> do
+ d' <- renameForD d
+ return (ForD d')
+ _ -> error "renameDecl"
+
+
+renameTyClD d = case d of
+ ForeignType _ _ _ -> error "renameTyClD" -- I'm guessing these can't be exported
+ -- ForeignType name a b -> do
+ -- name' <- renameL name
+ -- return (ForeignType name' a b)
+
+ TyData x lcontext lname ltyvars _ k cons _ -> do
+ lcontext' <- renameLContext lcontext
+ ltyvars' <- mapM renameLTyVarBndr ltyvars
+ cons' <- mapM renameLCon cons
+ -- I don't think we need the derivings, so we return Nothing
+ -- We skip the type patterns too. TODO: find out what they are :-)
+ return (TyData x lcontext' (keepL lname) ltyvars' Nothing k cons' Nothing)
+
+ TySynonym lname ltyvars typat ltype -> do
+ ltyvars' <- mapM renameLTyVarBndr ltyvars
+ ltype' <- renameLType ltype
+ -- We skip type patterns here as well.
+ return (TySynonym (keepL lname) ltyvars' Nothing ltype')
+
+ ClassDecl lcontext lname ltyvars lfundeps lsigs _ _ _ -> do
+ lcontext' <- renameLContext lcontext
+ ltyvars' <- mapM renameLTyVarBndr ltyvars
+ lfundeps' <- mapM renameLFunDep lfundeps
+ lsigs' <- mapM renameLSig lsigs
+ -- we don't need the default methods or the already collected doc entities
+ -- we skip the ATs for now.
+ return (ClassDecl lcontext' (keepL lname) ltyvars' lfundeps' lsigs' emptyBag [] [])
+
+ where
+ renameLCon (L loc con) = return . L loc =<< renameCon con
+ renameCon (ConDecl lname expl ltyvars lcontext details restype mbldoc) = do
+ ltyvars' <- mapM renameLTyVarBndr ltyvars
+ lcontext' <- renameLContext lcontext
+ details' <- renameDetails details
+ restype' <- renameResType restype
+ mbldoc' <- mapM renameLDoc mbldoc
+ return (ConDecl (keepL lname) expl ltyvars' lcontext' details' restype' mbldoc')
+
+ renameDetails (RecCon fields) = return . RecCon =<< mapM renameField fields
+ renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps
+ renameDetails (InfixCon a b) = do
+ a' <- renameLType a
+ b' <- renameLType b
+ return (InfixCon a' b')
+
+ renameField (ConDeclField name t doc) = do
+ t' <- renameLType t
+ doc' <- mapM renameLDoc doc
+ return (ConDeclField (keepL name) t' doc')
+
+ renameResType (ResTyH98) = return ResTyH98
+ renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t
+
+ renameLFunDep (L loc (xs, ys)) = return (L loc (map keep xs, map keep ys))
+
+ renameLSig (L loc sig) = return . L loc =<< renameSig sig
+
+
+renameSig sig = case sig of
+ TypeSig (L loc name) ltype -> do
+ ltype' <- renameLType ltype
+ return (TypeSig (L loc (keep name)) ltype')
+{- SpecSig lname ltype x -> do
+ lname' <- renameL lname
+ ltype' <- renameLType ltype
+ return (SpecSig lname' ltype' x)
+ InlineSig lname x -> do
+ lname' <- renameL lname
+ return (InlineSig lname' x)
+ SpecInstSig t -> return . SpecInstSig =<< renameLType t
+ FixSig fsig -> return . FixSig =<< renameFixitySig fsig
+ where
+ renameFixitySig (FixitySig lname x) = do
+ lname' <- renameL lname
+ return (FixitySig lname' x)
+-}
+
+
+renameForD (ForeignImport lname ltype x) = do
+ ltype' <- renameLType ltype
+ return (ForeignImport (keepL lname) ltype' x)
+renameForD (ForeignExport lname ltype x) = do
+ ltype' <- renameLType ltype
+ return (ForeignExport (keepL lname) ltype' x)
+
+
+renameExportItem :: ExportItem Name -> RnM (ExportItem DocName)
+renameExportItem item = case item of
+ ExportModule mod -> return (ExportModule mod)
+ ExportGroup lev id doc -> do
+ doc' <- renameDoc doc
+ return (ExportGroup lev id doc')
+ ExportDecl x decl doc instances -> do
+ decl' <- renameLDecl decl
+ doc' <- mapM renameDoc doc
+ instances' <- mapM renameInstHead instances
+ return (ExportDecl x decl' doc' instances')
+ ExportNoDecl x y subs -> do
+ y' <- lookupRn id y
+ subs' <- mapM (lookupRn id) subs
+ return (ExportNoDecl x y' subs')
+ ExportDoc doc -> do
+ doc' <- renameDoc doc
+ return (ExportDoc doc')
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-21 20:00:35 +0000