aboutsummaryrefslogtreecommitdiff
path: root/src/Main.hs
diff options
context:
space:
mode:
authordavve <davve@dtek.chalmers.se>2006-07-23 18:22:43 +0000
committerdavve <davve@dtek.chalmers.se>2006-07-23 18:22:43 +0000
commit75a917a29115da1fcc70aec243c36597ad2a63c8 (patch)
tree825836368d1a03d4ee3c4d2b314e8a16684dfb0a /src/Main.hs
parentde580ba29f412239c2f922e9bd67eea2ccdd8bc7 (diff)
More work on pass1 -- mostly done
Diffstat (limited to 'src/Main.hs')
-rw-r--r--src/Main.hs196
1 files changed, 126 insertions, 70 deletions
diff --git a/src/Main.hs b/src/Main.hs
index ad0c3313..666bb6e6 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -38,7 +38,7 @@ import Foreign.C
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe
-
+import Data.List ( nubBy )
#if __GLASGOW_HASKELL__ >= 603
import System.Process
@@ -305,7 +305,7 @@ run flags files = do
sorted_checked_modules' <- remove_maybes sorted_checked_modules
-{- let Just (group,_,_) = GHC.renamedSource (snd (head sorted_checked_modules))
+{- let Just (group,_,_,_) = GHC.renamedSource (snd (head sorted_checked_modules))
let Just mi = GHC.checkedModuleInfo (snd (head sorted_checked_modules))
let exported_names = GHC.modInfoExports mi
@@ -334,8 +334,8 @@ run flags files = do
let sub_names = mk_sub_map_from_group group
putStrLn "Printing the submap:"
putStrLn "---------------------------------"
- printSDoc (ppr (Map.toList sub_names)) defaultUserStyle
--}
+ printSDoc (ppr (Map.toList sub_names)) defaultUserStyle -}
+
let (export_item_map, messages) = runWriter (pass1 sorted_checked_modules' flags)
@@ -443,12 +443,18 @@ run flags files = do
print_ x = printSDoc (ppr x) defaultUserStyle
instance Outputable ExportItem2 where
- ppr (ExportDecl2 n decl instns) = text "ExportDecl" <+> ppr n <+> ppr decl <+> text (show instns)
+ ppr (ExportDecl2 n decl doc instns) = text "ExportDecl" <+> ppr n <+> ppr decl <+> ppr doc <+> text (show 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 (GHC.DocEntity GHC.Name) where
+ ppr (GHC.DocEntity d) = ppr d
+ ppr (GHC.DeclEntity name) = ppr name
+
+
{- let loop ((mod, checkedMod):modules) module_map = do
exported_names <- get_exported_names
binding_group <- get_binding_group
@@ -480,27 +486,29 @@ pass1 modules flags = worker modules (Map.empty) flags
worker [] module_map _ = return module_map
worker ((mod, checked_mod):rest_modules) module_map flags = do
- let (parsed_source, renamed_source, _, module_info) = checked_mod
+ let (parsed_source, renamed_source, _, moduleInfo) = checked_mod
(mb_doc_opts, haddock_mod_info, mb_mod_doc) = get_module_stuff parsed_source
opts <- mk_doc_opts mb_doc_opts
- tell [show mb_doc_opts]
- let exported_names = GHC.modInfoExports module_info
- (group, _, mb_exports) = renamed_source
- exported_decl_map = mk_exported_decl_map exported_names group
+ let exportedNames = GHC.modInfoExports moduleInfo
+ (group, _, mb_exports, doc) = 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
- decls = recover_decls_from_group group
- exports = fmap (map unLoc) mb_exports
+ exports = fmap (map unLoc) mb_exports
ignore_all_exports = Flag_IgnoreAllExports `elem` flags
-
- export_items <- mkExportItems module_map mod exported_names
- exported_decl_map sub_map decls opts
- exports ignore_all_exports
+ docMap = mkDocMap group
+
+ export_items <- mkExportItems module_map mod exportedNames
+ exportedDeclMap localDeclMap sub_map entities opts
+ exports ignore_all_exports docMap
let haddock_module = HM {
hmod_options = opts,
- hmod_exported_decl_map = exported_decl_map,
+ hmod_exported_decl_map = exportedDeclMap,
hmod_orig_exports = export_items,
hmod_sub_map = sub_map
}
@@ -521,7 +529,47 @@ pass1 modules flags = worker modules (Map.empty) flags
then OptHide : opts
else opts
return opts'
-
+
+sameName (GHC.DocEntity _) _ = False
+sameName (GHC.DeclEntity _) (GHC.DocEntity _) = False
+sameName (GHC.DeclEntity a) (GHC.DeclEntity b) = a == b
+
+mkDocMap :: GHC.HsGroup GHC.Name -> Map GHC.Name (GHC.HsDoc GHC.Name)
+mkDocMap group = Map.fromList $
+ collectDocs (GHC.hs_docs group) ++ collectDocsFromClassMeths (getClasses group)
+ where
+ getClasses group = filter GHC.isClassDecl (map unLoc (GHC.hs_tyclds group))
+ collectDocsFromClassMeths classes = concatMap (collectDocs . GHC.tcdDocs) classes
+
+collectDocs :: [GHC.DocEntity GHC.Name] -> [(GHC.Name, GHC.HsDoc GHC.Name)]
+collectDocs entities = collect Nothing GHC.DocEmpty entities
+
+collect :: Maybe (GHC.DocEntity GHC.Name) -> GHC.HsDoc GHC.Name -> [GHC.DocEntity GHC.Name] -> [(GHC.Name, GHC.HsDoc GHC.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
+ GHC.DocEntity (GHC.DocCommentNext str) ->
+ case d of
+ Nothing -> collect d (GHC.docAppend doc_so_far str) es
+ Just d0 -> finishedDoc d0 doc_so_far (collect Nothing str es)
+
+ GHC.DocEntity (GHC.DocCommentPrev str) -> collect d (GHC.docAppend doc_so_far str) es
+
+ _other ->
+ case d of
+ Nothing -> collect (Just e) doc_so_far es
+ Just d0 -> finishedDoc d0 doc_so_far
+ (collect (Just e) GHC.DocEmpty es)
+
+finishedDoc :: GHC.DocEntity GHC.Name -> GHC.HsDoc GHC.Name -> [(GHC.Name, GHC.HsDoc GHC.Name)] -> [(GHC.Name, GHC.HsDoc GHC.Name)]
+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 =
concat [ tail (map unLoc (GHC.tyClDeclNames tycld)) | L _ tycld <- GHC.hs_tyclds group ]
@@ -531,23 +579,31 @@ mk_sub_map_from_group group =
Map.fromList [ (name, subs) | L _ tycld <- GHC.hs_tyclds group,
let name:subs = map unLoc (GHC.tyClDeclNames tycld) ]
-
recover_decls_from_group :: GHC.HsGroup GHC.Name -> [GHC.HsDecl GHC.Name]
recover_decls_from_group group =
- map (GHC.SigD . unLoc) (sigs_from_valds (GHC.hs_valds group)) ++
- map (GHC.TyClD . unLoc) (GHC.hs_tyclds group) ++
- map (GHC.InstD . unLoc) (GHC.hs_instds group) ++
- map (GHC.DefD . unLoc) (GHC.hs_defds group) ++
- map (GHC.ForD . unLoc) (GHC.hs_fords group) ++
- map (GHC.DeprecD . unLoc) (GHC.hs_depds group) ++
- map (GHC.RuleD . unLoc) (GHC.hs_ruleds group)
+ map (withDoc GHC.SigD . unLoc) (sigs_from_valds (GHC.hs_valds group)) ++
+ map (withDoc GHC.TyClD . unLoc) (GHC.hs_tyclds group) ++
+ map (withoutDoc GHC.InstD . unLoc) (GHC.hs_instds group) ++
+ map (withoutDoc GHC.DefD . unLoc) (GHC.hs_defds group) ++
+ map (withDoc GHC.ForD . unLoc) (GHC.hs_fords group) ++
+ map (withoutDoc GHC.DeprecD . unLoc) (GHC.hs_depds group) ++
+ map (withoutDoc GHC.RuleD . unLoc) (GHC.hs_ruleds group)
where
sigs_from_valds (GHC.ValBindsOut _ lsigs) = lsigs
sigs_from_valds _ = error "recover_decls_from_group: illegal input"
+ withDoc c d = c d Nothing
+-- withDoc c d = case GHC.getMainDeclBinder (c d Nothing) of
+-- Just name -> c d (find_doc name group)
+-- Nothing -> c d Nothing
+ withoutDoc c d = c d
+
+mkDeclMap :: [GHC.Name] -> GHC.HsGroup GHC.Name -> Map GHC.Name (GHC.HsDecl GHC.Name)
+mkDeclMap names group = Map.fromList [ (n,d) | (n,Just d) <- maybeDecls ]
+ where
+ maybeDecls = [ (name, getDeclFromGroup group name) | name <- names ]
-mk_exported_decl_map :: [GHC.Name] -> GHC.HsGroup GHC.Name -> Map GHC.Name (GHC.HsDecl GHC.Name)
-mk_exported_decl_map exported_names group = Map.fromList $
- [ (n,d) | (n,Just d) <- [ (name, getDeclFromGroup group name) | name <- exported_names ] ]
+getEntityNames :: [GHC.DocEntity GHC.Name] -> [GHC.Name]
+getEntityNames entities = [ name | GHC.DeclEntity name <- entities ]
getDeclFromGroup :: GHC.HsGroup GHC.Name -> GHC.Name -> Maybe (GHC.HsDecl GHC.Name)
getDeclFromGroup group name = case catMaybes [getDeclFromVals (GHC.hs_valds group),
@@ -557,21 +613,21 @@ 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))
+ [lsig] -> Just (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))
+ [ltycl] -> Just (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)
+ [for] -> Just (GHC.ForD for Nothing)
_ -> Nothing
where
matching = [ for | L _ for <- lfors, forName for == name ]
@@ -584,7 +640,6 @@ parseIfaceOption s =
(fpath,',':file) -> (fpath,file)
(file, _) -> ("", file)
-
updateHTMLXRefs :: [FilePath] -> [[Interface]] -> IO ()
updateHTMLXRefs paths ifaces_s =
writeIORef html_xrefs_ref (Map.fromList mapping)
@@ -989,16 +1044,18 @@ mkExportItems
:: ModuleMap2
-> GHC.Module -- this module
-> [GHC.Name] -- exported names (orig)
- -> Map GHC.Name (GHC.HsDecl GHC.Name) -- maps local names to declarations
+ -> 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.Name] -- sub-map for this module
- -> [GHC.HsDecl GHC.Name] -- decls in the current 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]
-mkExportItems mod_map this_mod exported_names decl_map sub_map decls
- opts maybe_exps ignore_all_exports
+mkExportItems mod_map 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
@@ -1006,7 +1063,7 @@ mkExportItems mod_map this_mod exported_names decl_map sub_map decls
return (concat exps)
where
everything_local_exported = -- everything exported
- return (fullContentsOfThisModule this_mod decls)
+ return (fullContentsOfThisModule this_mod entities localDeclMap docMap)
lookupExport (GHC.IEVar x) = declWith x
lookupExport (GHC.IEThingAbs t) = declWith t
@@ -1014,19 +1071,20 @@ mkExportItems mod_map this_mod exported_names decl_map sub_map decls
lookupExport (GHC.IEThingWith t cs) = declWith t
lookupExport (GHC.IEModuleContents m) = fullContentsOf m
lookupExport (GHC.IEGroup lev doc) = return [ ExportGroup2 lev "" doc ]
- lookupExport (GHC.IEDoc doc) = return [ ExportDoc2 doc ]
+ lookupExport (GHC.IEDoc doc) = return [ ExportDoc2 doc ]
lookupExport (GHC.IEDocNamed str)
- = do r <- findNamedDoc str decls
+ = do r <- findNamedDoc str entities
case r of
Nothing -> return []
Just found -> return [ ExportDoc2 found ]
-
+
-- NOTE: I'm unsure about this. Currently only "External" names are considered.
declWith :: GHC.Name -> ErrMsgM [ ExportItem2 ]
declWith t | not (isExternalName t) = return []
declWith t
| Just decl <- findDecl t
- = return [ ExportDecl2 t (restrictTo subs (extractDecl t mdl decl)) [] ]
+ = let maybeDoc = Map.lookup t docMap in
+ return [ ExportDecl2 t (restrictTo subs (extractDecl t mdl decl)) maybeDoc [] ]
| otherwise
= return [ ExportNoDecl2 t t subs ]
-- can't find the decl (it might be from another package), but let's
@@ -1039,8 +1097,8 @@ mkExportItems mod_map this_mod exported_names decl_map sub_map decls
all_subs | mdl == this_mod = Map.findWithDefault [] t sub_map
| otherwise = all_subs_of_qname mod_map t
- fullContentsOf m
- | m == this_mod = return (fullContentsOfThisModule this_mod decls)
+ fullContentsOf m
+ | m == this_mod = return (fullContentsOfThisModule this_mod entities localDeclMap docMap)
| otherwise =
case Map.lookup m mod_map of
Just hmod
@@ -1052,7 +1110,7 @@ mkExportItems mod_map this_mod exported_names decl_map sub_map decls
findDecl :: GHC.Name -> Maybe (GHC.HsDecl GHC.Name)
findDecl n | not (isExternalName n) = Nothing
findDecl n
- | m == this_mod = Map.lookup n decl_map
+ | m == this_mod = Map.lookup n exportedDeclMap
| otherwise =
case Map.lookup m mod_map of
Just hmod -> Map.lookup n (hmod_exported_decl_map hmod)
@@ -1060,19 +1118,14 @@ mkExportItems mod_map this_mod exported_names decl_map sub_map decls
where
m = nameModule n
-fullContentsOfThisModule :: GHC.Module -> [GHC.HsDecl GHC.Name] -> [ExportItem2]
-fullContentsOfThisModule mdl decls =
- map mkExportItem (filter keepDecl decls)
- where mkExportItem (GHC.DocD (GHC.DocGroup lev doc)) = ExportGroup2 lev "" doc
- mkExportItem decl = ExportDecl2 x decl [] -- NOTE: will this work? is x qualified correctly?
- where Just x = GHC.getMainDeclBinder decl
-
-keepDecl :: GHC.HsDecl GHC.Name -> Bool
-keepDecl (GHC.SigD _) = True
-keepDecl (GHC.TyClD _) = True
-keepDecl (GHC.DocD _) = True
-keepDecl (GHC.ForD (GHC.ForeignImport _ _ _ _)) = True
-keepDecl _ = False
+fullContentsOfThisModule :: GHC.Module -> [GHC.DocEntity GHC.Name] -> Map GHC.Name (GHC.HsDecl GHC.Name) ->
+ Map GHC.Name (GHC.HsDoc GHC.Name) -> [ExportItem2]
+fullContentsOfThisModule module_ entities declMap docMap = map mkExportItem entities
+ where
+ mkExportItem (GHC.DocEntity (GHC.DocGroup lev doc)) = ExportGroup2 lev "" doc
+ mkExportItem (GHC.DeclEntity name) = case Map.lookup name declMap of
+ Just decl -> let maybe_doc = Map.lookup name docMap in ExportDecl2 name decl maybe_doc []
+ Nothing -> error "fullContentsOfThisModule: This shouldn't happen"
{-
--< -----------------------------------------------------------------------------
@@ -1184,22 +1237,23 @@ keepDecl _ = False
-- 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 aren't actually located in the soure code.
+-- they're not actually located in the source code.
extractDecl :: GHC.Name -> GHC.Module -> GHC.HsDecl GHC.Name -> GHC.HsDecl GHC.Name
extractDecl name mdl decl
| Just n <- GHC.getMainDeclBinder decl, n == name = decl
| otherwise =
case decl of
- GHC.TyClD d | GHC.isClassDecl d ->
- let matching_sigs = [ sig | sig <- GHC.tcdSigs d, GHC.sigName sig == Just name ]
- in case matching_sigs 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)
+ in GHC.SigD (extractClassDecl n mdl tyvar_names s0) Nothing
_ -> error "internal: extractDecl"
- GHC.TyClD d | GHC.isDataDecl d ->
+ GHC.TyClD d _ | GHC.isDataDecl d ->
let (n, tyvar_names) = name_and_tyvars d
- in GHC.SigD (extractRecSel name mdl n tyvar_names (GHC.tcdCons d))
+ sig = extractRecSel name mdl n tyvar_names (GHC.tcdCons d)
+ in GHC.SigD sig Nothing
_ -> error "internal: extractDecl"
where
name_and_tyvars d = (unLoc (GHC.tcdLName d), GHC.hsLTyVarLocNames (GHC.tcdTyVars d))
@@ -1543,7 +1597,7 @@ expandDecl d = [ d ]
-----------------------------------------------------------------------------
-- Collecting documentation and attach it to the right declarations
-
+{-
collectDoc :: [HsDecl] -> [HsDecl]
collectDoc decls = collect Nothing DocEmpty decls
@@ -1593,16 +1647,18 @@ 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
-findNamedDoc :: String -> [GHC.HsDecl GHC.Name] -> ErrMsgM (Maybe (GHC.HsDoc GHC.Name))
-findNamedDoc name decls = search decls
+-- 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
tell ["Cannot find documentation for: $" ++ name]
return Nothing
- search ((GHC.DocD (GHC.DocCommentNamed name' doc)):rest)
+ search ((GHC.DocEntity (GHC.DocCommentNamed name' doc)):rest)
| name == name' = return (Just doc)
| otherwise = search rest
search (_other_decl : rest) = search rest