diff options
| -rw-r--r-- | src/HaddockHtml.hs | 31 | ||||
| -rw-r--r-- | src/HaddockRename.hs | 25 | ||||
| -rw-r--r-- | src/Main.hs | 13 |
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 |