Merge with changes to ghc HEAD

3 files changed, 27 insertions, 42 deletions

diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index 0dd7a189..d43b8270 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -41,7 +41,7 @@ import RdrName hiding ( Qual )
 import SrcLoc   
 import FastString            ( unpackFS )
 import BasicTypes            ( IPName(..), Boxity(..) )
-import Kind
+import Type                  ( Kind )
 import Outputable            ( ppr, defaultUserStyle, showSDoc )
 
 -- the base, module and entity URLs for the source code and wiki links.
@@ -721,7 +721,8 @@ ppFor summary links loc mbDoc (ForeignImport lname ltype _)
   = ppSig summary links loc mbDoc (TypeSig lname ltype)
 ppFor _ _ _ _ _ = error "ppFor"
 
-ppTySyn summary links loc mbDoc (TySynonym lname ltyvars ltype) 
+-- we skip type patterns for now
+ppTySyn summary links loc mbDoc (TySynonym lname ltyvars _ ltype) 
   = declWithDoc summary links loc n mbDoc (
     hsep ([keyword "type", ppBinder summary n]
     ++ ppTyVars ltyvars) <+> equals <+> ppLType ltype)
@@ -757,10 +758,9 @@ pp_hs_context cxt = parenList (map ppPred cxt)
 ppLPred = ppPred . unLoc
 
 ppPred (HsClassP n ts) = ppDocName n <+> hsep (map ppLType ts)
-ppPred (HsIParam (Dupable n) t) 
+-- TODO: find out what happened to the Dupable/Linear distinction
+ppPred (HsIParam (IPName n) t) 
   = toHtml "?" +++ ppDocName n <+> dcolon <+> ppLType t
-ppPred (HsIParam (Linear  n) t) 
-  = toHtml "%" +++ ppDocName n <+> dcolon <+> ppLType t
 
 -- -----------------------------------------------------------------------------
 -- Class declarations
@@ -783,8 +783,9 @@ ppFds fds =
 	fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> toHtml "->" <+>
 			       hsep (map ppDocName vars2)
 
+-- we skip ATs for now
 ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> DocMap -> HtmlTable
-ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ _) loc docMap = 
+ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ _ _) loc docMap = 
   if null sigs
     then (if summary then declBox else topDeclBox links loc nm) hdr
     else (if summary then declBox else topDeclBox links loc nm) (hdr <+> keyword "where")
@@ -798,11 +799,12 @@ ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ _) loc docM
     hdr = ppClassHdr summary lctxt nm tvs fds
     NoLink nm = unLoc lname
 
+-- we skip ATs for now
 ppClassDecl :: Ord key => Bool -> LinksInfo -> [InstHead DocName] -> key -> SrcSpan ->
                           Maybe (HsDoc DocName) -> DocMap -> TyClDecl DocName -> 
                           HtmlTable
 ppClassDecl summary links instances orig_c loc mbDoc docMap
-	decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ _)
+	decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ _ _)
   | summary = ppShortClassDecl summary links decl loc docMap
   | otherwise
     = classheader </>
@@ -1075,20 +1077,7 @@ ppDataHeader summary newOrData name tyvars =
 -- ----------------------------------------------------------------------------
 -- Types and contexts
 
