From ea3ec06c3716c9f47cbe2a17f77dbd63a18cff4a Mon Sep 17 00:00:00 2001 From: David Waern Date: Wed, 29 Aug 2007 23:49:29 +0000 Subject: Add some modules that I forgot to add earlier --- src/Haddock/GHC.hs | 108 ++++++ src/Haddock/Interface/AttachInstances.hs | 134 +++++++ src/Haddock/Interface/Create.hs | 578 +++++++++++++++++++++++++++++++ src/Haddock/Interface/Rename.hs | 404 +++++++++++++++++++++ 4 files changed, 1224 insertions(+) create mode 100644 src/Haddock/GHC.hs create mode 100644 src/Haddock/Interface/AttachInstances.hs create mode 100644 src/Haddock/Interface/Create.hs create mode 100644 src/Haddock/Interface/Rename.hs (limited to 'src') 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') -- cgit v1.2.3