More porting work -- doesn't compile

1 files changed, 136 insertions, 63 deletions

diff --git a/src/Main.hs b/src/Main.hs
index dfc5ee99..0fcd66fc 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -53,6 +53,8 @@ import Control.Concurrent
 import qualified GHC as GHC
 import Outputable
 import SrcLoc
+import qualified Digraph as Digraph
+import Name
 
 -----------------------------------------------------------------------------
 -- Top-level stuff
@@ -282,26 +284,57 @@ run flags files = do
   (ghcFlags'', rest) <- GHC.parseDynamicFlags ghcFlags' haddockGhcFlags 
   when (not (null rest)) (die $ "The following flags are not GHC flags: " ++ pprList rest ++ "\n")
 
-  GHC.defaultErrorHandler ghcFlags'' $ do 
+  sorted_checked_modules <- GHC.defaultErrorHandler ghcFlags'' $ do 
     GHC.setSessionDynFlags session ghcFlags''
     targets <- mapM (\s -> GHC.guessTarget s Nothing) files
     GHC.setTargets session targets
   
-    -- find out the module names of the targets, and topologically sort those modules
     maybe_module_graph <- GHC.depanal session [] True
     module_graph <- case maybe_module_graph of 
       Just module_graph -> return module_graph 
       Nothing -> die "Failed to load modules"
-    let sorted_modules = flattenSCC (topSortModuleGraph False module_graph Nothing) 
+    let sorted_modules = concatMap Digraph.flattenSCC (GHC.topSortModuleGraph False module_graph Nothing) 
     let modules = [ GHC.ms_mod modsum | modsum <- sorted_modules, GHC.ms_hspp_file modsum `elem` files ]
     mb_checked_modules <- mapM (GHC.checkModule session) modules
     let checked_modules = catMaybes mb_checked_modules
+    if length checked_modules /= length mb_checked_modules
+      then die "Failed to load all modules" 
+      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
+        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)     
+          
+           
+
+  --let Just (group, imports, exports) = GHC.renamedSource (head sorted_checked_modules)
+  --printSDoc (ppr group) defaultUserStyle
    
+  let exports = GHC.modInfoExports $ fromJust $ GHC.checkedModuleInfo $ snd $ (head sorted_checked_modules)
+  printSDoc (ppr exports) defaultUserStyle
+
+
+                            
+
 {-    let parsed_source = unLoc $ GHC.parsedSource (head checked_modules)
-    printSDoc (ppr parsed_source) defaultUserStyle
+     printSDoc (ppr parsed_source) defaultUserStyle
 -}
 
-    return ()
+  return ()
    -- case successFlag of 
     --  GHC.Succeeded -> bye "Succeeded"
     --  GHC.Failed -> bye "Could not load all targets"
@@ -380,8 +413,37 @@ run flags files = do
     pprList [x] = show x
     pprList (x:xs) = show x ++ ", " ++ pprList xs
 
---moduleFromFilename filename =  
-
+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 
+  [ (name, decl) | name <- exported_names, 
+    let Just decl = getDeclFromGroup name group ]  
+
+getDeclFromGroup :: GHC.HsGroup GHC.Name -> GHC.Name -> Maybe (GHC.HsDecl GHC.Name)
+getDeclFromGroup group name = case catMaybes [getDeclFromVals  (GHC.hs_valds  group), 
+                                              getDeclFromTyCls (GHC.hs_tyclds group),
+                                              getDeclFromFors  (GHC.hs_fords  group)] of
+  [Just decl] -> Just decl
+  _ -> Nothing
+  where 
+    getDeclFromVals (GHC.ValBindsOut _ lsigs) = case matching of 
+      [lsig] -> Just (GHC.SigD (unLoc lsig))
+      _      -> Nothing
+     where 
+        matching = [ lsig | lsig <- lsigs, GHC.sigName lsig == name ]
+    getDeclFromVals _ = error "getDeclFromVals: illegal input"
+     
+    getDeclFromTyCls ltycls = case matching of 
+      [ltycl] -> Just (GHC.TyClD (unLoc ltycl))
+      _       -> Nothing
+      where
+        matching = [ ltycl | ltycl <- ltycls, unLoc (GHC.tcdLName (unLoc ltycl)) == name ]
+    
+    getDeclFromFors lfors = case matching of 
+      [for] -> Just (GHC.ForD for)
+      _      -> Nothing
+      where
+        matching = [ for | L _ for@(GHC.ForeignExport n _ _ _) <- lfors, (unLoc n) == name ]
+ 
 parseIfaceOption :: String -> (FilePath,FilePath)
 parseIfaceOption s = 
   case break (==',') s of
@@ -792,14 +854,14 @@ unknownConstraint = UnQual (HsTyClsName (HsIdent "???"))
 mkExportItems
         :: ModuleMap2
 	-> GHC.Module			-- this module
-	-> GHC.NameSet			-- exported names (orig)
+	-> [GHC.Name]			-- exported names (orig)
 	-> 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
 	-> [DocOption]
-	-> Maybe [GHC.IE Name]
+	-> Maybe [GHC.IE GHC.Name]
 	-> Bool				-- --ignore-all-exports flag