-ppVar = ppOccName . kindVarOcc
-
-ppParendKind k@(FunKind _ _) = parens (ppKind k)
-ppParendKind k               = ppKind k
-
-ppKind kind = case kind of
-  LiftedTypeKind   -> char '*'
-  OpenTypeKind     -> char '?'
-  UnboxedTypeKind  -> char '#'
-  UnliftedTypeKind -> char '!'
-  UbxTupleKind     -> toHtml "(#)"
-  ArgTypeKind      -> toHtml "??"
-  FunKind k1 k2    -> hsep [ppParendKind k1, arrow <+> ppKind k2] 
-  KindVar v        -> ppVar v 
+ppKind k = toHtml $ showSDoc (ppr k)
 
 {-
 ppForAll Implicit _ lctxt = ppCtxtPart lctxt
diff --git a/src/HaddockRename.hs b/src/HaddockRename.hs
index a5e2daa5..f5c5f99c 100644
--- a/src/HaddockRename.hs
+++ b/src/HaddockRename.hs
@@ -132,14 +132,10 @@ renamePred (HsClassP name types) = do
   name' <- rename name 
   types' <- mapM renameLType types
   return (HsClassP name' types')
-renamePred (HsIParam (Dupable name) t) = do
+renamePred (HsIParam (IPName name) t) = do
   name' <- rename name
   t' <- renameLType t
-  return (HsIParam (Dupable name') t')
-renamePred (HsIParam (Linear name) t) = do
-  name' <- rename name
-  t' <- renameLType t
-  return (HsIParam (Linear name') t')
+  return (HsIParam (IPName name') t')
 
 renameLType (L loc t) = return . L loc =<< renameType t
 
@@ -226,25 +222,28 @@ renameTyClD d = case d of
  --   name' <- renameL name
  --   return (ForeignType name' a b)
 
-  TyData x lcontext lname ltyvars k cons _ -> do
+  TyData x lcontext lname ltyvars _ k cons _ -> do
     lcontext' <- renameLContext lcontext
     ltyvars' <- mapM renameLTyVarBndr ltyvars
     cons' <- mapM renameLCon cons
-    -- we don't need the derivings
-    return (TyData x lcontext' (keepL lname) ltyvars' k cons' Nothing) 
+    -- I don't think we need the derivings, so we return Nothing
+    -- We skip the type patterns too. TODO: find out what they are :-)
+    return (TyData x lcontext' (keepL lname) ltyvars' Nothing k cons' Nothing) 
  
-  TySynonym lname ltyvars ltype -> do
+  TySynonym lname ltyvars typat ltype -> do
     ltyvars' <- mapM renameLTyVarBndr ltyvars
     ltype' <- renameLType ltype
-    return (TySynonym (keepL lname) ltyvars' ltype')
+    -- We skip type patterns here as well.
+    return (TySynonym (keepL lname) ltyvars' Nothing ltype')
 
-  ClassDecl lcontext lname ltyvars lfundeps lsigs _ _ -> do
+  ClassDecl lcontext lname ltyvars lfundeps lsigs _ _ _ -> do
     lcontext' <- renameLContext lcontext
     ltyvars' <- mapM renameLTyVarBndr ltyvars
     lfundeps' <- mapM renameLFunDep lfundeps 
     lsigs' <- mapM renameLSig lsigs
     -- we don't need the default methods or the already collected doc entities
-    return (ClassDecl lcontext' (keepL lname) ltyvars' lfundeps' lsigs' emptyBag [])
+    -- we skip the ATs for now.
+    return (ClassDecl lcontext' (keepL lname) ltyvars' lfundeps' lsigs' emptyBag [] [])
  
   where
     renameLCon (L loc con) = return . L loc =<< renameCon con
diff --git a/src/Main.hs b/src/Main.hs
index acf9893a..1b3cc0fa 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -35,8 +35,7 @@ import Data.Map              (Map)
 
 import Distribution.InstalledPackageInfo ( InstalledPackageInfo(..) ) 
 
-import qualified GHC         ( init )
-import GHC hiding ( init ) 
+import GHC
 import Outputable
 import SrcLoc
 import Digraph               ( flattenSCC )
@@ -55,7 +54,6 @@ import FastString
 import DynFlags hiding ( Option )
 import Packages hiding ( package ) 
 import StaticFlags           ( parseStaticFlags )
-import Unique                ( mkUnique )
 
 -----------------------------------------------------------------------------
 -- Top-level stuff
@@ -183,11 +181,10 @@ extractGHCFlags flags = [ flag | Flag_GHCFlag flag <- flags ]
 
 startGHC :: String -> IO (Session, DynFlags)
 startGHC libDir = do
-  GHC.init (Just libDir)
   let ghcMode = BatchCompile
-  session <- newSession ghcMode
+  session <- newSession ghcMode (Just libDir)
   flags   <- getSessionDynFlags session
-  flags'  <- initPackages flags
+  flags'  <- liftM fst (initPackages flags)
   let flags'' = dopt_set flags' Opt_Haddock 
   return (session, flags'')
 
@@ -1213,8 +1210,8 @@ packageDocEnv mods infos = concatMap moduleDocEnv (zip mods infos)
 getPackages :: Session -> DynFlags -> IO [PackageData]
 getPackages session dynflags = do
 
-  -- get InstalledPackageInfo's for every package in the session
-  pkgInfos <- getExplicitPackagesAnd dynflags []
+  -- get InstalledPackageInfos for every package in the session
+  pkgInfos <- getPreloadPackagesAnd dynflags []
 
   -- return a list of those packages that we could create PackageData's for 
   let pkgInfos' = filter notRTS pkgInfos