From 6fd172c2692723ab67fcc1a998feed320a8ab144 Mon Sep 17 00:00:00 2001 From: Max Bolingbroke Date: Mon, 22 Aug 2011 20:25:27 +0100 Subject: Adapt Haddock for the ConstraintKind extension changes --- src/Haddock/Interface/AttachInstances.hs | 2 -- src/Haddock/Interface/Create.hs | 2 +- src/Haddock/Interface/Rename.hs | 31 ++++++------------------------- 3 files changed, 7 insertions(+), 28 deletions(-) (limited to 'src/Haddock/Interface') diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs index e4da3233..01d5b0f4 100644 --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -116,7 +116,6 @@ getAllInfo name = withSession $ \hsc_env -> do data SimpleType = SimpleType Name [SimpleType] deriving (Eq,Ord) --- TODO: should we support PredTy here? instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType]) instHead (_, _, cls, args) = (map argCount args, className cls, map simplify args) @@ -134,7 +133,6 @@ instHead (_, _, cls, args) where (SimpleType s ts) = simplify t1 simplify (TyVarTy v) = SimpleType (tyVarName v) [] simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts) - simplify _ = error "simplify" -- sortImage f = sortBy (\x y -> compare (f x) (f y)) diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index f9d72bd0..860a0044 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -770,7 +770,7 @@ extractClassDecl c tvs0 (L pos (TypeSig lname ltype)) = case ltype of _ -> L pos (TypeSig lname (noLoc (mkImplicitHsForAllTy (lctxt []) ltype))) where lctxt = noLoc . ctxt - ctxt preds = noLoc (HsClassP c (map toTypeNoLoc tvs0)) : preds + ctxt preds = nlHsTyConApp c (map toTypeNoLoc tvs0) : preds extractClassDecl _ _ _ = error "extractClassDecl: unexpected decl" diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 2d5c899a..cc49cd53 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -17,8 +17,8 @@ import Haddock.GhcUtils import GHC hiding (NoLink) import Name -import BasicTypes import Bag (emptyBag) +import BasicTypes ( IPName(..), ipNameName ) import Data.List import qualified Data.Map as Map hiding ( Map ) @@ -208,25 +208,6 @@ renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName) renameFnArgsDoc = mapM renameDoc -renameLPred :: LHsPred Name -> RnM (LHsPred DocName) -renameLPred = mapM renamePred - - -renamePred :: HsPred Name -> RnM (HsPred DocName) -renamePred (HsClassP name types) = do - name' <- rename name - types' <- mapM renameLType types - return (HsClassP name' types') -renamePred (HsEqualP type1 type2) = do - type1' <- renameLType type1 - type2' <- renameLType type2 - return (HsEqualP type1' type2') -renamePred (HsIParam (IPName name) t) = do - name' <- rename name - t' <- renameLType t - return (HsIParam (IPName name') t') - - renameLType :: LHsType Name -> RnM (LHsType DocName) renameLType = mapM renameType @@ -254,6 +235,8 @@ renameType t = case t of HsListTy ty -> return . HsListTy =<< renameLType ty HsPArrTy ty -> return . HsPArrTy =<< renameLType ty + HsIParamTy n ty -> liftM2 HsIParamTy (liftM IPName (rename (ipNameName n))) (renameLType ty) + HsEqTy ty1 ty2 -> liftM2 HsEqTy (renameLType ty1) (renameLType ty2) HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts @@ -265,8 +248,6 @@ renameType t = case t of HsParTy ty -> return . HsParTy =<< renameLType ty - HsPredTy p -> return . HsPredTy =<< renamePred p - HsKindSig ty k -> do ty' <- renameLType ty return (HsKindSig ty' k) @@ -285,15 +266,15 @@ renameLTyVarBndr (L loc tv) = do return $ L loc (replaceTyVarName tv name') -renameLContext :: Located [LHsPred Name] -> RnM (Located [LHsPred DocName]) +renameLContext :: Located [LHsType Name] -> RnM (Located [LHsType DocName]) renameLContext (L loc context) = do - context' <- mapM renameLPred context + context' <- mapM renameLType context return (L loc context') renameInstHead :: InstHead Name -> RnM (InstHead DocName) renameInstHead (preds, className, types) = do - preds' <- mapM renamePred preds + preds' <- mapM renameType preds className' <- rename className types' <- mapM renameType types return (preds', className', types') -- cgit v1.2.3 From 0f21c474382af69bb7dac214d6c225218240e033 Mon Sep 17 00:00:00 2001 From: Max Bolingbroke Date: Tue, 6 Sep 2011 09:13:59 +0100 Subject: Ignore associated type defaults (just as we ignore default methods) --- src/Haddock/Backends/LaTeX.hs | 6 +++--- src/Haddock/Backends/Xhtml/Decl.hs | 4 ++-- src/Haddock/Convert.hs | 13 ++++++++++--- src/Haddock/Interface/Rename.hs | 5 +++-- 4 files changed, 18 insertions(+), 10 deletions(-) (limited to 'src/Haddock/Interface') diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs index 27f6bd5e..a6e1bcdc 100644 --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -473,7 +473,7 @@ ppClassDecl :: [DocInstance DocName] -> SrcSpan -> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName -> Bool -> LaTeX ppClassDecl instances loc mbDoc subdocs - (ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) unicode + (ClassDecl lctxt lname ltyvars lfds lsigs _ ats at_defs _) unicode = declWithDoc classheader (if null body then Nothing else Just (vcat body)) $$ instancesBit where @@ -486,8 +486,8 @@ ppClassDecl instances loc mbDoc subdocs body = catMaybes [fmap docToLaTeX mbDoc, body_] body_ - | null lsigs, null ats = Nothing - | null ats = Just methodTable + | null lsigs, null ats, null at_defs = Nothing + | null ats, null at_defs = Just methodTable --- | otherwise = atTable $$ methodTable | otherwise = error "LaTeX.ppClassDecl" diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index add926ab..16e32b7e 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -352,7 +352,7 @@ ppFds fds unicode qual = ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, DocForDecl DocName)] -> Bool -> Qualification -> Html -ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc +ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _ _) loc subdocs unicode qual = if null sigs && null ats then (if summary then id else topDeclElem links loc [nm]) hdr @@ -381,7 +381,7 @@ ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> SrcSpan -> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName -> Bool -> Qualification -> Html ppClassDecl summary links instances loc mbDoc subdocs - decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) unicode qual + decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _ _) unicode qual | summary = ppShortClassDecl summary links decl loc subdocs unicode qual | otherwise = classheader +++ maybeDocSection qual mbDoc +++ atBit +++ methodBit +++ instancesBit diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs index 34de6775..81435a6e 100644 --- a/src/Haddock/Convert.hs +++ b/src/Haddock/Convert.hs @@ -68,14 +68,21 @@ tyThingToLHsDecl t = noLoc $ case t of (map (noLoc . synifyIdSig DeleteTopLevelQuantification) (classMethods cl)) emptyBag --ignore default method definitions, they don't affect signature - (map synifyClassAT (classATs cl)) + ats + (concat at_defss) [] --we don't have any docs at this point + where (ats, at_defss) = unzip $ map synifyClassAT (classATItems cl) -- class associated-types are a subset of TyCon -- (mainly only type/data-families) -synifyClassAT :: TyCon -> LTyClDecl Name -synifyClassAT = noLoc . synifyTyCon +synifyClassAT :: ClassATItem -> (LTyClDecl Name, [LTyClDecl Name]) +synifyClassAT (tc, _mb_defs) = (noLoc (synifyTyCon tc), []) + -- ignore the mb_defs since we ignore default methods + +synifyATDefault :: TyCon -> LTyClDecl Name +synifyATDefault tc = noLoc (synifyAxiom ax) + where Just ax = tyConFamilyCoercion_maybe tc synifyAxiom :: CoAxiom -> TyClDecl Name synifyAxiom (CoAxiom { co_ax_tvs = tvs, co_ax_lhs = lhs, co_ax_rhs = rhs }) diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 2d5c899a..70520028 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -351,15 +351,16 @@ renameTyClD d = case d of typats' <- mapM (mapM renameLType) typats return (TySynonym lname' ltyvars' typats' ltype') - ClassDecl lcontext lname ltyvars lfundeps lsigs _ ats _ -> do + ClassDecl lcontext lname ltyvars lfundeps lsigs _ ats at_defs _ -> do lcontext' <- renameLContext lcontext lname' <- renameL lname ltyvars' <- mapM renameLTyVarBndr ltyvars lfundeps' <- mapM renameLFunDep lfundeps lsigs' <- mapM renameLSig lsigs ats' <- mapM renameLTyClD ats + at_defs' <- mapM renameLTyClD at_defs -- we don't need the default methods or the already collected doc entities - return (ClassDecl lcontext' lname' ltyvars' lfundeps' lsigs' emptyBag ats' []) + return (ClassDecl lcontext' lname' ltyvars' lfundeps' lsigs' emptyBag ats' at_defs' []) where renameLCon (L loc con) = return . L loc =<< renameCon con -- cgit v1.2.3 From 8b2ee333020aeb9e639cd1772e1dca3b4b4ef3d2 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Sat, 1 Oct 2011 01:34:06 +0100 Subject: Follow changes to ForeignImport/ForeignExport in GHC --- src/Haddock/Backends/Hoogle.hs | 4 ++-- src/Haddock/Backends/Xhtml/Decl.hs | 2 +- src/Haddock/GhcUtils.hs | 4 ++-- src/Haddock/Interface/Create.hs | 2 +- src/Haddock/Interface/ExtractFnArgDocs.hs | 2 +- src/Haddock/Interface/Rename.hs | 8 ++++---- 6 files changed, 11 insertions(+), 11 deletions(-) (limited to 'src/Haddock/Interface') diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index adf95636..45399963 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -114,8 +114,8 @@ ppExport (ExportDecl decl dc subdocs _) = doc (fst dc) ++ f (unL decl) f (TyClD d@TyData{}) = ppData d subdocs f (TyClD d@ClassDecl{}) = ppClass d f (TyClD d@TySynonym{}) = ppSynonym d - f (ForD (ForeignImport name typ _)) = ppSig $ TypeSig [name] typ - f (ForD (ForeignExport name typ _)) = ppSig $ TypeSig [name] typ + f (ForD (ForeignImport name typ _ _)) = ppSig $ TypeSig [name] typ + f (ForD (ForeignExport name typ _ _)) = ppSig $ TypeSig [name] typ f (SigD sig) = ppSig sig f _ = [] ppExport _ = [] diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index 28132046..c1f3a89a 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -114,7 +114,7 @@ tyvarNames = map (getName . hsTyVarName . unLoc) ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> Qualification -> Html -ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _) unicode qual +ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _ _) unicode qual = ppFunSig summary links loc doc [name] typ unicode qual ppFor _ _ _ _ _ _ _ = error "ppFor" diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs index f79acd94..33ae1b6d 100644 --- a/src/Haddock/GhcUtils.hs +++ b/src/Haddock/GhcUtils.hs @@ -96,8 +96,8 @@ getMainDeclBinder (ValD d) = #endif getMainDeclBinder (SigD d) = sigNameNoLoc d -getMainDeclBinder (ForD (ForeignImport name _ _)) = [unLoc name] -getMainDeclBinder (ForD (ForeignExport _ _ _)) = [] +getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name] +getMainDeclBinder (ForD (ForeignExport _ _ _ _)) = [] getMainDeclBinder _ = [] -- Useful when there is a signature with multiple names, e.g. diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 860a0044..057fceb7 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -263,7 +263,7 @@ declsFromClass class_ = docs ++ defs ++ sigs ++ ats declNames :: HsDecl a -> [a] declNames (TyClD d) = [tcdName d] -declNames (ForD (ForeignImport n _ _)) = [unLoc n] +declNames (ForD (ForeignImport n _ _ _)) = [unLoc n] -- we have normal sigs only (since they are taken from ValBindsOut) declNames (SigD sig) = sigNameNoLoc sig declNames _ = error "unexpected argument to declNames" diff --git a/src/Haddock/Interface/ExtractFnArgDocs.hs b/src/Haddock/Interface/ExtractFnArgDocs.hs index 8889c3ab..a9f8a807 100644 --- a/src/Haddock/Interface/ExtractFnArgDocs.hs +++ b/src/Haddock/Interface/ExtractFnArgDocs.hs @@ -24,7 +24,7 @@ import GHC getDeclFnArgDocs :: HsDecl Name -> Map Int HsDocString getDeclFnArgDocs (SigD (TypeSig _ ty)) = getTypeFnArgDocs ty -getDeclFnArgDocs (ForD (ForeignImport _ ty _)) = getTypeFnArgDocs ty +getDeclFnArgDocs (ForD (ForeignImport _ ty _ _)) = getTypeFnArgDocs ty getDeclFnArgDocs (TyClD (TySynonym {tcdSynRhs = ty})) = getTypeFnArgDocs ty getDeclFnArgDocs _ = Map.empty diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 4ea22a2e..546ba62b 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -392,14 +392,14 @@ renameSig sig = case sig of renameForD :: ForeignDecl Name -> RnM (ForeignDecl DocName) -renameForD (ForeignImport lname ltype x) = do +renameForD (ForeignImport lname ltype co x) = do lname' <- renameL lname ltype' <- renameLType ltype - return (ForeignImport lname' ltype' x) -renameForD (ForeignExport lname ltype x) = do + return (ForeignImport lname' ltype' co x) +renameForD (ForeignExport lname ltype co x) = do lname' <- renameL lname ltype' <- renameLType ltype - return (ForeignExport lname' ltype' x) + return (ForeignExport lname' ltype' co x) renameInstD :: InstDecl Name -> RnM (InstDecl DocName) -- cgit v1.2.3 From 45bcf701d8e99e86f28a966b31654c16a5ae6b42 Mon Sep 17 00:00:00 2001 From: David Terei Date: Thu, 18 Aug 2011 14:27:53 -0700 Subject: Add safe haskell indication to haddock output --- src/Haddock/Backends/Xhtml.hs | 3 ++- src/Haddock/Interface/LexParseRn.hs | 27 ++++++++++++++++----------- src/Haddock/Interface/ParseModuleHeader.hs | 3 ++- src/Haddock/Interface/Rn.hs | 5 +++-- src/Haddock/InterfaceFile.hs | 4 +++- src/Haddock/Types.hs | 2 ++ 6 files changed, 28 insertions(+), 16 deletions(-) (limited to 'src/Haddock/Interface') diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs index b639760d..08e2fe07 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -200,7 +200,8 @@ moduleInfo iface = entries = mapMaybe doOneEntry [ ("Portability",hmi_portability), ("Stability",hmi_stability), - ("Maintainer",hmi_maintainer) + ("Maintainer",hmi_maintainer), + ("Safe Haskell",hmi_safety) ] in case entries of diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs index a92c9c46..d013ca27 100644 --- a/src/Haddock/Interface/LexParseRn.hs +++ b/src/Haddock/Interface/LexParseRn.hs @@ -25,6 +25,7 @@ import Haddock.Doc import Data.Maybe import FastString import GHC +import Outputable ( showPpr ) import RdrName data HaddockCommentType = NormalHaddockComment | DocSectionComment @@ -59,14 +60,18 @@ lexParseRnMbHaddockComment dflags hty gre (Just d) = lexParseRnHaddockComment df -- yes, you always get a HaddockModInfo though it might be empty lexParseRnHaddockModHeader :: DynFlags -> GlobalRdrEnv -> GhcDocHdr -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name)) lexParseRnHaddockModHeader dflags gre mbStr = do - let failure = (emptyHaddockModInfo, Nothing) - case mbStr of - Nothing -> return failure - Just (L _ (HsDocString fs)) -> do - let str = unpackFS fs - case parseModuleHeader dflags str of - Left mess -> do - tell ["haddock module header parse failed: " ++ mess] - return failure - Right (info, doc) -> - return (rnHaddockModInfo gre info, Just (rnDoc gre doc)) + (hmod, docn) <- case mbStr of + Nothing -> return failure + Just (L _ (HsDocString fs)) -> do + let str = unpackFS fs + case parseModuleHeader dflags str of + Left mess -> do + tell ["haddock module header parse failed: " ++ mess] + return failure + Right (info, doc) -> + return (rnHaddockModInfo gre info, Just (rnDoc gre doc)) + return (hmod { hmi_safety = safety }, docn) + + where + safety = Just $ showPpr $ safeHaskell dflags + failure = (emptyHaddockModInfo, Nothing) diff --git a/src/Haddock/Interface/ParseModuleHeader.hs b/src/Haddock/Interface/ParseModuleHeader.hs index d0e3e5fb..35533d0d 100644 --- a/src/Haddock/Interface/ParseModuleHeader.hs +++ b/src/Haddock/Interface/ParseModuleHeader.hs @@ -59,7 +59,8 @@ parseModuleHeader dflags str0 = hmi_description = docOpt, hmi_portability = portabilityOpt, hmi_stability = stabilityOpt, - hmi_maintainer = maintainerOpt + hmi_maintainer = maintainerOpt, + hmi_safety = Nothing }, doc) -- | This function is how we read keys. diff --git a/src/Haddock/Interface/Rn.hs b/src/Haddock/Interface/Rn.hs index 6f7af908..d63524b6 100644 --- a/src/Haddock/Interface/Rn.hs +++ b/src/Haddock/Interface/Rn.hs @@ -9,8 +9,9 @@ import Name ( Name ) import Outputable ( ppr, showSDoc ) rnHaddockModInfo :: GlobalRdrEnv -> HaddockModInfo RdrName -> HaddockModInfo Name -rnHaddockModInfo gre (HaddockModInfo desc port stab maint) = - HaddockModInfo (fmap (rnDoc gre) desc) port stab maint +rnHaddockModInfo gre hmod = + let desc = hmi_description hmod + in hmod { hmi_description = fmap (rnDoc gre) desc } ids2string :: [RdrName] -> String ids2string [] = [] diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs index 57374b1d..8ff91e34 100644 --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -526,13 +526,15 @@ instance Binary name => Binary (HaddockModInfo name) where put_ bh (hmi_portability hmi) put_ bh (hmi_stability hmi) put_ bh (hmi_maintainer hmi) + put_ bh (hmi_safety hmi) get bh = do descr <- get bh porta <- get bh stabi <- get bh maint <- get bh - return (HaddockModInfo descr porta stabi maint) + safet <- get bh + return (HaddockModInfo descr porta stabi maint safet) instance Binary DocName where diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index fddafc1d..c9b29bd0 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -330,6 +330,7 @@ data HaddockModInfo name = HaddockModInfo , hmi_portability :: Maybe String , hmi_stability :: Maybe String , hmi_maintainer :: Maybe String + , hmi_safety :: Maybe String } @@ -339,6 +340,7 @@ emptyHaddockModInfo = HaddockModInfo , hmi_portability = Nothing , hmi_stability = Nothing , hmi_maintainer = Nothing + , hmi_safety = Nothing } -- cgit v1.2.3