-	-> ErrMsgM [ExportItem]
+	-> ErrMsgM [ExportItem2]
 
 mkExportItems mod_map this_mod exported_names decl_map sub_map decls
               opts maybe_exps ignore_all_exports
@@ -817,35 +879,30 @@ mkExportItems mod_map this_mod exported_names decl_map sub_map decls
     lookupExport (GHC.IEThingAll t)        = declWith t
     lookupExport (GHC.IEThingWith t cs)    = declWith t
     lookupExport (GHC.IEModuleContents m)  = fullContentsOf m
-    lookupExport (GHC.IEGroup lev doc)     = return [ ExportGroup lev "" doc ]
-    lookupExport (GHC.IEDoc doc)           = return [ ExportDoc doc ]
+    lookupExport (GHC.IEGroup lev doc)     = return [ ExportGroup2 lev "" doc ]
+    lookupExport (GHC.IEDoc doc)           = return [ ExportDoc2 doc ]
     lookupExport (GHC.IEDocNamed str)
 	= do r <- findNamedDoc str decls
 	     case r of
 		Nothing -> return []
-		Just found -> return [ ExportDoc found ]
+		Just found -> return [ ExportDoc2 found ]
 
     -- NOTE: I'm unsure about this. Currently only "External" names are considered.	
-    declWith :: GHC.Name -> ErrMsgM [ ExportItem ]
+    declWith :: GHC.Name -> ErrMsgM [ ExportItem2 ]
     declWith t | not (isExternalName t) = return []
     declWith t
 	| Just decl <- findDecl t
-	= return [ ExportDecl t (restrictTo subs (extractDecl x mdl decl)) [] ]
+	= return [ ExportDecl2 t (restrictTo subs (extractDecl t mdl decl)) [] ]
 	| otherwise
-	= return [ ExportNoDecl t t (map (Qual mdl) subs) ]
+	= return [ ExportNoDecl2 t t 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 
-              Just mdl = nameModule t
-              x = nameOccName
-	      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
+              mdl = nameModule t
+	      subs = filter (`elem` exported_names) all_subs
+              all_subs | mdl == this_mod = Map.findWithDefault [] t sub_map
 		       | otherwise       = all_subs_of_qname mod_map t
 
     fullContentsOf m
@@ -855,12 +912,12 @@ mkExportItems mod_map this_mod exported_names decl_map sub_map decls
 	     Just hmod
 		| OptHide `elem` hmod_options hmod
 			-> return (hmod_orig_exports hmod)
-		| otherwise -> return [ ExportModule m ]
+		| otherwise -> return [ ExportModule2 m ]
 	     Nothing -> return [] -- already emitted a warning in exportedNames
 
     findDecl :: GHC.Name -> Maybe (GHC.HsDecl GHC.Name)
     findDecl n | not (isExternalName n) = Nothing
-    findDecl n =
+    findDecl n 
 	| m == this_mod = Map.lookup n decl_map
 	| otherwise = 
 	   case Map.lookup m mod_map of
@@ -869,14 +926,14 @@ mkExportItems mod_map this_mod exported_names decl_map sub_map decls
       where
         m = nameModule n
 
-fullContentsOfThisModule :: GHC.Module -> [GHC.HsDecl GHC.Name] -> [ExportItem]
+fullContentsOfThisModule :: GHC.Module -> [GHC.HsDecl GHC.Name] -> [ExportItem2]
 fullContentsOfThisModule mdl decls = 
   map mkExportItem (filter keepDecl decls)
-  where mkExportItem (DocD (DocGroup lev doc)) = ExportGroup lev "" doc
-	mkExportItem decl = ExportDecl x decl [] -- NOTE: will this work? is x qualified correctly?
-	     where Just x = GHC.getDeclMainBinder decl
+  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 -> Bool
+keepDecl :: GHC.HsDecl GHC.Name -> Bool
 keepDecl (GHC.SigD _)                       = True
 keepDecl (GHC.TyClD _)                      = True
 keepDecl (GHC.DocD _)                       = True
@@ -891,8 +948,8 @@ keepDecl _                              = False
 
 mkExportItems
 	:: ModuleMap
-	-> Module			-- this module
-	-> [HsQName]			-- exported names (orig)
+	-> 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
@@ -992,58 +1049,61 @@ keepDecl _ = False
 -- 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 noSrcLoc everywhere in the cobbled together type signatures since
+-- We put noSrcSpan everywhere in the cobbled together type signatures since
 -- they aren't actually located in the soure code.
  
 extractDecl :: GHC.Name -> GHC.Module -> GHC.HsDecl GHC.Name -> GHC.HsDecl GHC.Name
 extractDecl name mdl decl
-  | Just n <- getDeclMainBinder decl, n == name = 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 
           [s0] -> let (n, tyvar_names) = name_and_tyvars d
-                  in SigD (extractClassDecl n mdl tyvar_names s0)
+                  in GHC.SigD (extractClassDecl n mdl tyvar_names s0)
           _ -> error "internal: extractDecl" 
       GHC.TyClD d | GHC.isDataDecl d -> 
         let (n, tyvar_names) = name_and_tyvars d
-        in SigD (extractRecSel name mdl n tyvar_names (GHC.tcdCons d))
+        in GHC.SigD (extractRecSel name mdl n tyvar_names (GHC.tcdCons d))
       _ -> error "internal: extractDecl"
   where
-    name_and_tyvars d = (GHC.unLoc (GHC.tcdLName d), hsLTyVarLocNames (GHC.tcdTyVars d))
+    name_and_tyvars d = (unLoc (GHC.tcdLName d), GHC.hsLTyVarLocNames (GHC.tcdTyVars d))
 
-toTypeNoLoc :: Located GHC.Name -> LHsType GHC.Name
+toTypeNoLoc :: Located GHC.Name -> GHC.LHsType GHC.Name
 toTypeNoLoc lname = mkNoLoc (GHC.HsTyVar (unLoc lname))
 
 mkNoLoc :: a -> Located a
-mkNoLoc a = Located noSrcLoc a
+mkNoLoc a = L noSrcSpan a
+
+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 -> [GHC.Located GHC.Name] -> GHC.LSig GHC.Name -> GHC.Sig GHC.Name
-extractClassDecl c mdl tvs0 (GHC.Located p (GHC.TypeSig lname ltype)) = case ltype of
-  GHC.Located _ (GHC.HsForAllTy exp tvs (GHC.Located p'' preds) ty) -> 
-    GHC.TypeSig lname (mkNoLoc (GHC.HsForAllTy exp tvs lctxt ty))
-  _ -> GHC.TypeSig lname (mkNoLoc (GHC.HsForAllTy exp [] lctxt ltype))
-    where
-      lctxt = mkNoLoc ctxt
-      ctxt = [mkNoLoc (GHC.HsClassP c (map toTypeNoLoc tvs0))] ++ preds  
+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
+  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)) 
+  where
+    lctxt preds = mkNoLoc (ctxt preds)
+    ctxt preds = [mkNoLoc (GHC.HsClassP c (map toTypeNoLoc tvs0))] ++ preds  
 
 extractClassDecl _ _ _ d = error $ "Main.extractClassDecl: unexpected decl"
 
