aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authordavve <davve@dtek.chalmers.se>2006-07-11 23:07:44 +0000
committerdavve <davve@dtek.chalmers.se>2006-07-11 23:07:44 +0000
commitbbf12d02cb9fc17624bab24ba9c3ab0bfb2804d5 (patch)
tree1743ddfb70ad720c07cb42120a8008518a594292 /src
parentbad316def54a6429346f12b3a0fa2bfb33c822c8 (diff)
More progress on the porting -- first pass starting to shape up
Diffstat (limited to 'src')
-rw-r--r--src/HaddockTypes.hs8
-rw-r--r--src/Main.hs160
2 files changed, 135 insertions, 33 deletions
diff --git a/src/HaddockTypes.hs b/src/HaddockTypes.hs
index 0c0a27f8..172ef82a 100644
--- a/src/HaddockTypes.hs
+++ b/src/HaddockTypes.hs
@@ -137,8 +137,8 @@ type ModuleMap = Map Module Interface
type ModuleMap2 = Map GHC.Module HaddockModule
data HaddockModule = HM {
- hmod_options :: [DocOption],
- hmod_decls :: Map GHC.Name (GHC.HsDecl GHC.Name),
- hmod_orig_exports :: [ExportItem2],
- hmod_subs :: Map GHC.Name [GHC.Name]
+ hmod_options :: [DocOption],
+ hmod_exported_decl_map :: Map GHC.Name (GHC.HsDecl GHC.Name),
+ hmod_orig_exports :: [ExportItem2],
+ hmod_sub_map :: Map GHC.Name [GHC.Name]
}
diff --git a/src/Main.hs b/src/Main.hs
index bb5ed18c..8d0b6d1c 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -55,6 +55,7 @@ import Outputable
import SrcLoc
import qualified Digraph as Digraph
import Name
+import Module (moduleString)-- TODO: add an export to GHC API?
-----------------------------------------------------------------------------
-- Top-level stuff
@@ -300,34 +301,15 @@ run flags files = do
if length checked_modules /= length mb_checked_modules
then die "Failed to load all modules\n"
else return (zip modules checked_modules)
-
- let module_map = Map.empty
-
-{- let loop ((mod, checkedMod):modules) module_map = do
- exported_names <- get_exported_names
- binding_group <- get_binding_group
- let exported_decls_map = mk_exported_decls_map exported_names binding_group
- let exported_decls = Map.elems exported_decls_map
-
- mkExportItems module_map mod exported_names exported_decls_map
- where
- get_binding_group = case GHC.renamedSource checkedMod of
- Just (group, _, _) -> group
- Nothing -> die "Failed to get renamed source"
- get_module_info = case GHC.checkedModuleInfo checkedMod of
- Just mi -> return mi
- Nothing -> die "Failed to get checkedModuleInfo"
- get_exported_names = do
- module_info <- get_module_info
- return (GHC.modInfoExports module_info)
--}
+
+ 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
- let exported_decls_map = mk_exported_decls_map exported_names group
- let exported_decls = Map.elems exported_decls_map
+ let exported_decl_map = mk_exported_decl_map exported_names group
+ let exported_decls = Map.elems exported_decl_map
putStrLn "Printing all exported names:"
putStrLn "----------------------------"
@@ -342,13 +324,24 @@ run flags files = do
putStrLn "---------------------------------"
printSDoc (ppr exported_decls) defaultUserStyle
- let not_found = exported_names \\ (Map.keys exported_decls_map)
+ let not_found = exported_names \\ (Map.keys exported_decl_map)
putStrLn "Printing all names not found:"
putStrLn "---------------------------------"
printSDoc (ppr not_found) defaultUserStyle
+ let sub_names = mk_sub_map_from_group group
+ putStrLn "Printing the submap:"
+ putStrLn "---------------------------------"
+ printSDoc (ppr (Map.toList sub_names)) defaultUserStyle
+-}
+
+ let (export_item_map, messages) = runWriter (pass1 sorted_checked_modules' flags)
+ putStrLn "pass 1 messages:"
+ print messages
+ putStrLn "pass 1 export items:"
+ printSDoc (ppr (map (hmod_orig_exports . snd) (Map.toList export_item_map))) defaultUserStyle
--let Just (group, imports, exports) = GHC.renamedSource (head sorted_checked_modules)
--printSDoc (ppr group) defaultUserStyle
@@ -441,9 +434,115 @@ run flags files = do
pprList [] = []
pprList [x] = show x
pprList (x:xs) = show x ++ ", " ++ pprList xs
+
+ remove_maybes modules | length modules' == length modules = return modules'
+ | otherwise = die "Missing checked module phase information\n"
+ where modules' = [ (mod, (a,b,c,d)) | (mod, GHC.CheckedModule a (Just b) (Just c) (Just d)) <- modules ]
+
+instance Outputable ExportItem2 where
+ ppr (ExportDecl2 n decl instns) = text "ExportDecl" <+> ppr n <+> ppr decl <+> 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
-mk_exported_decls_map :: [GHC.Name] -> GHC.HsGroup GHC.Name -> Map GHC.Name (GHC.HsDecl GHC.Name)
-mk_exported_decls_map exported_names group = Map.fromList $
+{- let loop ((mod, checkedMod):modules) module_map = do
+ exported_names <- get_exported_names
+ binding_group <- get_binding_group
+ let exported_decls_map = mk_exported_decls_map exported_names binding_group
+ let exported_decls = Map.elems exported_decls_map
+
+ mkExportItems module_map mod exported_names exported_decls_map
+ where
+ get_binding_group = case GHC.renamedSource checkedMod of
+ Just (group, _, _) -> group
+ Nothing -> die "Failed to get renamed source"
+ get_module_info = case GHC.checkedModuleInfo checkedMod of
+ Just mi -> return mi
+ Nothing -> die "Failed to get checkedModuleInfo"
+ get_exported_names = do
+ module_info <- get_module_info
+ return (GHC.modInfoExports module_info)
+-}
+
+type FullyCheckedModule = (GHC.ParsedSource,
+ GHC.RenamedSource,
+ GHC.TypecheckedSource,
+ GHC.ModuleInfo)
+
+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
+
+ let (parsed_source, renamed_source, _, module_info) = checked_mod
+ (mb_doc_opts, haddock_mod_info, mb_mod_doc) = get_module_stuff parsed_source
+
+ opts <- mk_doc_opts 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
+ sub_map = mk_sub_map_from_group group
+ decls = recover_decls_from_group group
+ 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
+
+ let haddock_module = HM {
+ hmod_options = opts,
+ hmod_exported_decl_map = exported_decl_map,
+ hmod_orig_exports = export_items,
+ hmod_sub_map = sub_map
+ }
+
+ let module_map' = Map.insert mod haddock_module module_map
+ worker rest_modules module_map' flags
+
+ where
+ get_module_stuff source =
+ let GHC.HsModule _ _ _ _ _ mb_opts info mb_doc = unLoc source
+ in (mb_opts, info, mb_doc)
+
+ mk_doc_opts mb_opts = do
+ opts <- case mb_opts of
+ Just opts -> processOptions opts
+ Nothing -> return []
+ let opts' = if Flag_HideModule (moduleString mod) `elem` flags
+ then OptHide : opts
+ else opts
+ return opts'
+
+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 ]
+
+mk_sub_map_from_group :: GHC.HsGroup GHC.Name -> Map GHC.Name [GHC.Name]
+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)
+ where
+ sigs_from_valds (GHC.ValBindsOut _ lsigs) = lsigs
+ sigs_from_valds _ = error "recover_decls_from_group: illegal input"
+
+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 ] ]
getDeclFromGroup :: GHC.HsGroup GHC.Name -> GHC.Name -> Maybe (GHC.HsDecl GHC.Name)
@@ -952,7 +1051,7 @@ mkExportItems mod_map this_mod exported_names decl_map sub_map decls
| m == this_mod = Map.lookup n decl_map
| otherwise =
case Map.lookup m mod_map of
- Just hmod -> Map.lookup n (hmod_decls hmod)
+ Just hmod -> Map.lookup n (hmod_exported_decl_map hmod)
Nothing -> Nothing
where
m = nameModule n
@@ -1306,7 +1405,7 @@ all_subs_of_qname :: ModuleMap2 -> GHC.Name -> [GHC.Name]
all_subs_of_qname mod_map name
| isExternalName name =
case Map.lookup (nameModule name) mod_map of
- Just hmod -> Map.findWithDefault [] name (hmod_subs hmod)
+ Just hmod -> Map.findWithDefault [] name (hmod_sub_map hmod)
Nothing -> []
| otherwise = error $ "Main.all_subs_of_qname: unexpected unqual'd name"
@@ -1507,6 +1606,9 @@ findNamedDoc name decls = search decls
-- -----------------------------------------------------------------------------
-- Haddock options embedded in the source file
+processOptions_ str = let (opts, msg) = runWriter (processOptions str)
+ in print msg >> return opts
+
processOptions :: String -> ErrMsgM [DocOption]
processOptions str = do
case break (== ',') str of