From 82a5bcbb729d769a53e9c14b0be9c9b6b8daa548 Mon Sep 17 00:00:00 2001
From: davve <davve@dtek.chalmers.se>
Date: Sat, 29 Jul 2006 16:16:43 +0000
Subject: Add instances, build renaming environment, start on the renamer
---
examples/hide-bug/B.hs | 4 +-
examples/hide-bug/C.hs | 7 +-
examples/hide-bug/D.hs | 4 +-
src/HaddockRename.hs | 192 +++++----
src/HaddockTypes.hs | 62 ++-
src/HaddockUtil.hs | 4 +-
src/Main.hs | 1066 +++++++++++-------------------------------------
7 files changed, 384 insertions(+), 955 deletions(-)
diff --git a/examples/hide-bug/B.hs b/examples/hide-bug/B.hs
index 7c5b9dfe..f2ef544a 100644
--- a/examples/hide-bug/B.hs
+++ b/examples/hide-bug/B.hs
@@ -1 +1,3 @@
-module B(f, T) where import A
+module B(Test) where
+
+data Test = Test
diff --git a/examples/hide-bug/C.hs b/examples/hide-bug/C.hs
index 363221d9..d846035b 100644
--- a/examples/hide-bug/C.hs
+++ b/examples/hide-bug/C.hs
@@ -1 +1,6 @@
-module C(module B) where import B
+module C(C.bla) where
+
+import D
+
+bla :: Test
+bla = undefined
diff --git a/examples/hide-bug/D.hs b/examples/hide-bug/D.hs
index 30ac8acc..a9203a7c 100644
--- a/examples/hide-bug/D.hs
+++ b/examples/hide-bug/D.hs
@@ -1,3 +1,5 @@
-- The link to the type T in the doc for this module should point to
-- B.T, not A.T. Bug fixed in rev 1.59 of Main.hs.
-module D(f) where import C
+module D(Test) where
+
+import B
diff --git a/src/HaddockRename.hs b/src/HaddockRename.hs
index d3667d6b..922b362d 100644
--- a/src/HaddockRename.hs
+++ b/src/HaddockRename.hs
@@ -5,21 +5,26 @@
--
module HaddockRename (
- RnM, runRn, runRnFM, runRnUnqualFM, -- the monad (instance of Monad)
+ RnM, runRn, runRnFM, -- the monad (instance of Monad)
- renameExportList,
- renameDecl,
- renameExportItems, renameInstHead,
- renameDoc, renameMaybeDoc,
+ --renameExportList,
+ --renameDecl,
+ --renameExportItems, renameInstHead,
+ --renameDoc, renameMaybeDoc,
+ renameMaybeDoc, renameExportItems,
) where
import HaddockTypes
import HaddockUtil ( unQual )
-import HsSyn2
+--import HsSyn2
import Map ( Map )
import qualified Map hiding ( Map )
-import Monad
+import Prelude hiding ( mapM )
+import Control.Monad hiding ( mapM )
+import Data.Traversable
+
+import GHC
-- -----------------------------------------------------------------------------
-- Monad for renaming
@@ -29,11 +34,11 @@ import Monad
-- the environment.
newtype GenRnM n a =
- RnM { unRn :: (n -> (Bool,HsQName)) -- name lookup function
+ RnM { unRn :: (n -> (Bool, DocName)) -- name lookup function
-> (a,[n])
}
-type RnM a = GenRnM HsQName a
+type RnM a = GenRnM Name a
instance Monad (GenRnM n) where
(>>=) = thenRn
@@ -46,56 +51,76 @@ 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 (HsQName -> (Bool,HsQName))
+getLookupRn :: RnM (Name -> (Bool, DocName))
getLookupRn = RnM (\lkp -> (lkp,[]))
-outRn :: HsQName -> RnM ()
+outRn :: Name -> RnM ()
outRn name = RnM (\_ -> ((),[name]))
-lookupRn :: (HsQName -> a) -> HsQName -> RnM a
+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)
-runRnFM :: Map HsQName HsQName -> RnM a -> (a,[HsQName])
+runRnFM :: Map Name Name -> RnM a -> (a,[Name])
runRnFM env rn = unRn rn lkp
where lkp n = case Map.lookup n env of
- Nothing -> (False, n) -- leave the qualified name
- Just q -> (True, q)
-
--- like runRnFM, but if it can't find a mapping for a name,
--- it leaves an unqualified name in place instead.
-runRnUnqualFM :: Map HsQName HsQName -> RnM a -> (a,[HsQName])
-runRnUnqualFM env rn = unRn rn lkp
- where lkp n = case Map.lookup n env of
- Nothing -> (False, unQual n) -- remove the qualifier
- Just q -> (True, q)
+ Nothing -> (False, NoLink n)
+ Just q -> (True, Link q)
-runRn :: (n -> (Bool,HsQName)) -> GenRnM n a -> (a,[n])
+runRn :: (n -> (Bool,DocName)) -> GenRnM n a -> (a,[n])
runRn lkp rn = unRn rn lkp
--- -----------------------------------------------------------------------------
--- Renaming source code & documentation
+renameExportItems :: [ExportItem2 Name] -> RnM [ExportItem2 DocName]
+renameExportItems items = mapM renameExportItem items
-renameExportList :: [HsExportSpec] -> RnM [HsExportSpec]
-renameExportList spec = mapM renameExport spec
- where
- renameExport (HsEVar x) = lookupRn HsEVar x
- renameExport (HsEAbs x) = lookupRn HsEAbs x
- renameExport (HsEThingAll x) = lookupRn HsEThingAll x
- renameExport (HsEThingWith x cs) = do
- cs' <- mapM (lookupRn id) cs
- lookupRn (\x' -> HsEThingWith x' cs') x
- renameExport (HsEModuleContents m) = return (HsEModuleContents m)
- renameExport (HsEGroup lev doc0) = do
- doc <- renameDoc doc0
- return (HsEGroup lev doc)
- renameExport (HsEDoc doc0) = do
- doc <- renameDoc doc0
- return (HsEDoc doc)
- renameExport (HsEDocNamed str) = return (HsEDocNamed str)
+renameMaybeDoc :: Maybe (HsDoc Name) -> RnM (Maybe (HsDoc DocName))
+renameMaybeDoc mbDoc = mapM renameDoc mbDoc
+
+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 Link 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')
+
+-- -----------------------------------------------------------------------------
+-- Renaming source code & documentation
+{-
renameDecl :: HsDecl -> RnM HsDecl
renameDecl decl
@@ -207,62 +232,6 @@ renameInstHead (ctx,asst) = do
asst <- renamePred asst
return (ctx,asst)
--- -----------------------------------------------------------------------------
--- Renaming documentation
-
--- Renaming documentation is done by "marking it up" from ordinary Doc
--- into (Rn Doc), which can then be renamed with runRn.
-markupRename :: DocMarkup [HsQName] (RnM Doc)
-markupRename = Markup {
- markupEmpty = return DocEmpty,
- markupString = return . DocString,
- markupParagraph = liftM DocParagraph,
- markupAppend = liftM2 DocAppend,
- markupIdentifier = lookupForDoc,
- markupModule = return . DocModule,
- markupEmphasis = liftM DocEmphasis,
- markupMonospaced = liftM DocMonospaced,
- markupUnorderedList = liftM DocUnorderedList . sequence,
- markupOrderedList = liftM DocOrderedList . sequence,
- markupDefList = liftM DocDefList . mapM markupDef,
- markupCodeBlock = liftM DocCodeBlock,
- markupURL = return . DocURL,
- markupAName = return . DocAName
- }
-
-markupDef (ma,mb) = do a <- ma; b <- mb; return (a,b)
-
-renameDoc :: Doc -> RnM Doc
-renameDoc = markup markupRename
-
-renameMaybeDoc :: Maybe Doc -> RnM (Maybe Doc)
-renameMaybeDoc Nothing = return Nothing
-renameMaybeDoc (Just doc) = Just `liftM` renameDoc doc
-
--- ---------------------------------------------------------------------------
--- Looking up names in documentation
-
-lookupForDoc :: [HsQName] -> RnM Doc
-lookupForDoc qns = do
- lkp <- getLookupRn
- case [ n | (True,n) <- map lkp qns ] of
- ns@(_:_) -> return (DocIdentifier ns)
- [] -> -- if we were given a qualified name, but there's nothing
- -- matching that name in scope, then just assume its existence
- -- (this means you can use qualified names in doc strings wihout
- -- worrying about whether the entity is in scope).
- let quals = filter isQualified qns in
- if (not (null quals)) then
- return (DocIdentifier quals)
- else do
- outRn (head qns)
- -- no qualified names: just replace this name with its
- -- string representation.
- return (DocString (show (head qns)))
- where
- isQualified (Qual _ _) = True
- isQualified _ = False
-
-- -----------------------------------------------------------------------------
renameExportItems :: [ExportItem] -> RnM [ExportItem]
@@ -284,3 +253,28 @@ renameExportItems items = mapM rn items
rn (ExportDoc doc0)
= do doc <- renameDoc doc0
return (ExportDoc doc)
+-}
+
+renameInstHead = undefined
+
+
+renameDecl = undefined
+
+renameExportItem :: ExportItem2 Name -> RnM (ExportItem2 DocName)
+renameExportItem item = case item of
+ ExportModule2 mod -> return (ExportModule2 mod)
+ ExportGroup2 lev id doc -> do
+ doc' <- renameDoc doc
+ return (ExportGroup2 lev id doc')
+ ExportDecl2 x decl doc instances -> do
+ decl' <- renameDecl decl
+ doc' <- mapM renameDoc doc
+ instances' <- mapM renameInstHead instances
+ return (ExportDecl2 x decl' doc' instances')
+ ExportNoDecl2 x y subs -> do
+ y' <- lookupRn id y
+ subs' <- mapM (lookupRn id) subs
+ return (ExportNoDecl2 x y' subs')
+ ExportDoc2 doc -> do
+ doc' <- renameDoc doc
+ return (ExportDoc2 doc')
diff --git a/src/HaddockTypes.hs b/src/HaddockTypes.hs
index df059f7d..b4cb6921 100644
--- a/src/HaddockTypes.hs
+++ b/src/HaddockTypes.hs
@@ -9,7 +9,8 @@ module HaddockTypes (
NameEnv, Interface(..), ExportItem(..), ExportItem2(..), ModuleMap, ModuleMap2,
HaddockModule(..),
-- * Misc types
- DocOption(..), InstHead,
+ DocOption(..), InstHead, InstHead2,
+ DocName(..),
) where
import HsSyn2
@@ -108,40 +109,71 @@ data ExportItem
| ExportModule -- a cross-reference to another module
Module
-data ExportItem2
+data ExportItem2 name
= ExportDecl2
- GHC.Name -- the original name
- (GHC.HsDecl GHC.Name) -- a declaration
- (Maybe (GHC.HsDoc GHC.Name)) -- maybe a doc comment
- [InstHead] -- instances relevant to this declaration
+ GHC.Name -- the original name
+ (GHC.LHsDecl name) -- a declaration
+ (Maybe (GHC.HsDoc name)) -- maybe a doc comment
+ [InstHead2] -- instances relevant to this declaration
| ExportNoDecl2 -- an exported entity for which we have no documentation
-- (perhaps becuase it resides in another package)
- GHC.Name -- the original name
- GHC.Name -- where to link to
- [GHC.Name] -- subordinate names
+ GHC.Name -- the original name
+ name -- where to link to
+ [name] -- subordinate names
| ExportGroup2 -- a section heading
Int -- section level (1, 2, 3, ... )
String -- section "id" (for hyperlinks)
- (GHC.HsDoc GHC.Name) -- section heading text
+ (GHC.HsDoc name) -- section heading text
| ExportDoc2 -- some documentation
- (GHC.HsDoc GHC.Name)
+ (GHC.HsDoc name)
| ExportModule2 -- a cross-reference to another module
GHC.Module
type InstHead = (HsContext,HsAsst)
+type InstHead2 = ([GHC.TyVar], [GHC.PredType], GHC.Class, [GHC.Type])
+
type ModuleMap = Map Module Interface
type ModuleMap2 = Map GHC.Module HaddockModule
+data DocName = Link GHC.Name | NoLink GHC.Name
+
data HaddockModule = HM {
+
+-- | A value to identify the module
+ hmod_mod :: GHC.Module,
+
+-- | The documentation header for this module
+ hmod_doc :: Maybe (GHC.HsDoc GHC.Name),
+
+-- | The Haddock options for this module (prune, ignore-exports, etc)
hmod_options :: [DocOption],
- hmod_exported_decl_map :: Map GHC.Name (GHC.HsDecl GHC.Name),
+
+ hmod_exported_decl_map :: Map GHC.Name (GHC.LHsDecl GHC.Name),
hmod_doc_map :: Map GHC.Name (GHC.HsDoc GHC.Name),
- hmod_orig_exports :: [ExportItem2],
- hmod_documented_exports :: [GHC.Name],
- hmod_sub_map :: Map GHC.Name [GHC.Name]
+ hmod_export_items :: [ExportItem2 GHC.Name],
+
+-- | All the names that are defined in this module
+ hmod_locals :: [GHC.Name],
+
+-- | All the names that are exported by this module
+ hmod_exports :: [GHC.Name],
+
+-- | All the visible names exported by this module
+-- For a name to be visible, it has to:
+-- - be exported normally, and not via a full module re-exportation.
+-- - have a declaration in this module or any of it's imports, with the exception
+-- that it can't be from another package.
+-- Basically, a visible name is a name that will show up in the documentation.
+-- for this module.
+ hmod_visible_exports :: [GHC.Name],
+
+ hmod_sub_map :: Map GHC.Name [GHC.Name],
+
+-- | The instances exported by this module
+ hmod_instances :: [GHC.Instance]
}
diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs
index 35290c27..7ce16cd3 100644
--- a/src/HaddockUtil.hs
+++ b/src/HaddockUtil.hs
@@ -143,8 +143,8 @@ addConDocs (x:xs) doc = addConDoc x doc : xs
-- ---------------------------------------------------------------------------
-- Making abstract declarations
-restrictTo :: [GHC.Name] -> (GHC.HsDecl GHC.Name) -> (GHC.HsDecl GHC.Name)
-restrictTo names decl = case decl of
+restrictTo :: [GHC.Name] -> (GHC.LHsDecl GHC.Name) -> (GHC.LHsDecl GHC.Name)
+restrictTo names (L loc decl) = L loc $ case decl of
GHC.TyClD d doc | GHC.isDataDecl d && GHC.tcdND d == GHC.DataType ->
GHC.TyClD (d { GHC.tcdCons = restrictCons names (GHC.tcdCons d) }) doc
GHC.TyClD d doc | GHC.isDataDecl d && GHC.tcdND d == GHC.NewType ->
diff --git a/src/Main.hs b/src/Main.hs
index 7af7e25e..13c1b129 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -55,6 +55,14 @@ import SrcLoc
import qualified Digraph as Digraph
import Name
import Module (moduleString)-- TODO: add an export to GHC API?
+import InstEnv
+import Class
+import TypeRep
+import Var
+import TyCon
+import PrelNames
+import FastString
+#define FSLIT(x) (mkFastString# (x#))
import qualified DynFlags as DynFlags
-----------------------------------------------------------------------------
@@ -236,25 +244,7 @@ run flags files = do
prologue <- getPrologue flags
- -- grok the --use-package flags
- pkg_ifaces_to_read <- getPackageIfaces flags verbose
-
- let ifaces_to_read = read_iface_flags ++ pkg_ifaces_to_read
-
- read_iface_stuff <- mapM readIface (map snd ifaces_to_read)
-
- let
- (read_ifacess, doc_envs) = unzip read_iface_stuff
- read_ifaces = concat read_ifacess
-
- ext_doc_env = Map.unions doc_envs
-
- visible_read_ifaces = filter ((OptHide `notElem`) . iface_options)
- read_ifaces
- external_mods = map iface_module read_ifaces
- pkg_paths = map fst ifaces_to_read
-
- updateHTMLXRefs pkg_paths read_ifacess
+-- updateHTMLXRefs pkg_paths read_ifacess
when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags)
&& Flag_Html `elem` flags) $
@@ -266,7 +256,7 @@ run flags files = do
visible_read_ifaces prologue
copyHtmlBits odir libdir css_file
-}
- when (Flag_GenIndex `elem` flags) $ do
+{- when (Flag_GenIndex `elem` flags) $ do
ppHtmlIndex odir title package maybe_html_help_format
maybe_contents_url maybe_source_urls maybe_wiki_urls
visible_read_ifaces
@@ -274,7 +264,7 @@ run flags files = do
when (Flag_GenContents `elem` flags && Flag_GenIndex `elem` flags) $ do
ppHtmlHelpFiles title package visible_read_ifaces odir maybe_html_help_format pkg_paths
-
+-}
GHC.init (Just "/home/davve/dev/local/lib/ghc-6.5")
let ghcMode = GHC.JustTypecheck
session <- GHC.newSession ghcMode
@@ -337,13 +327,27 @@ run flags files = do
printSDoc (ppr (Map.toList sub_names)) defaultUserStyle -}
- let (export_item_map, messages) = runWriter (pass1 sorted_checked_modules' flags)
+ let (modMap, messages) = runWriter (pass1 sorted_checked_modules' flags)
+
+ haddockModules = catMaybes [ Map.lookup mod modMap | (mod, _) <- sorted_checked_modules' ]
+
+ let env = buildGlobalDocEnv haddockModules
+
+ let haddockModules' = attachInstances haddockModules
+
+ let renamedModules = runWriter $ mapM (renameModule env) haddockModules'
putStrLn "pass 1 messages:"
print messages
putStrLn "pass 1 export items:"
- printSDoc (ppr (map (hmod_orig_exports . snd) (Map.toList export_item_map))) defaultUserStyle
+ printSDoc (ppr (map hmod_export_items haddockModules')) defaultUserStyle
+
+ putStrLn "pass 2 env:"
+ printSDoc (ppr (Map.toList env)) defaultUserStyle
+ putStrLn "pass 2 export items:"
+ printSDoc (ppr renamedModules) defaultUserStyle
+
--let Just (group, imports, exports) = GHC.renamedSource (head sorted_checked_modules)
--printSDoc (ppr group) defaultUserStyle
@@ -442,13 +446,19 @@ run flags files = do
print_ x = printSDoc (ppr x) defaultUserStyle
-instance Outputable ExportItem2 where
- ppr (ExportDecl2 n decl doc instns) = text "ExportDecl" <+> ppr n <+> ppr decl <+> ppr doc <+> text (show instns)
+instance (Outputable a, OutputableBndr a) => Outputable (ExportItem2 a) where
+ ppr (ExportDecl2 n decl doc instns) = text "ExportDecl" <+> ppr n <+> ppr decl <+> ppr doc <+> ppr instns
ppr (ExportNoDecl2 n1 n2 ns) = text "ExportNoDecl (org name, link name, sub names)" <+> ppr n1 <+> ppr n2 <+> ppr ns
ppr (ExportGroup2 lev id doc) = text "ExportGroup (lev, id, doc)" <+> ppr lev <+> ppr doc
ppr (ExportDoc2 doc) = text "ExportDoc" <+> ppr doc
ppr (ExportModule2 mod) = text "ExportModule" <+> ppr mod
+instance Outputable DocName where
+ ppr (Link name) = ppr name
+ ppr (NoLink name) = ppr name
+
+instance OutputableBndr DocName where
+ pprBndr _ d = ppr d
instance Outputable (GHC.DocEntity GHC.Name) where
ppr (GHC.DocEntity d) = ppr d
@@ -459,7 +469,7 @@ type FullyCheckedModule = (GHC.ParsedSource,
GHC.TypecheckedSource,
GHC.ModuleInfo)
-getDocumentedExports :: [ExportItem2] -> [GHC.Name]
+getDocumentedExports :: [ExportItem2 GHC.Name] -> [GHC.Name]
getDocumentedExports exports = concatMap getName exports
where
getName (ExportDecl2 name _ _ _) = [name]
@@ -469,40 +479,58 @@ pass1 :: [(GHC.Module, FullyCheckedModule)] -> [Flag] -> ErrMsgM ModuleMap2
pass1 modules flags = worker modules (Map.empty) flags
where
worker :: [(GHC.Module, FullyCheckedModule)] -> ModuleMap2 -> [Flag] -> ErrMsgM ModuleMap2
- worker [] module_map _ = return module_map
- worker ((mod, checked_mod):rest_modules) module_map flags = do
+ worker [] moduleMap _ = return moduleMap
+ worker ((mod, checked_mod):rest_modules) moduleMap flags = do
let (parsed_source, renamed_source, _, moduleInfo) = checked_mod
- (mb_doc_opts, haddock_mod_info, mb_mod_doc) = get_module_stuff parsed_source
+ (mb_doc_opts, haddock_mod_info, _) = get_module_stuff parsed_source
opts <- mk_doc_opts mb_doc_opts
- let exportedNames = GHC.modInfoExports moduleInfo
- (group, _, mb_exports, doc) = renamed_source
+ let (group, _, mb_exports, mbModDoc) = renamed_source
entities = nubBy sameName (GHC.hs_docs group)
- entityNames = getEntityNames entities
- exportedDeclMap = mkDeclMap exportedNames group
- localDeclMap = mkDeclMap entityNames group
- sub_map = mk_sub_map_from_group group
exports = fmap (map unLoc) mb_exports
- ignore_all_exports = Flag_IgnoreAllExports `elem` flags
+
+ -- lots of names
+ exportedNames = GHC.modInfoExports moduleInfo
+ theseEntityNames = entityNames entities
+ subNames = allSubnamesInGroup group
+ localNames = theseEntityNames ++ subNames
+ -- guaranteed to be Just, since the module has been compiled from scratch
+ scopeNames = fromJust $ GHC.modInfoTopLevelScope moduleInfo
+
+ subMap = mk_sub_map_from_group group
+
+ theseVisibleNames <- visibleNames mod moduleMap localNames scopeNames subMap exports opts
+
+ let exportedDeclMap = mkDeclMap exportedNames group
+ localDeclMap = mkDeclMap theseEntityNames group
docMap = mkDocMap group
-
- export_items <- mkExportItems module_map mod exportedNames
- exportedDeclMap localDeclMap sub_map entities opts
- exports ignore_all_exports docMap
+
+ ignore_all_exports = Flag_IgnoreAllExports `elem` flags
+
+ exportItems <- mkExportItems moduleMap mod exportedNames
+ exportedDeclMap localDeclMap subMap entities opts
+ exports ignore_all_exports docMap
+
+ let instances = GHC.modInfoInstances moduleInfo
let haddock_module = HM {
+ hmod_mod = mod,
+ hmod_doc = mbModDoc,
hmod_options = opts,
- hmod_exported_decl_map = exportedDeclMap,
+ hmod_locals = localNames,
hmod_doc_map = docMap,
- hmod_orig_exports = export_items,
- hmod_sub_map = sub_map,
- hmod_documented_exports = getDocumentedExports export_items
+ hmod_sub_map = subMap,
+ hmod_export_items = exportItems,
+ hmod_exports = exportedNames,
+ hmod_visible_exports = theseVisibleNames,
+ hmod_exported_decl_map = exportedDeclMap,
+ hmod_instances = instances
}
- let module_map' = Map.insert mod haddock_module module_map
- worker rest_modules module_map' flags
+ let moduleMap' = Map.insert mod haddock_module moduleMap
+ worker rest_modules moduleMap' flags
where
get_module_stuff source =
@@ -558,8 +586,8 @@ finishedDoc d GHC.DocEmpty rest = rest
finishedDoc (GHC.DeclEntity name) doc rest = (name, doc) : rest
finishedDoc _ _ rest = rest
-get_all_subnames_from_group :: GHC.HsGroup GHC.Name -> [GHC.Name]
-get_all_subnames_from_group group =
+allSubnamesInGroup :: GHC.HsGroup GHC.Name -> [GHC.Name]
+allSubnamesInGroup group =
concat [ tail (map unLoc (GHC.tyClDeclNames tycld)) | L _ tycld <- GHC.hs_tyclds group ]
mk_sub_map_from_group :: GHC.HsGroup GHC.Name -> Map GHC.Name [GHC.Name]
@@ -567,15 +595,15 @@ mk_sub_map_from_group group =
Map.fromList [ (name, subs) | L _ tycld <- GHC.hs_tyclds group,
let name:subs = map unLoc (GHC.tyClDeclNames tycld) ]
-mkDeclMap :: [GHC.Name] -> GHC.HsGroup GHC.Name -> Map GHC.Name (GHC.HsDecl GHC.Name)
+mkDeclMap :: [GHC.Name] -> GHC.HsGroup GHC.Name -> Map GHC.Name (GHC.LHsDecl GHC.Name)
mkDeclMap names group = Map.fromList [ (n,d) | (n,Just d) <- maybeDecls ]
where
maybeDecls = [ (name, getDeclFromGroup group name) | name <- names ]
-getEntityNames :: [GHC.DocEntity GHC.Name] -> [GHC.Name]
-getEntityNames entities = [ name | GHC.DeclEntity name <- entities ]
+entityNames :: [GHC.DocEntity GHC.Name] -> [GHC.Name]
+entityNames entities = [ name | GHC.DeclEntity name <- entities ]
-getDeclFromGroup :: GHC.HsGroup GHC.Name -> GHC.Name -> Maybe (GHC.HsDecl GHC.Name)
+getDeclFromGroup :: GHC.HsGroup GHC.Name -> GHC.Name -> Maybe (GHC.LHsDecl GHC.Name)
getDeclFromGroup group name = case catMaybes [getDeclFromVals (GHC.hs_valds group),
getDeclFromTyCls (GHC.hs_tyclds group),
getDeclFromFors (GHC.hs_fords group)] of
@@ -583,24 +611,24 @@ getDeclFromGroup group name = case catMaybes [getDeclFromVals (GHC.hs_valds gr
_ -> Nothing
where
getDeclFromVals (GHC.ValBindsOut _ lsigs) = case matching of
- [lsig] -> Just (GHC.SigD (unLoc lsig) Nothing)
+ [lsig] -> Just (L (getLoc lsig) (GHC.SigD (unLoc lsig) Nothing))
_ -> Nothing
where
matching = [ lsig | lsig <- lsigs, let Just n = GHC.sigName lsig, n == name ]
getDeclFromVals _ = error "getDeclFromVals: illegal input"
getDeclFromTyCls ltycls = case matching of
- [ltycl] -> Just (GHC.TyClD (unLoc ltycl) Nothing)
+ [ltycl] -> Just (L (getLoc ltycl) (GHC.TyClD (unLoc ltycl) Nothing))
_ -> Nothing
where
matching = [ ltycl | ltycl <- ltycls,
name `elem` map unLoc (GHC.tyClDeclNames (unLoc ltycl))]
getDeclFromFors lfors = case matching of
- [for] -> Just (GHC.ForD for Nothing)
+ [for] -> Just (L (getLoc for) (GHC.ForD (unLoc for) Nothing))
_ -> Nothing
where
- matching = [ for | L _ for <- lfors, forName for == name ]
+ matching = [ for | for <- lfors, forName (unLoc for) == name ]
forName (GHC.ForeignExport n _ _ _) = unLoc n
forName (GHC.ForeignImport n _ _ _) = unLoc n
@@ -618,30 +646,6 @@ updateHTMLXRefs paths ifaces_s =
| (fpath, ifaces) <- zip paths ifaces_s,
iface <- ifaces
]
-{-
-parse_file :: FilePath -> IO HsModule
-parse_file file = do
- bracket
- (openFile file ReadMode)
- (\h -> hClose h)
- (\h -> do stuff <- hGetContents h
- case parse stuff (SrcLoc 1 1 file) 1 0 file [] of
- Ok _ e -> return e
- Failed err -> die (file ++ ':':err ++ "\n")
- )
--}
-{-
-getPrologue :: [Flag] -> IO (Maybe Doc)
-getPrologue flags
- = case [filename | Flag_Prologue filename <- flags ] of
- [] -> return Nothing
- [filename] -> do
- str <- readFile filename
- case parseParas (tokenise str) of
- Left err -> dieMsg err
- Right doc -> return (Just doc)
- _otherwise -> dieMsg "multiple -p/--prologue options"
--}
getPrologue :: [Flag] -> IO (Maybe (GHC.HsDoc GHC.RdrName))
getPrologue flags
@@ -654,63 +658,6 @@ getPrologue flags
Right doc -> return (Just doc)
_otherwise -> dieMsg "multiple -p/--prologue options"
--- ---------------------------------------------------------------------------
--- External packages
-
-getPackageIfaces :: [Flag] -> Bool -> IO [(String,String)]
-getPackageIfaces flags verbose =
- let
- pkgs = [pkg | Flag_UsePackage pkg <- flags]
- in
-#if __GLASGOW_HASKELL__ < 603
- if (not (null pkgs))
- then die ("-use-package not supported; recompile Haddock with GHC 6.4 or later")
- else return []
-#else
- do
- mb_iface_details <- mapM getPkgIface pkgs
- return [ ok | Just ok <- mb_iface_details ]
- where
- hc_pkg = "ghc-pkg" -- ToDo: flag
-
- getPkgIface pkg = do
- when verbose $
- putStrLn ("querying ghc-pkg for " ++ pkg ++ "...")
- getPkgIface' pkg
- `catch` (\e -> do
- putStrLn ("Warning: cannot use package " ++ pkg ++ ":")
- putStrLn (" " ++ show e)
- return Nothing)
-
- getPkgIface' pkg = do
- html <- getPkgField pkg "haddock-html"
- html_exists <- doesDirectoryExist html
- when (not html_exists) $ do
- throwIO (ErrorCall ("HTML directory " ++ html ++ " does not exist."))
-
- iface <- getPkgField pkg "haddock-interfaces"
- iface_exists <- doesFileExist iface
- when (not iface_exists) $ do
- throwIO (ErrorCall ("interface " ++ iface ++ " does not exist."))
-
- return (Just (html, iface))
-
- getPkgField pkg field = do
- (hin,hout,herr,p) <- runInteractiveProcess hc_pkg
- ["field", pkg, field]
- Nothing Nothing
- hClose hin
- out <- hGetContents hout
- forkIO (hGetContents herr >> return ()) -- just sink the stderr
- r <- waitForProcess p
- when (r /= ExitSuccess) $
- throwIO (ErrorCall ("ghc-pkg failed"))
- let value = dropWhile isSpace $ init $ tail $ dropWhile (/=':') out
- when verbose $
- putStrLn (" " ++ field ++ ": " ++ value)
- return value
-#endif
-
-----------------------------------------------------------------------------
-- Figuring out the definitions that are exported from a module
@@ -862,71 +809,44 @@ mkInterfacePhase1 flags verbose mod_map filename package
iface_insts = instances
}
)
-
+-}
-- -----------------------------------------------------------------------------
-- Phase 2
-mkInterfacePhase2
- :: Bool -- verbose
- -> Interface
- -> Map HsQName HsQName -- global doc-name mapping
- -> ErrMsgM Interface
-
-mkInterfacePhase2 verbose iface gbl_doc_env =
- case iface of {
- Interface {
- iface_module = this_mdl,
- iface_env = env,
- iface_reexported = reexports,
- iface_orig_exports = orig_export_items,
- iface_doc = orig_module_doc } ->
-
- let
- -- [ The export list from the renamed output (sort of) ]
- exported_visible_names =
- [orig | (nm,orig) <- Map.toAscList env, nm `notElem` reexports ]
-
- -- build the import_env.
- import_env = foldl fn gbl_doc_env exported_visible_names
- where fn env qnm@(Qual _ nm) = Map.insert qnm (Qual this_mdl nm) env
- fn env (UnQual nm) = env
-
- -- rename names in the exported declarations to point to things that
- -- are closer, or maybe even exported by, the current module.
- (renamed_export_list, missing_names1)
- = runRnUnqualFM import_env (renameExportItems orig_export_items)
-
- (final_module_doc, missing_names2)
- = runRnUnqualFM import_env (renameMaybeDoc orig_module_doc)
-
- -- we're only interested in reporting missing *qualfied*
- -- names, the unqualified ones are the ones that couldn't
- -- be resolved in phase 1 and have already been reported.
- filtered_missing_names =
- filter isQual (missing_names1 ++ missing_names2)
- where isQual (Qual _ _) = True
- isQual _ = False
-
- missing_names = map show (nub filtered_missing_names)
- in do
+renameModule :: Map GHC.Name GHC.Name -> HaddockModule -> ErrMsgM ([ExportItem2 DocName], Maybe (GHC.HsDoc DocName))
+renameModule 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 renameing
+ -- env
+ let localEnv = foldl fn renamingEnv (hmod_visible_exports mod)
+ where fn env name = Map.insert name (nameSetMod name (hmod_mod mod)) env
+
+ -- rename names in the exported declarations to point to things that
+ -- are closer, or maybe even exported by, the current module.
+ (renamedExportItems, missingNames1)
+ = runRnFM localEnv (renameExportItems (hmod_export_items mod))
+ (finalModuleDoc, missingNames2)
+ = runRnFM localEnv (renameMaybeDoc (hmod_doc mod))
+
+ missingNames = map (showSDoc . ppr) (nub (missingNames1 ++ missingNames2))
+ in do
-- report things that we couldn't link to. Only do this
-- for non-hidden modules.
- when (OptHide `notElem` iface_options iface &&
- not (null missing_names)) $
- tell ["Warning: " ++ show this_mdl ++
+ when (OptHide `notElem` hmod_options mod &&
+ not (null missingNames)) $
+ tell ["Warning: " ++ show (ppr (hmod_mod mod) defaultUserStyle) ++
": could not find link destinations for:\n"++
- " " ++ concat (map (' ':) missing_names)
+ " " ++ concat (map (' ':) missingNames)
]
-- trace (show (Map.toAscList import_env)) $ do
- return iface{ iface_exports = renamed_export_list,
- iface_doc = final_module_doc }
- }
-
+ return (renamedExportItems, finalModuleDoc)
+
-- -----------------------------------------------------------------------------
-
+{-
-- Try to generate instance declarations for derived instances.
-- We can't do this properly without instance inference, but if a type
-- variable occurs as a constructor argument, then we can just
@@ -1014,15 +934,15 @@ mkExportItems
:: ModuleMap2
-> GHC.Module -- this module
-> [GHC.Name] -- exported names (orig)
- -> Map GHC.Name (GHC.HsDecl GHC.Name) -- maps exported names to declarations
- -> Map GHC.Name (GHC.HsDecl GHC.Name) -- maps local names to declarations
+ -> Map GHC.Name (GHC.LHsDecl GHC.Name) -- maps exported names to declarations
+ -> Map GHC.Name (GHC.LHsDecl GHC.Name) -- maps local names to declarations
-> Map GHC.Name [GHC.Name] -- sub-map for this module
-> [GHC.DocEntity GHC.Name] -- entities in the current module
-> [DocOption]
-> Maybe [GHC.IE GHC.Name]
-> Bool -- --ignore-all-exports flag
-> Map GHC.Name (GHC.HsDoc GHC.Name)
- -> ErrMsgM [ExportItem2]
+ -> ErrMsgM [ExportItem2 GHC.Name]
mkExportItems mod_map this_mod exported_names exportedDeclMap localDeclMap sub_map entities
opts maybe_exps ignore_all_exports docMap
@@ -1049,7 +969,7 @@ mkExportItems mod_map this_mod exported_names exportedDeclMap localDeclMap sub_m
Just found -> return [ ExportDoc2 found ]
-- NOTE: I'm unsure about this. Currently only "External" names are considered.
- declWith :: GHC.Name -> ErrMsgM [ ExportItem2 ]
+ declWith :: GHC.Name -> ErrMsgM [ ExportItem2 GHC.Name ]
declWith t | not (isExternalName t) = return []
declWith t
| (Just decl, maybeDoc) <- findDecl t
@@ -1072,11 +992,11 @@ mkExportItems mod_map this_mod exported_names exportedDeclMap localDeclMap sub_m
case Map.lookup m mod_map of
Just hmod
| OptHide `elem` hmod_options hmod
- -> return (hmod_orig_exports hmod)
+ -> return (hmod_export_items hmod)
| otherwise -> return [ ExportModule2 m ]
Nothing -> return [] -- already emitted a warning in exportedNames
- findDecl :: GHC.Name -> (Maybe (GHC.HsDecl GHC.Name), Maybe (GHC.HsDoc GHC.Name))
+ findDecl :: GHC.Name -> (Maybe (GHC.LHsDecl GHC.Name), Maybe (GHC.HsDoc GHC.Name))
findDecl n | not (isExternalName n) = error "This shouldn't happen"
findDecl n
| m == this_mod = (Map.lookup n exportedDeclMap, Map.lookup n docMap)
@@ -1088,8 +1008,8 @@ mkExportItems mod_map this_mod exported_names exportedDeclMap localDeclMap sub_m
where
m = nameModule n
-fullContentsOfThisModule :: GHC.Module -> [GHC.DocEntity GHC.Name] -> Map GHC.Name (GHC.HsDecl GHC.Name) ->
- Map GHC.Name (GHC.HsDoc GHC.Name) -> [ExportItem2]
+fullContentsOfThisModule :: GHC.Module -> [GHC.DocEntity GHC.Name] -> Map GHC.Name (GHC.LHsDecl GHC.Name) ->
+ Map GHC.Name (GHC.HsDoc GHC.Name) -> [ExportItem2 GHC.Name]
fullContentsOfThisModule module_ entities declMap docMap = map mkExportItem entities
where
mkExportItem (GHC.DocEntity (GHC.DocGroup lev doc)) = ExportGroup2 lev "" doc
@@ -1097,133 +1017,27 @@ fullContentsOfThisModule module_ entities declMap docMap = map mkExportItem enti
Just decl -> let maybe_doc = Map.lookup name docMap in ExportDecl2 name decl maybe_doc []
Nothing -> error "fullContentsOfThisModule: This shouldn't happen"
-{-
---< -----------------------------------------------------------------------------
--- 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
- :: ModuleMap
- -> GHC.Module -- this module
- -> [GHC.Name] -- exported names (orig)
- -> Map HsName HsDecl -- maps local names to declarations
- -> Map HsName [HsName] -- sub-map for this module
- -> [HsDecl] -- decls in the current module
- -> [DocOption]
- -> Maybe [HsExportSpec]
- -> Bool -- --ignore-all-exports flag
- -> ErrMsgM [ExportItem]
-
-mkExportItems mod_map this_mod exported_names decl_map sub_map decls
- opts maybe_exps ignore_all_exports
- | 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 decls)
-
- lookupExport (HsEVar x) = declWith x
- lookupExport (HsEAbs t) = declWith t
- lookupExport (HsEThingAll t) = declWith t
- lookupExport (HsEThingWith t cs) = declWith t
- lookupExport (HsEModuleContents m) = fullContentsOf m
- lookupExport (HsEGroup lev doc) = return [ ExportGroup lev "" doc ]
- lookupExport (HsEDoc doc) = return [ ExportDoc doc ]
- lookupExport (HsEDocNamed str)
- = do r <- findNamedDoc str decls
- case r of
- Nothing -> return []
- Just found -> return [ ExportDoc found ]
-
- declWith :: HsQName -> ErrMsgM [ ExportItem ]
- declWith (UnQual _) = return []
- declWith t@(Qual mdl x)
- | Just decl <- findDecl t
- = return [ ExportDecl t (restrictTo subs (extractDecl x mdl decl)) [] ]
- | otherwise
- = return [ ExportNoDecl t t (map (Qual mdl) subs) ]
- -- can't find the decl (it might be from another package), but let's
- -- list the entity anyway. Later on, the renamer will change the
- -- orig name into the import name, so we get a proper link to
- -- the doc for this entity.
- where
- subs = map nameOfQName subs_qnames
- subs_qnames = filter (`elem` exported_names) all_subs_qnames
-
- all_subs_qnames = map (Qual mdl) all_subs
-
- all_subs | mdl == this_mod = Map.findWithDefault [] x sub_map
- | otherwise = all_subs_of_qname mod_map t
-
- fullContentsOf m
- | m == this_mod = return (fullContentsOfThisModule this_mod decls)
- | otherwise =
- case Map.lookup m mod_map of
- Just iface
- | OptHide `elem` iface_options iface
- -> return (iface_orig_exports iface)
- | otherwise -> return [ ExportModule m ]
- Nothing -> return [] -- already emitted a warning in exportedNames
-
- findDecl :: HsQName -> Maybe HsDecl
- findDecl (UnQual _)
- = Nothing -- must be a name we couldn't resolve
- findDecl (Qual m n)
- | m == this_mod = Map.lookup n decl_map
- | otherwise =
- case Map.lookup m mod_map of
- Just iface -> Map.lookup n (iface_decls iface)
- Nothing -> Nothing
-
-
-fullContentsOfThisModule :: Module -> [HsDecl] -> [ExportItem]
-fullContentsOfThisModule mdl decls =
- map mkExportItem (filter keepDecl decls)
- where mkExportItem (HsDocGroup _ lev doc) = ExportGroup lev "" doc
- mkExportItem decl = ExportDecl (Qual mdl x) decl []
- where Just x = declMainBinder decl
-
-keepDecl :: HsDecl -> Bool
-keepDecl HsTypeSig{} = True
-keepDecl HsTypeDecl{} = True
-keepDecl HsNewTypeDecl{} = True
-keepDecl HsDataDecl{} = True
-keepDecl HsClassDecl{} = True
-keepDecl HsDocGroup{} = True
-keepDecl HsForeignImport{} = True
-keepDecl _ = False
-
--}
-
-- 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...)
--- We put noSrcSpan everywhere in the cobbled together type signatures since
--- they're not actually located in the source code.
-extractDecl :: GHC.Name -> GHC.Module -> GHC.HsDecl GHC.Name -> GHC.HsDecl GHC.Name
+extractDecl :: GHC.Name -> GHC.Module -> GHC.LHsDecl GHC.Name -> GHC.LHsDecl GHC.Name
extractDecl name mdl decl
- | Just n <- GHC.getMainDeclBinder decl, n == name = decl
+ | Just n <- GHC.getMainDeclBinder (unLoc decl), n == name = decl
| otherwise =
- case decl of
+ case unLoc decl of
GHC.TyClD d _ | GHC.isClassDecl d ->
let matches = [ sig | sig <- GHC.tcdSigs d, GHC.sigName sig == Just name ]
in case matches of
[s0] -> let (n, tyvar_names) = name_and_tyvars d
- in GHC.SigD (extractClassDecl n mdl tyvar_names s0) Nothing
+ L pos sig = extractClassDecl n mdl tyvar_names s0
+ in L pos (GHC.SigD sig Nothing)
_ -> error "internal: extractDecl"
GHC.TyClD d _ | GHC.isDataDecl d ->
let (n, tyvar_names) = name_and_tyvars d
- sig = extractRecSel name mdl n tyvar_names (GHC.tcdCons d)
- in GHC.SigD sig Nothing
+ L pos sig = extractRecSel name mdl n tyvar_names (GHC.tcdCons d)
+ in L pos (GHC.SigD sig Nothing)
_ -> error "internal: extractDecl"
where
name_and_tyvars d = (unLoc (GHC.tcdLName d), GHC.hsLTyVarLocNames (GHC.tcdTyVars d))
@@ -1238,82 +1052,31 @@ rmLoc :: Located a -> Located a
rmLoc a = mkNoLoc (unLoc a)
-- originally expected unqualified 1:st name, now it doesn't
-extractClassDecl :: GHC.Name -> GHC.Module -> [Located GHC.Name] -> GHC.LSig GHC.Name -> GHC.Sig GHC.Name
-extractClassDecl c mdl tvs0 (L _ (GHC.TypeSig lname ltype)) = case ltype of
+extractClassDecl :: GHC.Name -> GHC.Module -> [Located GHC.Name] -> GHC.LSig GHC.Name -> GHC.LSig GHC.Name
+extractClassDecl c mdl tvs0 (L pos (GHC.TypeSig lname ltype)) = case ltype of
L _ (GHC.HsForAllTy exp tvs (L _ preds) ty) ->
- GHC.TypeSig (rmLoc lname) (mkNoLoc (GHC.HsForAllTy exp tvs (lctxt preds) ty))
- _ -> GHC.TypeSig (rmLoc lname) (mkNoLoc (GHC.mkImplicitHsForAllTy (lctxt []) ltype))
+ L pos (GHC.TypeSig lname (mkNoLoc (GHC.HsForAllTy exp tvs (lctxt preds) ty)))
+ _ -> L pos (GHC.TypeSig lname (mkNoLoc (GHC.mkImplicitHsForAllTy (lctxt []) ltype)))
where
lctxt preds = mkNoLoc (ctxt preds)
ctxt preds = [mkNoLoc (GHC.HsClassP c (map toTypeNoLoc tvs0))] ++ preds
-extractClassDecl _ _ _ d = error $ "Main.extractClassDecl: unexpected decl"
+extractClassDecl _ _ _ d = error $ "extractClassDecl: unexpected decl"
extractRecSel :: GHC.Name -> GHC.Module -> GHC.Name -> [Located GHC.Name] -> [GHC.LConDecl GHC.Name]
- -> GHC.Sig GHC.Name
+ -> GHC.LSig GHC.Name
extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
-- originally expected unqualified 3:rd name, now it doesn't
extractRecSel nm mdl t tvs (L _ con : rest) =
case GHC.con_details con of
GHC.RecCon fields | (GHC.HsRecField n ty _ : _) <- matching_fields fields ->
- GHC.TypeSig (mkNoLoc nm) (mkNoLoc (GHC.HsFunTy data_ty (GHC.getBangType ty)))
+ L (getLoc n) (GHC.TypeSig (mkNoLoc nm) (mkNoLoc (GHC.HsFunTy data_ty (GHC.getBangType ty))))
_ -> extractRecSel nm mdl t tvs rest
where
matching_fields flds = [ f | f@(GHC.HsRecField n _ _) <- flds, (unLoc n) == nm ]
data_ty = foldl (\x y -> mkNoLoc (GHC.HsAppTy x y)) (mkNoLoc (GHC.HsTyVar t)) (map toTypeNoLoc tvs)
--- 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 :: HsName -> Module -> HsDecl -> HsDecl
-extractDecl name mdl decl
- | Just n <- declMainBinder decl, n == name = decl
- | otherwise =
- case decl of
- HsClassDecl _ _ n tvs _ decls _ ->
- case [ d | d@HsTypeSig{} <- decls,
- declMainBinder d == Just name ] of
- [d0] -> extractClassDecl n mdl tvs d0
- _ -> error "internal: extractDecl"
-
- HsDataDecl _ _ t tvs cons _ _ ->
- extractRecSel name mdl t tvs cons
-
- HsNewTypeDecl _ _ t tvs con _ _ ->
- extractRecSel name mdl t tvs [con]
-
- _ -> error ("extractDecl: " ++ show decl)
-
-extractClassDecl :: HsName -> Module -> [HsName] -> HsDecl -> HsDecl
-extractClassDecl c mdl tvs0 (HsTypeSig loc [n] ty doc)
- = case ty of
- HsForAllType tvs ctxt' ty' ->
- HsTypeSig loc [n] (HsForAllType tvs (ctxt ++ ctxt') ty') doc
- _ ->
- HsTypeSig loc [n] (HsForAllType Nothing ctxt ty) doc
- where
- ctxt = [HsAssump (Qual mdl c, map HsTyVar tvs0)]
-extractClassDecl _ _ _ d =
- error $ "Main.extractClassDecl: unexpected decl: " ++ show d
-
-extractRecSel :: HsName -> Module -> HsName -> [HsName] -> [HsConDecl]
- -> HsDecl
-extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
-extractRecSel nm mdl t tvs (d@(HsConDecl{}):rest) =
- extractRecSel nm mdl t tvs rest
-extractRecSel nm mdl t tvs (HsRecDecl loc _ _tvs _ fields _mb_doc : rest)
- | (HsFieldDecl ns ty mb_doc : _) <- matching_fields
- = HsTypeSig loc [nm] (HsTyFun data_ty (unbang ty)) mb_doc
- | otherwise = extractRecSel nm mdl t tvs rest
- where
- matching_fields = [ f | f@(HsFieldDecl ns ty mb_doc) <- fields,
- nm `elem` ns ]
-
- data_ty = foldl HsTyApp (HsTyCon (Qual mdl t)) (map HsTyVar tvs)
--}
-- -----------------------------------------------------------------------------
-- Pruning
@@ -1322,109 +1085,57 @@ pruneExportItems items = filter has_doc items
where has_doc (ExportDecl _ d _) = isJust (declDoc d)
has_doc _ = True
--- -----------------------------------------------------------------------------
--- Make a sub-name map for this module
-
-mkSubNames :: [HsDecl] -> Map HsName [HsName]
-mkSubNames decls =
- Map.fromList [ (n, subs) | d <- decls,
- Just n <- [declMainBinder d],
- subs@(_:_) <- [declSubBinders d] ]
-- -----------------------------------------------------------------------------
-- Gather a list of original names exported from this module
-{-
-exportedNames :: Module -> ModuleMap -> [HsName]
- -> Map HsQName HsQName
- -> Map HsName [HsName]
- -> Maybe [HsExportSpec]
- -> [DocOption]
- -> ErrMsgM ([HsQName], [HsQName])
-
-exportedNames mdl mod_map local_names orig_env sub_map maybe_exps opts
- | Nothing <- maybe_exps
- = return all_local_names_pr
- | OptIgnoreExports `elem` opts
- = return all_local_names_pr
- | Just expspecs <- maybe_exps
- = do all_names <- mapM extract expspecs
- all_vis_names <- mapM extract_vis expspecs
- return (concat all_names, concat all_vis_names)
- where
- all_local_names = map (Qual mdl) local_names
- all_local_names_pr = (all_local_names,all_local_names)
- in_scope = Set.fromList (Map.elems orig_env)
+visibleNames :: GHC.Module
+ -> ModuleMap2
+ -> [GHC.Name]
+ -> [GHC.Name]
+ -> Map GHC.Name [GHC.Name]
+ -> Maybe [GHC.IE GHC.Name]
+ -> [DocOption]
+ -> ErrMsgM [GHC.Name]
+
+visibleNames mdl modMap localNames scope subMap maybeExps opts
+ -- if no export list, just return all local names
+ | Nothing <- maybeExps = return localNames
+ | OptIgnoreExports `elem` opts = return localNames
+ | Just expspecs <- maybeExps = do
+ visibleNames <- mapM extract expspecs
+ return $ filter isNotPackageName (concat visibleNames)
+ where
+ isNotPackageName name = nameMod == mdl || isJust (Map.lookup nameMod modMap)
+ where nameMod = nameModule name
extract e =
case e of
- HsEVar x -> return [x]
- HsEAbs t -> return [t]
- HsEThingAll t@(Qual m x) ->
- return (t : filter (`Set.member` in_scope) (map (Qual m) all_subs))
+ GHC.IEVar x -> return [x]
+ GHC.IEThingAbs t -> return [t]
+ GHC.IEThingAll t -> return (t : all_subs)
where
- all_subs | m == mdl = Map.findWithDefault [] x sub_map
- | otherwise = all_subs_of_qname mod_map t
+ all_subs | nameModule t == mdl = Map.findWithDefault [] t subMap
+ | otherwise = all_subs_of_qname modMap t
- HsEThingWith t cs -> return (t : cs)
- HsEModuleContents m
- | m == mdl -> return (map (Qual mdl) local_names)
- | otherwise ->
- case Map.lookup m mod_map of
- Just iface ->
- return (filter (`Set.member` in_scope) (Map.elems (iface_env iface)))
- Nothing ->
- do tell (exportModuleMissingErr mdl m)
- return []
- _ -> return []
-
- -- Just the names that will be visible in the documentation
- -- (ie. omit names exported via a 'module M' export, if we are just
- -- going to cross-reference the module).
- extract_vis e =
- case e of
- HsEModuleContents m
- | m == mdl -> return (map (Qual mdl) local_names)
+ GHC.IEThingWith t cs -> return (t : cs)
+
+ GHC.IEModuleContents m
+ | m == mdl -> return localNames
| otherwise ->
- case Map.lookup m mod_map of
- Just iface
- | OptHide `elem` iface_options iface ->
- return (filter (`Set.member` in_scope) (Map.elems (iface_env iface)))
+ case Map.lookup m modMap of
+ Just mod
+ | OptHide `elem` hmod_options mod ->
+ return (filter (`elem` scope) (hmod_exports mod))
| otherwise -> return []
Nothing
- -> return [] -- we already emitted a warning above
-
- -- remaining cases: we have to catch names which are reexported from
- -- here, but for which we have no documentation, perhaps because they
- -- are from another package. We have to do this by looking for
- -- the declaration in the other module.
- _ -> do xs <- extract e
- return (filter is_documented_here xs)
-
- is_documented_here (UnQual _) = False
- is_documented_here (Qual m n)
- | m == mdl = True -- well, it's not documented anywhere else!
- | otherwise =
- case Map.lookup m mod_map of
- Nothing -> False
- Just iface -> isJust (Map.lookup n (iface_decls iface))
--}
+ -> tell ["Can not reexport a package module"] >> return []
+
+ _ -> return []
+
exportModuleMissingErr this mdl
= ["Warning: in export list of " ++ show this
++ ": module not found: " ++ show 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).
-all_subs_of_qname :: ModuleMap -> HsQName -> [HsName]
-all_subs_of_qname mod_map (Qual mdl nm) =
- case Map.lookup mdl mod_map of
- Just iface -> Map.findWithDefault [] nm (iface_sub iface)
- Nothing -> []
-all_subs_of_qname _ n@(UnQual _) =
- error $ "Main.all_subs_of_qname: unexpected unqual'd name:" ++ show n
--}
-
-- 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
@@ -1437,83 +1148,6 @@ all_subs_of_qname mod_map name
Nothing -> []
| otherwise = error $ "Main.all_subs_of_qname: unexpected unqual'd name"
--- ----------------------------------------------------------------------------
--- Building name environments
-
--- The orig env maps names in the current source file to
--- fully-qualified "original" names.
-{-
-buildOrigEnv :: Module -> Bool -> ModuleMap -> [HsImportDecl]
- -> ErrMsgM (Map HsQName HsQName)
-buildOrigEnv this_mdl verbose mod_map imp_decls
- = do maps <- mapM build imp_decls
- return (Map.unions (reverse maps))
- where
- build imp_decl@(HsImportDecl _ mdl qual maybe_as _)
- = case Map.lookup mdl mod_map of
- Nothing -> do
- when verbose $
- -- only emit missing module messages when -v is on. Otherwise
- -- we get a ton of spurious messages about missing "Prelude".
- tell ["Warning: " ++ show this_mdl
- ++ ": imported module not found: " ++ show mdl]
- return Map.empty
- Just iface ->
- return (Map.fromList (concat (map orig_map
- (processImportDecl mod_map imp_decl))))
- where
-
- -- bring both qualified and unqualified names into scope, unless
- -- the import was 'qualified'.
- orig_map (nm,qnm)
- | qual = [ (Qual qual_module nm, qnm) ]
- | otherwise = [ (Qual qual_module nm, qnm), (UnQual nm, qnm) ]
-
- qual_module
- | Just m <- maybe_as = m
- | otherwise = mdl
--}
-{-
-processImportDecl :: ModuleMap -> HsImportDecl -> [(HsName,HsQName)]
-processImportDecl mod_map (HsImportDecl _ mdl is_qualified maybe_as imp_specs)
- = case Map.lookup mdl mod_map of
- Nothing -> []
- Just iface -> imported_names
- where
- env = iface_env iface
- sub = iface_sub iface
-
- all_names = Map.toAscList env
-
- imported_names :: [(HsName,HsQName)]
- imported_names
- = case imp_specs of
- Nothing -> all_names
- Just (False,specs) -> [ (n,qnm) | (n,qnm) <- all_names,
- n `elem` names specs False ]
- Just (True, specs) -> [ (n,qnm) | (n,qnm) <- all_names,
- n `notElem` names specs True ]
- where
- names specs is_hiding
- = concat (map (spec_names is_hiding) specs)
-
- -- when hiding, a conid refers to both the constructor and
- -- the type/class constructor.
- spec_names _hid (HsIVar v) = [v]
- spec_names True (HsIAbs (HsTyClsName i))
- = [HsTyClsName i, HsVarName i]
- spec_names False (HsIAbs v) = [v]
- spec_names _hid (HsIThingAll v) = v : sub_names v
- spec_names _hid (HsIThingWith v xs) = v : xs
-
- sub_names :: HsName -> [HsName]
- sub_names nm =
- case Map.lookup nm env of
- Just qnm -> filter (`Map.member` env) (all_subs_of_qname mod_map qnm)
- _ -> []
--}
--- -----------------------------------------------------------------------------
-
-- | Build a mapping which for each original name, points to the "best"
-- place to link to in the documentation. For the definition of
-- "best", we use "the module nearest the bottom of the dependency
@@ -1523,30 +1157,27 @@ processImportDecl mod_map (HsImportDecl _ mdl is_qualified maybe_as imp_specs)
-- The interfaces are passed in in topologically sorted order, but we start
-- by reversing the list so we can do a foldl.
--
-buildGlobalDocEnv :: [Interface] -> Map HsQName HsQName
-buildGlobalDocEnv ifaces
- = foldl upd Map.empty (reverse ifaces)
+
+buildGlobalDocEnv :: [HaddockModule] -> Map GHC.Name GHC.Name
+buildGlobalDocEnv modules
+ = foldl upd Map.empty (reverse modules)
where
- upd old_env iface
- | OptHide `elem` iface_options iface
+ upd old_env mod
+ | OptHide `elem` hmod_options mod
= old_env
- | OptNotHome `elem` iface_options iface
+ | OptNotHome `elem` hmod_options mod
= foldl' keep_old old_env exported_names
| otherwise
= foldl' keep_new old_env exported_names
where
- mdl = iface_module iface
- exported_names = filter not_reexported (Map.elems (iface_env iface))
+ exported_names = hmod_visible_exports mod
+ modName = hmod_mod mod
- not_reexported (Qual _ n) = n `notElem` iface_reexported iface
- not_reexported (UnQual n) = n `notElem` iface_reexported iface
- -- UnQual probably shouldn't happen
+ keep_old env n = Map.insertWith (\new old -> old)
+ n (nameSetMod n modName) env
+ keep_new env n = Map.insert n (nameSetMod n modName) env
- keep_old env qnm = Map.insertWith (\new old -> old)
- qnm (Qual mdl nm) env
- where nm = nameOfQName qnm
- keep_new env qnm = Map.insert qnm (Qual mdl nm) env
- where nm = nameOfQName qnm
+nameSetMod n newMod = mkExternalName (nameUnique n) newMod (nameOccName n) Nothing (nameSrcLoc n)
builtinDocEnv = Map.fromList (map (\a -> (a,a)) builtinNames)
@@ -1556,73 +1187,9 @@ builtinNames =
[unit_tycon_qname, fun_tycon_qname, list_tycon_qname,
unit_con_name, nil_con_name]
--- -----------------------------------------------------------------------------
--- Expand multiple type signatures
-
-expandDecl :: HsDecl -> [HsDecl]
-expandDecl (HsTypeSig loc fs qt doc) = [ HsTypeSig loc [f] qt doc | f <- fs ]
-expandDecl (HsClassDecl loc ctxt n tvs fds decls doc)
- = [ HsClassDecl loc ctxt n tvs fds (concat (map expandDecl decls)) doc ]
-expandDecl d = [ d ]
-
------------------------------------------------------------------------------
--- Collecting documentation and attach it to the right declarations
-{-
-collectDoc :: [HsDecl] -> [HsDecl]
-collectDoc decls = collect Nothing DocEmpty decls
-
-collect :: Maybe HsDecl -> GenDoc [HsQName] -> [HsDecl] -> [HsDecl]
-collect d doc_so_far [] =
- case d of
- Nothing -> []
- Just d0 -> finishedDoc d0 doc_so_far []
-
-collect d doc_so_far (decl:ds) =
- case decl of
- HsDocCommentNext _ str ->
- case d of
- Nothing -> collect d (docAppend doc_so_far str) ds
- Just d0 -> finishedDoc d0 doc_so_far (collect Nothing str ds)
-
- HsDocCommentPrev _ str -> collect d (docAppend doc_so_far str) ds
-
- _other ->
- let decl' = collectInDecl decl in
- case d of
- Nothing -> collect (Just decl') doc_so_far ds
- Just d0 -> finishedDoc d0 doc_so_far
- (collect (Just decl') DocEmpty ds)
-
-finishedDoc :: HsDecl -> GenDoc [HsQName] -> [HsDecl] -> [HsDecl]
-finishedDoc d DocEmpty rest = d : rest
-finishedDoc d doc rest = d' : rest
- where d' =
- case d of
- HsTypeDecl loc n ns ty _ ->
- HsTypeDecl loc n ns ty (Just doc)
- HsDataDecl loc ctxt n ns cons drv _ ->
- HsDataDecl loc ctxt n ns cons drv (Just doc)
- HsNewTypeDecl loc ctxt n ns con drv _ ->
- HsNewTypeDecl loc ctxt n ns con drv (Just doc)
- HsClassDecl loc ctxt n tvs fds meths _ ->
- HsClassDecl loc ctxt n tvs fds meths (Just doc)
- HsTypeSig loc ns ty _ ->
- HsTypeSig loc ns ty (Just doc)
- HsForeignImport loc cc sf str n ty _ ->
- HsForeignImport loc cc sf str n ty (Just doc)
- _other -> d
-
-collectInDecl :: HsDecl -> HsDecl
-collectInDecl (HsClassDecl loc ctxt n tvs fds meths doc)
- = HsClassDecl loc ctxt n tvs fds (collect Nothing DocEmpty meths) doc
-collectInDecl decl
- = decl
--}
-- -----------------------------------------------------------------------------
-- Named documentation
--- TODO: work out this stuff
-
findNamedDoc :: String -> [GHC.DocEntity GHC.Name] -> ErrMsgM (Maybe (GHC.HsDoc GHC.Name))
findNamedDoc name entities = search entities
where search [] = do
@@ -1657,244 +1224,71 @@ parseOption "ignore-exports" = return (Just OptIgnoreExports)
parseOption "not-home" = return (Just OptNotHome)
parseOption other = do tell ["Unrecognised option: " ++ other]; return Nothing
--- -----------------------------------------------------------------------------
--- Topologically sort the modules
+-- simplified type for sorting types, ignoring qualification (not visible
+-- in Haddock output) and unifying special tycons with normal ones.
+data SimpleType = SimpleType GHC.Name [SimpleType] deriving (Eq,Ord)
-sortModules :: [(HsModule,FilePath)] -> IO [(HsModule,FilePath)]
-sortModules mdls = mapM for_each_scc sccs
+attachInstances :: [HaddockModule] -> [HaddockModule]
+attachInstances modules = map attach modules
where
- sccs = stronglyConnComp edges
-
- edges :: [((HsModule,FilePath), Module, [Module])]
- edges = [ ((hsmod,file), mdl, get_imps impdecls)
- | (hsmod@(HsModule _ mdl _ impdecls _ _ _ _), file) <- mdls
- ]
-
- get_imps impdecls = [ imp | HsImportDecl _ imp _ _ _ <- impdecls ]
-
- get_mods hsmodules = [ mdl | HsModule _ mdl _ _ _ _ _ _ <- hsmodules ]
+ instMap = fmap (sortImage instHead) $ collectInstances modules
+ attach mod = mod { hmod_export_items = newItems }
+ where
+ newItems = map attachExport (hmod_export_items mod)
- for_each_scc (AcyclicSCC hsmodule) = return hsmodule
- for_each_scc (CyclicSCC hsmodules) =
- dieMsg ("modules are recursive: " ++
- unwords (map show (get_mods (map fst hsmodules))))
+ attachExport (ExportDecl2 n decl doc _) =
+ ExportDecl2 n decl doc (case Map.lookup n instMap of
+ Nothing -> []
+ Just instheads -> instheads)
+ attachExport otherExport = otherExport
--- -----------------------------------------------------------------------------
--- Collect instances and attach them to declarations
-
-attachInstances :: [Interface] -> [Interface]
-attachInstances mod_ifaces
- = map attach mod_ifaces
- where
- inst_map = fmap (sortImage instHead) $ collectInstances mod_ifaces
+collectInstances
+ :: [HaddockModule]
+ -> Map GHC.Name [InstHead2] -- maps class/type names to instances
- attach iface = iface{ iface_orig_exports = new_exports }
- where
- new_exports = map attach_export (iface_orig_exports iface)
-
- attach_export (ExportDecl nm decl _) =
- ExportDecl nm decl (case Map.lookup nm inst_map of
- Nothing -> []
- Just instheads -> instheads)
- attach_export other_export =
- other_export
-
-collectInstances
- :: [Interface]
- -> Map HsQName [InstHead] -- maps class/type names to instances
-
-collectInstances ifaces
- = Map.fromListWith (flip (++)) ty_inst_pairs `Map.union`
- Map.fromListWith (flip (++)) class_inst_pairs
+collectInstances modules
+ = Map.fromListWith (flip (++)) tyInstPairs `Map.union`
+ Map.fromListWith (flip (++)) classInstPairs
where
- all_instances = concat (map iface_insts ifaces)
-
- class_inst_pairs = [ (cls, [(ctxt,(cls,args))])
- | HsInstDecl _ ctxt (cls,args) _ <- all_instances ]
-
- ty_inst_pairs = [ (nm, [(ctxt,(cls,args))])
- | HsInstDecl _ ctxt (cls,args) _ <- all_instances,
- nm <- nub (concat (map freeTyCons args))
- ]
-
--- simplified type for sorting types, ignoring qualification (not visible
--- in Haddock output) and unifying special tycons with normal ones.
-data SimpleType = SimpleType HsName [SimpleType] deriving (Eq,Ord)
-
--- Sort key for instances:
--- arities of arguments, to place higher-kind instances
--- name of class
--- type arguments
-instHead :: (HsContext,(HsQName,[HsType])) -> ([Int],HsName,[SimpleType])
-instHead (ctxt,(cls,args))
- = (map argCount args, nameOfQName cls, map simplify args)
+ 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 :: InstHead2 -> ([Int], GHC.Name, [SimpleType])
+instHead (_, _, cls, args)
+ = (map argCount args, className cls, map simplify args)
where
- argCount (HsTyApp t _) = argCount t + 1
+ 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 (HsForAllType tvs ctxt t) = simplify t
- simplify (HsTyFun t1 t2) =
- SimpleType fun_tycon_name [simplify t1, simplify t2]
- simplify (HsTyTuple b ts) =
- SimpleType (tuple_tycon_name (length ts - 1)) (map simplify ts)
- simplify (HsTyApp t1 t2) = SimpleType s (args ++ [simplify t2])
- where (SimpleType s args) = simplify t1
- simplify (HsTyVar v) = SimpleType v []
- simplify (HsTyCon n) = SimpleType (nameOfQName n) []
- simplify (HsTyDoc t _) = simplify t
- simplify (HsTyIP n t) = simplify t
+ 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
--- -----------------------------------------------------------------------------
--- The interface file format.
--- This has to read interfaces up to Haddock 0.6 (without the short
--- document annotations), and interfaces afterwards, so we use the
--- FormatVersion hack to work out which one the interface file contains.
-
-thisFormatVersion :: FormatVersion
-thisFormatVersion = mkFormatVersion 2
-
--- | How we store interfaces. Not everything is stored.
-type StoredInterface2 =
- (Module,Maybe Doc,Maybe String,Bool,[(HsName,Module)], [(HsName,[HsName])])
-
--- | How we store interfaces. Not everything is stored.
-type StoredInterface1 =
- (Module,Maybe Doc,Maybe String,Bool,[(HsName,HsQName)],[(HsName,HsQName)],
- [(HsName,[HsName])])
-
--- | How we used to store interfaces.
-type NullVersionStoredInterface =
- (Module,Maybe String,Bool,[(HsName,HsQName)],[(HsName,HsQName)],
- [(HsName,[HsName])])
-
-dumpInterfaces :: [Interface] -> Map HsQName HsQName -> FilePath -> IO ()
-dumpInterfaces interfaces global_doc_env fileName =
- do
- let
- preparedInterfaces :: [StoredInterface2]
- preparedInterfaces = map from_interface interfaces
-
- bh <- openBinMem 100000
- put_ bh thisFormatVersion
- put_ bh preparedInterfaces
- putDocEnv bh global_doc_env
- writeBinMem bh fileName
-
-
-readIface :: FilePath -> IO ([Interface], Map HsQName HsQName)
-readIface fileName = do
- bh <- readBinMem fileName
- formatVersion <- get bh
- case formatVersion of
- v | v == thisFormatVersion -> do
- (stuff :: [StoredInterface2]) <- get bh
- doc_env <- getDocEnv bh
- return (map to_interface2 stuff, doc_env)
- v | v == mkFormatVersion 1 -> do
- (stuff :: [StoredInterface1]) <- get bh
- return (map to_interface1 stuff, Map.empty)
- v | v == nullFormatVersion -> do
- (stuff :: [NullVersionStoredInterface]) <- get bh
- return (map nullVersion_to_interface stuff, Map.empty)
- otherwise -> do
- noDieMsg (
- "Warning: The interface file " ++ show fileName
- ++ " could not be read.\n"
- ++ "Maybe it's from a later version of Haddock?\n")
- return ([], Map.empty)
-
-from_interface :: Interface -> StoredInterface2
-from_interface iface =
- ( iface_module iface,
- toDescription iface,iface_package iface,
- OptHide `elem` iface_options iface,
- [(n,mdl) | (n,Qual mdl n') <- Map.toAscList (iface_env iface),
- if n /= n' then error "help!" else True],
- Map.toAscList (iface_sub iface)
- )
-
-getDocEnv :: BinHandle -> IO (Map HsQName HsQName)
-getDocEnv bh = do
- doc_env_list <- get bh
- return (Map.fromList [(Qual mdl1 nm,Qual mdl2 nm) |
- (mdl1,nm,mdl2) <- doc_env_list])
-
-putDocEnv :: BinHandle -> Map HsQName HsQName -> IO ()
-putDocEnv bh env = do
- let doc_env_list =
- [(mdl1,nm,mdl2) | (Qual mdl1 nm, Qual mdl2 _) <- Map.toAscList env]
- put_ bh doc_env_list
-
-
-to_interface1 :: StoredInterface1 -> Interface
-to_interface1 (mdl,descriptionOpt,package, hide, env, _, sub) =
- Interface {
- iface_module = mdl,
- iface_filename = "",
- iface_orig_filename= "",
- iface_package = package,
- iface_env = Map.fromList env,
- iface_sub = Map.fromList sub,
- iface_reexported = [],
- iface_exports = [],
- iface_orig_exports = [],
- iface_insts = [],
- iface_decls = Map.empty,
- iface_info = toModuleInfo descriptionOpt,
- iface_doc = Nothing,
- iface_options = if hide then [OptHide] else []
- }
-
-to_interface2 :: StoredInterface2 -> Interface
-to_interface2 (mdl,descriptionOpt,package, hide, env, sub) =
- Interface {
- iface_module = mdl,
- iface_filename = "",
- iface_orig_filename= "",
- iface_package = package,
- iface_env =
- Map.fromList [(n,Qual mdl n) | (n,mdl) <- env],
- iface_sub = Map.fromList sub,
- iface_reexported = [],
- iface_exports = [],
- iface_orig_exports = [],
- iface_insts = [],
- iface_decls = Map.empty,
- iface_info = toModuleInfo descriptionOpt,
- iface_doc = Nothing,
- iface_options = if hide then [OptHide] else []
- }
-
-nullVersion_to_interface :: NullVersionStoredInterface -> Interface
-nullVersion_to_interface (mdl, package, hide, env, reexported, sub) =
- Interface {
- iface_module = mdl,
- iface_filename = "",
- iface_orig_filename= "",
- iface_package = package,
- iface_env = Map.fromList env,
- iface_sub = Map.fromList sub,
- iface_reexported = [],
- iface_exports = [],
- iface_orig_exports = [],
- iface_insts = [],
- iface_decls = Map.empty,
- iface_info = emptyModuleInfo,
- iface_doc = Nothing,
- iface_options = if hide then [OptHide] else []
- }
-
-toModuleInfo :: Maybe Doc -> ModuleInfo
-toModuleInfo descriptionOpt =
- emptyModuleInfo {description = descriptionOpt}
+funTyConName = mkWiredInName gHC_PRIM
+ (mkOccNameFS tcName FSLIT("(->)"))
+ funTyConKey
+ Nothing -- No parent object
+ (ATyCon funTyCon) -- Relevant TyCon
+ BuiltInSyntax
-
-
-- -----------------------------------------------------------------------------
-- A monad which collects error messages
--
cgit v1.2.3