-extractRecSel :: GHC.Located GHC.Name -> GHC.Module -> GHC.Name -> [GHC.Located GHC.Name] -> [GHC.LConDecl GHC.Name]
-              -> GHC.Sig Ghc.Name
+extractRecSel :: GHC.Name -> GHC.Module -> GHC.Name -> [Located GHC.Name] -> [GHC.LConDecl GHC.Name]
+              -> GHC.Sig GHC.Name
 extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
 
 -- originally expected unqualified 3:rd name, now it doesn't
-extractRecSel nm mdl t tvs (Located _ con : rest) =
+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 nm (mkNoLoc (GHC.HsFunTy data_ty (GHC.getBangType ty)))
+      GHC.TypeSig (mkNoLoc nm) (mkNoLoc (GHC.HsFunTy data_ty (GHC.getBangType ty)))
     _ -> extractRecSel nm mdl t tvs rest
  where 
-  matching_fields flds = [ f | HsRecField n _ _ <- flds, n == nm ]   
-  data_ty = mkNoLoc (foldl HsAppTy (mkNoLoc (HsTyVar t)) (map toTypeNoLoc tvs))
+  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
@@ -1115,7 +1175,7 @@ mkSubNames decls =
 
 -- -----------------------------------------------------------------------------
 -- Gather a list of original names exported from this module
-
+{-
 exportedNames :: Module -> ModuleMap -> [HsName]
 	-> Map HsQName HsQName
 	-> Map HsName [HsName]
@@ -1190,11 +1250,11 @@ exportedNames mdl mod_map local_names orig_env sub_map maybe_exps opts
 	case Map.lookup m mod_map of
 	  Nothing -> False
 	  Just iface -> isJust (Map.lookup n (iface_decls iface))
-
+-}
 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).
@@ -1205,13 +1265,26 @@ all_subs_of_qname mod_map (Qual mdl nm) =
 	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
+-- class).
+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)
+      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
@@ -1241,8 +1314,8 @@ buildOrigEnv this_mdl verbose mod_map imp_decls
         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
@@ -1280,7 +1353,7 @@ processImportDecl mod_map (HsImportDecl _ mdl is_qualified maybe_as imp_specs)
 	  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"
@@ -1390,12 +1463,12 @@ collectInDecl decl
 -- -----------------------------------------------------------------------------
 -- Named documentation
 
-findNamedDoc :: String -> [HsDecl] -> ErrMsgM (Maybe Doc)
+findNamedDoc :: String -> [GHC.HsDecl GHC.Name] -> ErrMsgM (Maybe (GHC.HsDoc GHC.Name))
 findNamedDoc name decls = search decls
 	where search [] = do
 		tell ["Cannot find documentation for: $" ++ name]
 		return Nothing
-	      search ((DocD (DocCommentNamed name' doc)):rest) 
+	      search ((GHC.DocD (GHC.DocCommentNamed name' doc)):rest) 
 			| name == name' = return (Just doc)
 		   	| otherwise = search rest
 	      search (_other_decl : rest) = search rest