From b383b17cd1c4aebe73481dba0df13640e7bfc50a Mon Sep 17 00:00:00 2001 From: Justus Adam Date: Thu, 2 Mar 2017 15:33:34 +0100 Subject: Adding MDoc to exports of Documentation.Haddock --- haddock-api/src/Documentation/Haddock.hs | 1 + 1 file changed, 1 insertion(+) (limited to 'haddock-api') diff --git a/haddock-api/src/Documentation/Haddock.hs b/haddock-api/src/Documentation/Haddock.hs index 1ff5cf75..4203a564 100644 --- a/haddock-api/src/Documentation/Haddock.hs +++ b/haddock-api/src/Documentation/Haddock.hs @@ -34,6 +34,7 @@ module Documentation.Haddock ( -- * Documentation comments Doc, + MDoc, DocH(..), Example(..), Hyperlink(..), -- cgit v1.2.3 From ef99ed85007636a866fbdeed154d89612d68f824 Mon Sep 17 00:00:00 2001 From: Justus Adam Date: Thu, 9 Mar 2017 11:41:44 +0100 Subject: Also exposing toInstalledIface --- haddock-api/src/Documentation/Haddock.hs | 1 + 1 file changed, 1 insertion(+) (limited to 'haddock-api') diff --git a/haddock-api/src/Documentation/Haddock.hs b/haddock-api/src/Documentation/Haddock.hs index 4203a564..14605e92 100644 --- a/haddock-api/src/Documentation/Haddock.hs +++ b/haddock-api/src/Documentation/Haddock.hs @@ -16,6 +16,7 @@ module Documentation.Haddock ( -- * Interface Interface(..), InstalledInterface(..), + toInstalledIface, createInterfaces, processModules, -- cgit v1.2.3 From d2be5e88281d8e3148bc55830c27c75844b86f38 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Thu, 9 Mar 2017 22:13:43 -0500 Subject: Bump for GHC 8.2 --- haddock-api/src/Haddock/InterfaceFile.hs | 4 ++-- haddock.cabal | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) (limited to 'haddock-api') diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index 63419102..0d000029 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -82,8 +82,8 @@ binaryInterfaceMagic = 0xD0Cface -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] -- binaryInterfaceVersion :: Word16 -#if (__GLASGOW_HASKELL__ >= 801) && (__GLASGOW_HASKELL__ < 803) -binaryInterfaceVersion = 28 +#if (__GLASGOW_HASKELL__ >= 802) && (__GLASGOW_HASKELL__ < 804) +binaryInterfaceVersion = 29 binaryInterfaceVersionCompatibility :: [Word16] binaryInterfaceVersionCompatibility = [binaryInterfaceVersion] diff --git a/haddock.cabal b/haddock.cabal index 7103a459..10460526 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -55,8 +55,8 @@ executable haddock array, xhtml >= 3000.2 && < 3000.3, Cabal >= 1.10, - ghc-boot == 8.1, - ghc == 8.1, + ghc-boot, + ghc == 8.2.*, bytestring, transformers -- cgit v1.2.3 From 4f249c9b64d50d79e7ba703289cd67293a76821a Mon Sep 17 00:00:00 2001 From: Richard Eisenberg Date: Fri, 10 Mar 2017 11:31:33 -0500 Subject: Update Haddock w.r.t. new HsImplicitBndrs --- haddock-api/src/Haddock/Convert.hs | 5 +++-- haddock-api/src/Haddock/Interface/Rename.hs | 3 ++- 2 files changed, 5 insertions(+), 3 deletions(-) (limited to 'haddock-api') diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index b5966291..577b1a3c 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -114,7 +114,8 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) hs_rhs = synifyType WithinType rhs in TyFamEqn { tfe_tycon = name , tfe_pats = HsIB { hsib_body = typats - , hsib_vars = map tyVarName tkvs } + , hsib_vars = map tyVarName tkvs + , hsib_closed = True } , tfe_fixity = Prefix , tfe_rhs = hs_rhs } @@ -300,7 +301,7 @@ synifyDataCon use_gadt_syntax dc = (False,True) -> case linear_tys of [a,b] -> return $ InfixCon a b _ -> Left "synifyDataCon: infix with non-2 args?" - gadt_ty = HsIB [] (synifyType WithinType res_ty) + gadt_ty = HsIB [] (synifyType WithinType res_ty) False -- finally we get synifyDataCon's result! in hs_arg_tys >>= \hat -> diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index f88d9f4e..b43860fb 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -577,7 +577,8 @@ renameImplicit :: (in_thing -> RnM out_thing) renameImplicit rn_thing (HsIB { hsib_body = thing }) = do { thing' <- rn_thing thing ; return (HsIB { hsib_body = thing' - , hsib_vars = PlaceHolder }) } + , hsib_vars = PlaceHolder + , hsib_closed = PlaceHolder }) } renameWc :: (in_thing -> RnM out_thing) -> HsWildCardBndrs Name in_thing -- cgit v1.2.3 From f6f9bca1416f6cee48f2d4731a6c38db92e87300 Mon Sep 17 00:00:00 2001 From: Brian Huffman Date: Fri, 17 Mar 2017 14:57:39 -0700 Subject: Print any user-supplied kind signatures on type parameters. This applies to type parameters on data, newtype, type, and class declarations, and also to forall-bound type vars in type signatures. --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 37 ++++++++++---------------- 1 file changed, 14 insertions(+), 23 deletions(-) (limited to 'haddock-api') diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 2aec5272..ffe42c4f 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -171,8 +171,8 @@ ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge -- | Pretty-print type variables. -ppTyVars :: [LHsTyVarBndr DocName] -> [Html] -ppTyVars tvs = map (ppTyName . getName . hsLTyVarName) tvs +ppTyVars :: Unicode -> Qualification -> [LHsTyVarBndr DocName] -> [Html] +ppTyVars unicode qual tvs = map (ppHsTyVarBndr unicode qual . unLoc) tvs tyvarNames :: LHsQTyVars DocName -> [Name] tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit @@ -199,7 +199,7 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars splice unicode qual where hdr = hsep ([keyword "type", ppBinder summary occ] - ++ ppTyVars (hsQTvExplicit ltyvars)) + ++ ppTyVars unicode qual (hsQTvExplicit ltyvars)) full = hdr <+> equals <+> ppLType unicode qual ltype occ = nameOccName . getName $ name fixs @@ -353,20 +353,20 @@ ppAssocType summ links doc (L loc decl) fixities splice unicode qual = -- | Print a type family and its variables ppFamDeclBinderWithVars :: Bool -> Unicode -> Qualification -> FamilyDecl DocName -> Html ppFamDeclBinderWithVars summ unicode qual (FamilyDecl { fdLName = lname, fdTyVars = tvs }) = - ppAppDocNameTyVarBndrs summ unicode qual (unLoc lname) (map unLoc $ hsq_explicit tvs) + ppAppDocNameTyVarBndrs summ unicode qual (unLoc lname) (hsq_explicit tvs) -- | Print a newtype / data binder and its variables -ppDataBinderWithVars :: Bool -> TyClDecl DocName -> Html -ppDataBinderWithVars summ decl = - ppAppDocNameNames summ (tcdName decl) (tyvarNames $ tcdTyVars decl) +ppDataBinderWithVars :: Bool -> Unicode -> Qualification -> TyClDecl DocName -> Html +ppDataBinderWithVars summ unicode qual decl = + ppAppDocNameTyVarBndrs summ unicode qual (tcdName decl) (hsQTvExplicit $ tcdTyVars decl) -------------------------------------------------------------------------------- -- * Type applications -------------------------------------------------------------------------------- -ppAppDocNameTyVarBndrs :: Bool -> Unicode -> Qualification -> DocName -> [HsTyVarBndr DocName] -> Html +ppAppDocNameTyVarBndrs :: Bool -> Unicode -> Qualification -> DocName -> [LHsTyVarBndr DocName] -> Html ppAppDocNameTyVarBndrs summ unicode qual n vs = - ppTypeApp n [] vs ppDN (ppHsTyVarBndr unicode qual) + ppTypeApp n [] vs ppDN (ppHsTyVarBndr unicode qual . unLoc) where ppDN notation = ppBinderFixity notation summ . nameOccName . getName ppBinderFixity Infix = ppBinderInfix @@ -379,15 +379,6 @@ ppAppNameTypes n ks ts unicode qual = ppTypeApp n ks ts (\p -> ppDocName qual p True) (ppParendType unicode qual) --- | Print an application of a 'DocName' and a list of 'Names' -ppAppDocNameNames :: Bool -> DocName -> [Name] -> Html -ppAppDocNameNames summ n ns = - ppTypeApp n [] ns ppDN ppTyName - where - ppDN notation = ppBinderFixity notation summ . nameOccName . getName - ppBinderFixity Infix = ppBinderInfix - ppBinderFixity _ = ppBinder - -- | General printing of type applications ppTypeApp :: DocName -> [a] -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html ppTypeApp n [] (t1:t2:rest) ppDN ppT @@ -445,7 +436,7 @@ ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName ppClassHdr summ lctxt n tvs fds unicode qual = keyword "class" <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual else noHtml) - <+> ppAppDocNameNames summ n (tyvarNames tvs) + <+> ppAppDocNameTyVarBndrs summ unicode qual n (hsQTvExplicit tvs) <+> ppFds fds unicode qual @@ -890,7 +881,7 @@ ppDataHeader summary decl@(DataDecl { tcdDataDefn = -- context ppLContext ctxt unicode qual <+> -- T a b c ..., or a :+: b - ppDataBinderWithVars summary decl + ppDataBinderWithVars summary unicode qual decl <+> case ks of Nothing -> mempty Just (L _ x) -> dcolon unicode <+> ppKind unicode qual x @@ -967,8 +958,8 @@ ppLKind unicode qual y = ppKind unicode qual (unLoc y) ppKind :: Unicode -> Qualification -> HsKind DocName -> Html ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual -ppForAllPart :: [LHsTyVarBndr DocName] -> Unicode -> Html -ppForAllPart tvs unicode = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot +ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocName] -> Html +ppForAllPart unicode qual tvs = hsep (forallSymbol unicode : ppTyVars unicode qual tvs) +++ dot ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) @@ -977,7 +968,7 @@ ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> Html ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual = maybeParen ctxt_prec pREC_FUN $ - ppForAllPart tvs unicode <+> ppr_mono_lty pREC_TOP ty unicode qual + ppForAllPart unicode qual tvs <+> ppr_mono_lty pREC_TOP ty unicode qual ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual = maybeParen ctxt_prec pREC_FUN $ -- cgit v1.2.3 From ee3e3d03ce17238fb81a2ec83880167335d516e9 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Thu, 23 Mar 2017 09:27:28 -0400 Subject: haddock-api: Bump bound on GHC --- haddock-api/haddock-api.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'haddock-api') diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 620fd981..922aa07c 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -48,7 +48,7 @@ library , xhtml >= 3000.2 && < 3000.3 , Cabal >= 1.10 , ghc-boot - , ghc >= 8.0 && < 8.2 + , ghc == 8.2.* , ghc-paths , haddock-library == 1.4.* -- cgit v1.2.3 From 68e531baa35e698d947686b83525871eb33c3730 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 13 Mar 2017 02:53:36 -0700 Subject: Correctly handle Backpack identity/semantic modules. Signed-off-by: Edward Z. Yang (cherry picked from commit 26d6c150b31bc4580ab17cfd07b6e7f9afe10737) --- haddock-api/src/Haddock/Interface/Create.hs | 75 +++++++++++++++++++++-------- 1 file changed, 54 insertions(+), 21 deletions(-) (limited to 'haddock-api') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index c8e6b982..ff53fd3c 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -62,6 +62,7 @@ createInterface tm flags modMap instIfaceMap = do L _ hsm = parsedSource tm !safety = modInfoSafe mi mdl = ms_mod ms + sem_mdl = tcg_semantic_mod (fst (tm_internals_ tm)) dflags = ms_hspp_opts ms !instances = modInfoInstances mi !fam_instances = md_fam_insts md @@ -88,8 +89,9 @@ createInterface tm flags modMap instIfaceMap = do let declsWithDocs = topDecls group_ fixMap = mkFixMap group_ (decls, _) = unzip declsWithDocs - localInsts = filter (nameIsLocalOrFrom mdl) $ map getName instances - ++ map getName fam_instances + localInsts = filter (nameIsLocalOrFrom sem_mdl) + $ map getName instances + ++ map getName fam_instances -- Locations of all TH splices splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ] @@ -104,7 +106,7 @@ createInterface tm flags modMap instIfaceMap = do let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap)) - exportItems <- mkExportItems modMap mdl allWarnings gre exportedNames decls + exportItems <- mkExportItems modMap mdl sem_mdl allWarnings gre exportedNames decls maps fixMap splices exports instIfaceMap dflags let !visibleNames = mkVisibleNames maps exportItems opts @@ -156,6 +158,10 @@ createInterface tm flags modMap instIfaceMap = do , ifaceTokenizedSrc = tokenizedSrc } +-- | Given all of the @import M as N@ declarations in a package, +-- create a mapping from the module identity of M, to an alias N +-- (if there are multiple aliases, we pick the last one.) This +-- will go in 'ifaceModuleAliases'. mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName mkAliasMap dflags mRenamedSource = case mRenamedSource of @@ -166,13 +172,28 @@ mkAliasMap dflags mRenamedSource = SrcLoc.L _ alias <- ideclAs impDecl return $ (lookupModuleDyn dflags + -- TODO: This is supremely dodgy, because in general the + -- UnitId isn't going to look anything like the package + -- qualifier (even with old versions of GHC, the + -- IPID would be p-0.1, but a package qualifier never + -- has a version number it. (Is it possible that in + -- Haddock-land, the UnitIds never have version numbers? + -- I, ezyang, have not quite understand Haddock's package + -- identifier model.) + -- + -- Additionally, this is simulating some logic GHC already + -- has for deciding how to qualify names when it outputs + -- them to the user. We should reuse that information; + -- or at least reuse the renamed imports, which know what + -- they import! (fmap Module.fsToUnitId $ fmap sl_fs $ ideclPkgQual impDecl) (case ideclName impDecl of SrcLoc.L _ name -> name), alias)) impDecls --- similar to GHC.lookupModule +-- Similar to GHC.lookupModule +-- ezyang: Not really... lookupModuleDyn :: DynFlags -> Maybe UnitId -> ModuleName -> Module lookupModuleDyn _ (Just pkgId) mdlName = @@ -492,6 +513,7 @@ collectDocs = go Nothing [] mkExportItems :: IfaceMap -> Module -- this module + -> Module -- semantic module -> WarningMap -> GlobalRdrEnv -> [Name] -- exported names (orig) @@ -504,7 +526,7 @@ mkExportItems -> DynFlags -> ErrMsgGhc [ExportItem Name] mkExportItems - modMap thisMod warnings gre exportedNames decls + modMap thisMod semMod warnings gre exportedNames decls maps@(docMap, argMap, subMap, declMap, instMap) fixMap splices optExports instIfaceMap dflags = case optExports of Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls @@ -515,6 +537,7 @@ mkExportItems lookupExport (IEThingAll (L _ t)) = declWith $ ieWrappedName t lookupExport (IEThingWith (L _ t) _ _ _) = declWith $ ieWrappedName t lookupExport (IEModuleContents (L _ m)) = + -- Pass in identity module, so we can look it up in index correctly moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices lookupExport (IEGroup lev docStr) = return $ return . ExportGroup lev "" $ processDocString dflags gre docStr @@ -582,6 +605,8 @@ mkExportItems Just decl -> -- We try to get the subs and docs -- from the installed .haddock file for that package. + -- TODO: This needs to be more sophisticated to deal + -- with signature inheritance case M.lookup (nameModule t) instIfaceMap of Nothing -> do liftErrMsg $ tell @@ -597,8 +622,7 @@ mkExportItems mkExportDecl :: Name -> LHsDecl Name -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name mkExportDecl name decl (doc, subs) = decl' where - decl' = ExportDecl (restrictTo sub_names (extractDecl name mdl decl)) doc subs' [] fixities False - mdl = nameModule name + decl' = ExportDecl (restrictTo sub_names (extractDecl name decl)) doc subs' [] fixities False subs' = filter (isExported . fst) subs sub_names = map fst subs' fixities = [ (n, f) | n <- name:sub_names, Just f <- [M.lookup n fixMap] ] @@ -609,14 +633,20 @@ mkExportItems findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)])) findDecl n - | m == thisMod, Just ds <- M.lookup n declMap = + | m == semMod, Just ds <- M.lookup n declMap = (ds, lookupDocs n warnings docMap argMap subMap) - | Just iface <- M.lookup m modMap, Just ds <- M.lookup n (ifaceDeclMap iface) = + | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap, Just ds <- M.lookup n (ifaceDeclMap iface) = (ds, lookupDocs n warnings (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface)) | otherwise = ([], (noDocForDecl, [])) where m = nameModule n +-- | Given a 'Module' from a 'Name', convert it into a 'Module' that +-- we can actually find in the 'IfaceMap'. +semToIdMod :: UnitId -> Module -> Module +semToIdMod this_uid m + | Module.isHoleModule m = mkModule this_uid (moduleName m) + | otherwise = m hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl Name)) hiDecl dflags t = do @@ -679,7 +709,7 @@ lookupDocs n warnings docMap argMap subMap = -- only return those that are. -- 3) B is visible and all its exports are in scope, in which case we return -- a single 'ExportModule' item. -moduleExports :: Module -- ^ Module A +moduleExports :: Module -- ^ Module A (identity, NOT semantic) -> ModuleName -- ^ The real name of B, the exported module -> DynFlags -- ^ The flags used when typechecking A -> WarningMap @@ -693,8 +723,11 @@ moduleExports :: Module -- ^ Module A -> [SrcSpan] -- ^ Locations of all TH splices -> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps fixMap splices - | m == thisMod = fullModuleContents dflags warnings gre maps fixMap splices decls + | expMod == moduleName thisMod + = fullModuleContents dflags warnings gre maps fixMap splices decls | otherwise = + -- NB: we constructed the identity module when looking up in + -- the IfaceMap. case M.lookup m ifaceMap of Just iface | OptHide `elem` ifaceOptions iface -> return (ifaceExportItems iface) @@ -710,7 +743,7 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa "documentation for exported module: " ++ pretty dflags expMod] return [] where - m = mkModule unitId expMod + m = mkModule unitId expMod -- Identity module! unitId = moduleUnitId thisMod @@ -789,8 +822,8 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap -- 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...). -extractDecl :: Name -> Module -> LHsDecl Name -> LHsDecl Name -extractDecl name mdl decl +extractDecl :: Name -> LHsDecl Name -> LHsDecl Name +extractDecl name decl | name `elem` getMainDeclBinder (unLoc decl) = decl | otherwise = case unLoc decl of @@ -812,11 +845,11 @@ extractDecl name mdl decl O.$$ O.nest 4 (O.ppr matches)) TyClD d@DataDecl {} -> let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d)) - in SigD <$> extractRecSel name mdl n tyvar_tys (dd_cons (tcdDataDefn d)) + in SigD <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d)) InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n , dfid_pats = HsIB { hsib_body = tys } , dfid_defn = defn }) -> - SigD <$> extractRecSel name mdl n tys (dd_cons defn) + SigD <$> extractRecSel name n tys (dd_cons defn) InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) -> let matches = [ d | L _ d <- insts -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d) @@ -826,19 +859,19 @@ extractDecl name mdl decl , selectorFieldOcc n == name ] in case matches of - [d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0) + [d0] -> extractDecl name (noLoc . InstD $ DataFamInstD d0) _ -> error "internal: extractDecl (ClsInstD)" _ -> error "internal: extractDecl" -extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name] +extractRecSel :: Name -> Name -> [LHsType Name] -> [LConDecl Name] -> LSig Name -extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found" +extractRecSel _ _ _ [] = error "extractRecSel: selector not found" -extractRecSel nm mdl t tvs (L _ con : rest) = +extractRecSel nm t tvs (L _ con : rest) = case getConDetails con of RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty))))) - _ -> extractRecSel nm mdl t tvs rest + _ -> extractRecSel nm t tvs rest where matching_fields :: [LConDeclField Name] -> [(SrcSpan, LConDeclField Name)] matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds -- cgit v1.2.3 From 26879d9b4a2aba264a10812f2738d4db685d61d1 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 13 Mar 2017 03:03:20 -0700 Subject: Add a field marking if interface is a signature or not. Signed-off-by: Edward Z. Yang (cherry picked from commit 930cfbe58e2e87f5a4d431d89a3c204934e6e858) --- haddock-api/src/Haddock/Interface/Create.hs | 1 + haddock-api/src/Haddock/InterfaceFile.hs | 6 ++++-- haddock-api/src/Haddock/Types.hs | 7 +++++++ 3 files changed, 12 insertions(+), 2 deletions(-) (limited to 'haddock-api') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index ff53fd3c..024cd02d 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -132,6 +132,7 @@ createInterface tm flags modMap instIfaceMap = do return $! Interface { ifaceMod = mdl + , ifaceIsSig = Module.isHoleModule sem_mdl , ifaceOrigFilename = msHsFilePath ms , ifaceInfo = info , ifaceDoc = Documentation mbDoc modWarn diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index 0d000029..78853a79 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -372,9 +372,10 @@ instance Binary InterfaceFile where instance Binary InstalledInterface where - put_ bh (InstalledInterface modu info docMap argMap + put_ bh (InstalledInterface modu is_sig info docMap argMap exps visExps opts subMap fixMap) = do put_ bh modu + put_ bh is_sig put_ bh info put_ bh docMap put_ bh argMap @@ -386,6 +387,7 @@ instance Binary InstalledInterface where get bh = do modu <- get bh + is_sig <- get bh info <- get bh docMap <- get bh argMap <- get bh @@ -395,7 +397,7 @@ instance Binary InstalledInterface where subMap <- get bh fixMap <- get bh - return (InstalledInterface modu info docMap argMap + return (InstalledInterface modu is_sig info docMap argMap exps visExps opts subMap fixMap) diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 8addfa2f..a6dd6354 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -80,6 +80,9 @@ data Interface = Interface -- | The module behind this interface. ifaceMod :: !Module + -- | Is this a signature? + , ifaceIsSig :: !Bool + -- | Original file name of the module. , ifaceOrigFilename :: !FilePath @@ -157,6 +160,9 @@ data InstalledInterface = InstalledInterface -- | The module represented by this interface. instMod :: Module + -- | Is this a signature? + , instIsSig :: Bool + -- | Textual information about the module. , instInfo :: HaddockModInfo Name @@ -186,6 +192,7 @@ data InstalledInterface = InstalledInterface toInstalledIface :: Interface -> InstalledInterface toInstalledIface interface = InstalledInterface { instMod = ifaceMod interface + , instIsSig = ifaceIsSig interface , instInfo = ifaceInfo interface , instDocMap = ifaceDocMap interface , instArgMap = ifaceArgMap interface -- cgit v1.2.3 From fbbe544c91020da143160bb8c68ee890d214a69e Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 13 Mar 2017 03:13:10 -0700 Subject: Render signature module tree separately from modules. Signed-off-by: Edward Z. Yang (cherry picked from commit 2067a2d0afa9cef381d26fb7140b67c62f433fc0) --- haddock-api/src/Haddock/Backends/Xhtml.hs | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) (limited to 'haddock-api') diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 65b427f9..34911b11 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -263,13 +263,20 @@ ppHtmlContents dflags odir doctitle _maybe_package themes mathjax_url maybe_index_url maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug qual = do let tree = mkModuleTree dflags showPkgs - [(instMod iface, toInstalledDescription iface) | iface <- ifaces] + [(instMod iface, toInstalledDescription iface) + | iface <- ifaces + , not (instIsSig iface)] + sig_tree = mkModuleTree dflags showPkgs + [(instMod iface, toInstalledDescription iface) + | iface <- ifaces + , instIsSig iface] html = headHtml doctitle Nothing themes mathjax_url +++ bodyHtml doctitle Nothing maybe_source_url maybe_wiki_url Nothing maybe_index_url << [ ppPrologue qual doctitle prologue, + ppSignatureTree qual sig_tree, ppModuleTree qual tree ] createDirectoryIfMissing True odir @@ -282,7 +289,13 @@ ppPrologue qual title (Just doc) = divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml qual doc)) +ppSignatureTree :: Qualification -> [ModuleTree] -> Html +ppSignatureTree qual ts = + divModuleList << (sectionName << "Signatures" +++ mkNodeList qual [] "n" ts) + + ppModuleTree :: Qualification -> [ModuleTree] -> Html +ppModuleTree _ [] = mempty ppModuleTree qual ts = divModuleList << (sectionName << "Modules" +++ mkNodeList qual [] "n" ts) -- cgit v1.2.3 From 4e6f4447caf61b6a91a483f30a15354cbf6cfc31 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 13 Mar 2017 15:13:27 -0700 Subject: Documentation. Signed-off-by: Edward Z. Yang (cherry picked from commit 0671abfe7e8ceae2269467a30b77ed9d9656e2cc) --- haddock-api/src/Haddock/Interface/Create.hs | 27 ++++++++++++++++++++++----- 1 file changed, 22 insertions(+), 5 deletions(-) (limited to 'haddock-api') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 024cd02d..502d6599 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -11,6 +11,10 @@ -- Maintainer : haddock@projects.haskell.org -- Stability : experimental -- Portability : portable +-- +-- This module provides a single function 'createInterface', +-- which creates a Haddock 'Interface' from the typechecking +-- results 'TypecheckedModule' from GHC. ----------------------------------------------------------------------------- module Haddock.Interface.Create (createInterface) where @@ -54,7 +58,11 @@ import HsDecls ( getConDetails ) -- | Use a 'TypecheckedModule' to produce an 'Interface'. -- To do this, we need access to already processed modules in the topological -- sort. That's what's in the 'IfaceMap'. -createInterface :: TypecheckedModule -> [Flag] -> IfaceMap -> InstIfaceMap -> ErrMsgGhc Interface +createInterface :: TypecheckedModule + -> [Flag] -- Boolean flags + -> IfaceMap -- Locally processed modules + -> InstIfaceMap -- External, already installed interfaces + -> ErrMsgGhc Interface createInterface tm flags modMap instIfaceMap = do let ms = pm_mod_summary . tm_parsed_module $ tm @@ -518,7 +526,7 @@ mkExportItems -> WarningMap -> GlobalRdrEnv -> [Name] -- exported names (orig) - -> [LHsDecl Name] + -> [LHsDecl Name] -- renamed source declarations -> Maps -> FixMap -> [SrcSpan] -- splice locations @@ -716,7 +724,7 @@ moduleExports :: Module -- ^ Module A (identity, NOT semantic) -> WarningMap -> GlobalRdrEnv -- ^ The renaming environment used for A -> [Name] -- ^ All the exports of A - -> [LHsDecl Name] -- ^ All the declarations in A + -> [LHsDecl Name] -- ^ All the renamed declarations in A -> IfaceMap -- ^ Already created interfaces -> InstIfaceMap -- ^ Interfaces in other packages -> Maps @@ -765,8 +773,17 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa -- (For more information, see Trac #69) -fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> FixMap -> [SrcSpan] - -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name] +-- | Simplified variant of 'mkExportItems', where we can assume that +-- every locally defined declaration is exported; thus, we just +-- zip through the renamed declarations. +fullModuleContents :: DynFlags + -> WarningMap + -> GlobalRdrEnv -- ^ The renaming environment + -> Maps + -> FixMap + -> [SrcSpan] -- ^ Locations of all TH splices + -> [LHsDecl Name] -- ^ All the renamed declarations + -> ErrMsgGhc [ExportItem Name] fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap splices decls = liftM catMaybes $ mapM mkExportItem (expandSig decls) where -- cgit v1.2.3 From f65966b2febe36c8aae8ebee13d3f12a63479e65 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 13 Mar 2017 15:25:09 -0700 Subject: More docs. Signed-off-by: Edward Z. Yang (cherry picked from commit 3d77b373dd5807d5d956719dd7c849a11534fa6a) --- haddock-api/src/Haddock/Interface/Create.hs | 5 +++++ 1 file changed, 5 insertions(+) (limited to 'haddock-api') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 502d6599..f1043c03 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -92,6 +92,7 @@ createInterface tm flags modMap instIfaceMap = do | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0 | otherwise = opts0 + -- Process the top-level module header documentation. (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader let declsWithDocs = topDecls group_ @@ -114,6 +115,8 @@ createInterface tm flags modMap instIfaceMap = do let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap)) + -- The MAIN functionality: compute the export items which will + -- each be the actual documentation of this module. exportItems <- mkExportItems modMap mdl sem_mdl allWarnings gre exportedNames decls maps fixMap splices exports instIfaceMap dflags @@ -352,6 +355,8 @@ mkMaps dflags gre instances decls = -- | Get all subordinate declarations inside a declaration, and their docs. +-- A subordinate declaration is something like the associate type or data +-- family of a type class. subordinates :: InstMap -> HsDecl Name -> [(Name, [HsDocString], Map Int HsDocString)] subordinates instMap decl = case decl of InstD (ClsInstD d) -> do -- cgit v1.2.3 From 76d0b2b8ac2bfaa7983a9b5ea828f6caf8a6205d Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 13 Mar 2017 15:33:25 -0700 Subject: TODO on moduleExports. Signed-off-by: Edward Z. Yang (cherry picked from commit 94610e9b446324f4231fa6ad4c6ac51e4eba8c0e) --- haddock-api/src/Haddock/Interface/Create.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) (limited to 'haddock-api') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index f1043c03..85401bfa 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -551,7 +551,11 @@ mkExportItems lookupExport (IEThingAll (L _ t)) = declWith $ ieWrappedName t lookupExport (IEThingWith (L _ t) _ _ _) = declWith $ ieWrappedName t lookupExport (IEModuleContents (L _ m)) = - -- Pass in identity module, so we can look it up in index correctly + -- TODO: We could get more accurate reporting here if IEModuleContents + -- also recorded the actual names that are exported here. We CAN + -- compute this info using @gre@ but 'moduleExports does not seem to + -- do so. + -- NB: Pass in identity module, so we can look it up in index correctly moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices lookupExport (IEGroup lev docStr) = return $ return . ExportGroup lev "" $ processDocString dflags gre docStr -- cgit v1.2.3 From 24694932de26645331eb53b016c84a6a5c171a97 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Tue, 14 Mar 2017 03:53:49 -0700 Subject: Better Backpack support with signature merging. When we merge signatures, we gain exports that don't necessarily have a source-level declaration corresponding to them. This meant Haddock dropped them. There are two big limitations: * If there's no export list, we won't report inherited signatures. * If the type has a subordinate, the current hiDecl implementation doesn't reconstitute them. These are probably worth fixing eventually, but this gets us to minimum viable functionality. Signed-off-by: Edward Z. Yang (cherry picked from commit 6cc832dfb1de6088a4abcaae62b25a7e944d55c3) --- haddock-api/src/Haddock/Interface/Create.hs | 46 +++++++++++++++++++++-------- 1 file changed, 34 insertions(+), 12 deletions(-) (limited to 'haddock-api') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 85401bfa..e594feae 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -71,6 +71,7 @@ createInterface tm flags modMap instIfaceMap = do !safety = modInfoSafe mi mdl = ms_mod ms sem_mdl = tcg_semantic_mod (fst (tm_internals_ tm)) + is_sig = ms_hsc_src ms == HsigFile dflags = ms_hspp_opts ms !instances = modInfoInstances mi !fam_instances = md_fam_insts md @@ -117,7 +118,7 @@ createInterface tm flags modMap instIfaceMap = do -- The MAIN functionality: compute the export items which will -- each be the actual documentation of this module. - exportItems <- mkExportItems modMap mdl sem_mdl allWarnings gre exportedNames decls + exportItems <- mkExportItems is_sig modMap mdl sem_mdl allWarnings gre exportedNames decls maps fixMap splices exports instIfaceMap dflags let !visibleNames = mkVisibleNames maps exportItems opts @@ -143,7 +144,7 @@ createInterface tm flags modMap instIfaceMap = do return $! Interface { ifaceMod = mdl - , ifaceIsSig = Module.isHoleModule sem_mdl + , ifaceIsSig = is_sig , ifaceOrigFilename = msHsFilePath ms , ifaceInfo = info , ifaceDoc = Documentation mbDoc modWarn @@ -525,7 +526,8 @@ collectDocs = go Nothing [] -- We create the export items even if the module is hidden, since they -- might be useful when creating the export items for other modules. mkExportItems - :: IfaceMap + :: Bool -- is it a signature + -> IfaceMap -> Module -- this module -> Module -- semantic module -> WarningMap @@ -540,7 +542,7 @@ mkExportItems -> DynFlags -> ErrMsgGhc [ExportItem Name] mkExportItems - modMap thisMod semMod warnings gre exportedNames decls + is_sig modMap thisMod semMod warnings gre exportedNames decls maps@(docMap, argMap, subMap, declMap, instMap) fixMap splices optExports instIfaceMap dflags = case optExports of Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls @@ -569,8 +571,9 @@ mkExportItems Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc declWith :: Name -> ErrMsgGhc [ ExportItem Name ] - declWith t = - case findDecl t of + declWith t = do + r <- findDecl t + case r of ([L l (ValD _)], (doc, _)) -> do -- Top-level binding without type signature export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap @@ -649,13 +652,32 @@ mkExportItems isExported = (`elem` exportedNames) - findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)])) + findDecl :: Name -> ErrMsgGhc ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)])) findDecl n - | m == semMod, Just ds <- M.lookup n declMap = - (ds, lookupDocs n warnings docMap argMap subMap) - | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap, Just ds <- M.lookup n (ifaceDeclMap iface) = - (ds, lookupDocs n warnings (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface)) - | otherwise = ([], (noDocForDecl, [])) + | m == semMod = + case M.lookup n declMap of + Just ds -> return (ds, lookupDocs n warnings docMap argMap subMap) + Nothing + | is_sig -> do + -- OK, so it wasn't in the local declaration map. It could + -- have been inherited from a signature. Reconstitute it + -- from the type. + mb_r <- hiDecl dflags n + case mb_r of + Nothing -> return ([], (noDocForDecl, [])) + -- TODO: If we try harder, we might be able to find + -- a Haddock! Look in the Haddocks for each thing in + -- requirementContext (pkgState) + Just decl -> return ([decl], (noDocForDecl, [])) + | otherwise -> + return ([], (noDocForDecl, [])) + | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap + , Just ds <- M.lookup n (ifaceDeclMap iface) = + return (ds, lookupDocs n warnings + (ifaceDocMap iface) + (ifaceArgMap iface) + (ifaceSubMap iface)) + | otherwise = return ([], (noDocForDecl, [])) where m = nameModule n -- cgit v1.2.3 From ef93eaac9bc0ca40073763d2e18ced3a51679ead Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Wed, 22 Mar 2017 13:48:12 -0700 Subject: Annotate signature docs with (signature) Signed-off-by: Edward Z. Yang (cherry picked from commit 07b88c5d4e79b87a319fbb08f8ea01dbb41063c1) --- haddock-api/src/Haddock/Backends/Xhtml.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'haddock-api') diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 34911b11..fc26afbb 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -482,13 +482,16 @@ ppHtmlModule odir doctitle themes mdl = ifaceMod iface aliases = ifaceModuleAliases iface mdl_str = moduleString mdl + mdl_str_annot = mdl_str ++ if ifaceIsSig iface + then " (signature)" + else "" real_qual = makeModuleQual qual aliases mdl html = - headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes maybe_mathjax_url +++ + headHtml mdl_str_annot (Just $ "mini_" ++ moduleHtmlFile mdl) themes maybe_mathjax_url +++ bodyHtml doctitle (Just iface) maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url << [ - divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str)), + divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str_annot)), ifaceToHtml maybe_source_url maybe_wiki_url iface unicode real_qual ] -- cgit v1.2.3 From 0567d936e02dcbc41c62b4dd63c7aaafc3383844 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Wed, 22 Mar 2017 14:11:25 -0700 Subject: Render help documentation link next to (signature) in title. Signed-off-by: Edward Z. Yang (cherry picked from commit 4eb765ca4205c79539d60b7afa9b7e261a4a49fe) --- haddock-api/resources/html/Ocean.std-theme/ocean.css | 5 +++++ haddock-api/src/Haddock/Backends/Xhtml.hs | 9 ++++++++- 2 files changed, 13 insertions(+), 1 deletion(-) (limited to 'haddock-api') diff --git a/haddock-api/resources/html/Ocean.std-theme/ocean.css b/haddock-api/resources/html/Ocean.std-theme/ocean.css index e8e4d705..29af691b 100644 --- a/haddock-api/resources/html/Ocean.std-theme/ocean.css +++ b/haddock-api/resources/html/Ocean.std-theme/ocean.css @@ -88,6 +88,11 @@ pre, code, kbd, samp, tt, .src { font-size: 182%; /* 24pt */ } +#module-header .caption sup { + font-size: 70%; + font-weight: normal; +} + .info { font-size: 85%; /* 11pt */ } diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index fc26afbb..4cb028b8 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -485,13 +485,17 @@ ppHtmlModule odir doctitle themes mdl_str_annot = mdl_str ++ if ifaceIsSig iface then " (signature)" else "" + mdl_str_linked = mdl_str +++ + " (signature" +++ + sup << ("[" +++ anchor ! [href signatureDocURL] << "?" +++ "]" ) +++ + ")" real_qual = makeModuleQual qual aliases mdl html = headHtml mdl_str_annot (Just $ "mini_" ++ moduleHtmlFile mdl) themes maybe_mathjax_url +++ bodyHtml doctitle (Just iface) maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url << [ - divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str_annot)), + divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str_linked)), ifaceToHtml maybe_source_url maybe_wiki_url iface unicode real_qual ] @@ -499,6 +503,9 @@ ppHtmlModule odir doctitle themes writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html) ppHtmlModuleMiniSynopsis odir doctitle themes maybe_mathjax_url iface unicode real_qual debug +signatureDocURL :: String +signatureDocURL = "https://wiki.haskell.org/Module_signature" + ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes -> Maybe String -> Interface -> Bool -> Qualification -> Bool -> IO () ppHtmlModuleMiniSynopsis odir _doctitle themes maybe_mathjax_url iface unicode qual debug = do -- cgit v1.2.3 From 18ed871afb82560d5433b2f53e31b4db9353a74e Mon Sep 17 00:00:00 2001 From: Phil Ruffwind Date: Sat, 1 Apr 2017 05:05:06 -0400 Subject: Update MathJax URL MathJax is shutting down their CDN: https://www.mathjax.org/cdn-shutting-down/ They recommend migrating to cdnjs. --- haddock-api/src/Haddock/Backends/Xhtml.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'haddock-api') diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 4cb028b8..c5caa6a2 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -126,7 +126,7 @@ headHtml docTitle miniPage themes mathjax_url = ] where setSynopsis = maybe "" (\p -> "setSynopsis(\"" ++ p ++ "\");") miniPage - mjUrl = maybe "https://cdn.mathjax.org/mathjax/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML" id mathjax_url + mjUrl = maybe "https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" id mathjax_url srcButton :: SourceURLs -> Maybe Interface -> Maybe Html -- cgit v1.2.3 From 1185aba1fd0727028dc223380c811ec98a42605c Mon Sep 17 00:00:00 2001 From: David Turner Date: Fri, 17 Mar 2017 12:04:04 +0000 Subject: Add highlight for :target to ocean.css --- haddock-api/resources/html/Ocean.std-theme/ocean.css | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'haddock-api') diff --git a/haddock-api/resources/html/Ocean.std-theme/ocean.css b/haddock-api/resources/html/Ocean.std-theme/ocean.css index 29af691b..9d2c644f 100644 --- a/haddock-api/resources/html/Ocean.std-theme/ocean.css +++ b/haddock-api/resources/html/Ocean.std-theme/ocean.css @@ -614,4 +614,8 @@ div#style-menu-holder { float: right; } +:target { + background-color: #ffff00; +} + /* @end */ -- cgit v1.2.3 From e0ada1743cb722d2f82498a95b201f3ffb303137 Mon Sep 17 00:00:00 2001 From: alexbiehl Date: Tue, 11 Apr 2017 20:35:08 +0200 Subject: Read files for hyperlinker eagerly This also exposes Documentation.Haddock.Utf8 --- haddock-api/src/Haddock/Interface/Create.hs | 12 ++++++++---- haddock-library/haddock-library.cabal | 2 +- 2 files changed, 9 insertions(+), 5 deletions(-) (limited to 'haddock-api') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index e594feae..d2ad9294 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -19,6 +19,7 @@ module Haddock.Interface.Create (createInterface) where import Documentation.Haddock.Doc (metaDocAppend) +import Documentation.Haddock.Utf8 as Utf8 import Haddock.Types import Haddock.Options import Haddock.GhcUtils @@ -29,6 +30,7 @@ import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Ast as Hyperlinker import Haddock.Backends.Hyperlinker.Parser as Hyperlinker +import qualified Data.ByteString as BS import qualified Data.Map as M import Data.Map (Map) import Data.List @@ -38,6 +40,7 @@ import Data.Ord import Control.Applicative import Control.Arrow (second) import Control.DeepSeq +import Control.Exception (evaluate) import Control.Monad import Data.Function (on) @@ -976,10 +979,11 @@ mkMaybeTokenizedSrc flags tm summary = pm_mod_summary . tm_parsed_module $ tm mkTokenizedSrc :: ModSummary -> RenamedSource -> IO [RichToken] -mkTokenizedSrc ms src = - Hyperlinker.enrich src . Hyperlinker.parse <$> rawSrc - where - rawSrc = readFile $ msHsFilePath ms +mkTokenizedSrc ms src = do + -- make sure to read the whole file at once otherwise + -- we run out of file descriptors (see #495) + rawSrc <- BS.readFile (msHsFilePath ms) >>= evaluate + return $ Hyperlinker.enrich src (Hyperlinker.parse (decodeUtf8 rawSrc)) -- | Find a stand-alone documentation comment by its name. findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString) diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index cabfbc67..4e355dd1 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -34,6 +34,7 @@ library Documentation.Haddock.Parser.Monad Documentation.Haddock.Types Documentation.Haddock.Doc + Documentation.Haddock.Utf8 other-modules: Data.Attoparsec @@ -48,7 +49,6 @@ library Data.Attoparsec.Internal.Types Data.Attoparsec.Number Documentation.Haddock.Parser.Util - Documentation.Haddock.Utf8 test-suite spec type: exitcode-stdio-1.0 -- cgit v1.2.3 From b44676d9acd36b50a93aea6882751284d00013b6 Mon Sep 17 00:00:00 2001 From: alexbiehl Date: Tue, 11 Apr 2017 20:37:06 +0200 Subject: Explicit import list ofr Control.DeepSeq in Haddock.Interface.Create --- haddock-api/src/Haddock/Interface/Create.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'haddock-api') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index d2ad9294..6ff1223c 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -39,7 +39,7 @@ import Data.Monoid import Data.Ord import Control.Applicative import Control.Arrow (second) -import Control.DeepSeq +import Control.DeepSeq (force) import Control.Exception (evaluate) import Control.Monad import Data.Function (on) -- cgit v1.2.3 From e9cd7b1b52228b9ef8e1bd4e6cb1f2583740fcee Mon Sep 17 00:00:00 2001 From: Kyrill Briantsev Date: Thu, 12 Jan 2017 13:23:50 +0300 Subject: Prevent GHC API from doing optimization passes. --- haddock-api/src/Haddock.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'haddock-api') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index bbaea359..6af0874a 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -397,7 +397,7 @@ withGhc' libDir flags ghcActs = runGhc (Just libDir) $ do ghcMode = CompManager, ghcLink = NoLink } - let dynflags'' = gopt_unset dynflags' Opt_SplitObjs + let dynflags'' = updOptLevel 0 $ gopt_unset dynflags' Opt_SplitObjs defaultCleanupHandler dynflags'' $ do -- ignore the following return-value, which is a list of packages -- that may need to be re-linked: Haddock doesn't do any -- cgit v1.2.3 From 3b64e93ec1811bb5741550a4956ea5f28be24443 Mon Sep 17 00:00:00 2001 From: Alexander Biehl Date: Wed, 12 Apr 2017 16:32:04 +0200 Subject: Add @alexbiehl as maintaner --- haddock-api/haddock-api.cabal | 2 +- haddock-library/haddock-library.cabal | 2 +- haddock.cabal | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) (limited to 'haddock-api') diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 922aa07c..f98a8202 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -6,7 +6,7 @@ description: Haddock is a documentation-generation tool for Haskell license: BSD3 license-file: LICENSE author: Simon Marlow, David Waern -maintainer: Simon Hengel , Mateusz Kowalczyk +maintainer: Alex Biehl , Simon Hengel , Mateusz Kowalczyk homepage: http://www.haskell.org/haddock/ bug-reports: https://github.com/haskell/haddock/issues copyright: (c) Simon Marlow, David Waern diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index 4e355dd1..463569a3 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -9,7 +9,7 @@ description: Haddock is a documentation-generation tool for Haskell itself, see the ‘haddock’ package. license: BSD3 license-file: LICENSE -maintainer: Simon Hengel , Mateusz Kowalczyk +maintainer: Alex Biehl , Simon Hengel , Mateusz Kowalczyk homepage: http://www.haskell.org/haddock/ bug-reports: https://github.com/haskell/haddock/issues category: Documentation diff --git a/haddock.cabal b/haddock.cabal index 6ebdad76..a79f8c78 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -6,7 +6,7 @@ description: Haddock is a documentation-generation tool for Haskell license: BSD3 license-file: LICENSE author: Simon Marlow, David Waern -maintainer: Simon Hengel , Mateusz Kowalczyk +maintainer: Alex Biehl , Simon Hengel , Mateusz Kowalczyk homepage: http://www.haskell.org/haddock/ bug-reports: https://github.com/haskell/haddock/issues copyright: (c) Simon Marlow, David Waern -- cgit v1.2.3 From 70885ce16e1b0b9bf19fe0efb85a48daa0e5c281 Mon Sep 17 00:00:00 2001 From: alexbiehl Date: Tue, 18 Apr 2017 16:45:32 +0200 Subject: Travis: Use ghc-8.2.1 on master --- .travis.yml | 84 +++++++++++++++++++++++++++------ haddock-api/haddock-api.cabal | 5 +- haddock-api/src/Haddock.hs | 25 ++++++---- haddock-library/haddock-library.cabal | 5 +- haddock-test/src/Test/Haddock/Config.hs | 17 +++++-- haddock.cabal | 53 ++++++++++++--------- 6 files changed, 136 insertions(+), 53 deletions(-) (limited to 'haddock-api') diff --git a/.travis.yml b/.travis.yml index 405f8753..c1f8f504 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,26 +1,80 @@ +# This Travis job script has been generated by a script via +# +# make_travis_yml_2.hs 'haddock.cabal' +# +# For more information, see https://github.com/hvr/multi-ghc-travis +# +language: c sudo: false +git: + submodules: false # whether to recursively clone submodules + +cache: + directories: + - $HOME/.cabal/packages + - $HOME/.cabal/store + +before_cache: + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log + # remove files that are regenerated by 'cabal update' + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.* + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx + matrix: include: - - env: CABALVER=head GHCVER=head - addons: {apt: {packages: [cabal-install-head,ghc-head], sources: [hvr-ghc]}} + - compiler: "ghc-8.2.1" + # env: TEST=--disable-tests BENCH=--disable-benchmarks + addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.1], sources: [hvr-ghc]}} + - compiler: "ghc-head" + # env: TEST=--disable-tests BENCH=--disable-benchmarks + addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-head], sources: [hvr-ghc]}} allow_failures: - - env: CABALVER=head GHCVER=head + - compiler: "ghc-head" before_install: - - export PATH=$HOME/.cabal/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH + - HC=${CC} + - unset CC + - PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$PATH + - PKGNAME='haddock' + +install: - cabal --version - - cabal update - - cd haddock-library - - cabal install --only-dependencies --enable-tests -# - cabal install doctest - # --ghc-options=-Werror - - cabal configure --enable-tests && cabal build && cabal test -# - doctest -isrc -i$(echo vendor/attoparsec-*) -optP-include -optPdist/build/autogen/cabal_macros.h src/Documentation/Haddock/Parser.hs - - cabal install - - cd .. - - (cd haddock-api/ && cabal install --only-dependencies --enable-tests && cabal configure --enable-tests && cabal build && cabal test && cabal install) + - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" + - BENCH=${BENCH---enable-benchmarks} + - TEST=${TEST---enable-tests} + - travis_retry cabal update -v + - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config + - rm -fv cabal.project.local + - rm -f cabal.project.freeze + - cabal new-build -w ${HC} ${TEST} ${BENCH} --dep -j2 all + - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --dep -j2 all +# Here starts the actual work to be performed for the package under test; +# any command which exits with a non-zero exit code causes the build to fail. script: - - cabal configure --enable-tests && cabal build && cabal test + - if [ -f configure.ac ]; then autoreconf -i; fi + - rm -rf dist/ + - cabal sdist # test that a source-distribution can be generated + - cd dist/ + - SRCTAR=(${PKGNAME}-*.tar.gz) + - SRC_BASENAME="${SRCTAR/%.tar.gz}" + - tar -xvf "./$SRC_BASENAME.tar.gz" + - cd "$SRC_BASENAME/" +## from here on, CWD is inside the extracted source-tarball + - rm -fv cabal.project.local + # this builds all libraries and executables (without tests/benchmarks) + - rm -f cabal.project.freeze + - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all + # this builds all libraries and executables (including tests/benchmarks) + # - rm -rf ./dist-newstyle + + # build & run tests + - cabal new-build -w ${HC} ${TEST} ${BENCH} all + - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} all; fi + +# EOF diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index f98a8202..921e16eb 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -12,7 +12,7 @@ bug-reports: https://github.com/haskell/haddock/issues copyright: (c) Simon Marlow, David Waern category: Documentation build-type: Simple -cabal-version: >= 1.10 +cabal-version: >= 2.0 stability: experimental data-dir: @@ -120,6 +120,9 @@ test-suite spec , hspec , QuickCheck == 2.* + build-tool-depends: + hspec-discover:hspec-discover + source-repository head type: git location: https://github.com/haskell/haddock.git diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 6af0874a..dec85b79 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -426,15 +426,22 @@ getHaddockLibDir flags = #ifdef IN_GHC_TREE getInTreeDir #else - d <- getDataDir -- provided by Cabal - doesDirectoryExist d >>= \exists -> case exists of - True -> return d - False -> do - -- If directory does not exist then we are probably invoking from - -- ./dist/build/haddock/haddock so we use ./resources as a fallback. - doesDirectoryExist "resources" >>= \exists_ -> case exists_ of - True -> return "resources" - False -> die ("Haddock's resource directory (" ++ d ++ ") does not exist!\n") + -- if data directory does not exist we are probably + -- invoking from either ./haddock-api or ./ + let res_dirs = [ getDataDir -- provided by Cabal + , pure "resources" + , pure "haddock-api/resources" + ] + + check get_path = do + p <- get_path + exists <- doesDirectoryExist p + pure $ if exists then Just p else Nothing + + dirs <- mapM check res_dirs + case [p | Just p <- dirs] of + (p : _) -> return p + _ -> die "Haddock's resource directory does not exist!\n" #endif fs -> return (last fs) diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index 463569a3..b7a20758 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -14,7 +14,7 @@ homepage: http://www.haskell.org/haddock/ bug-reports: https://github.com/haskell/haddock/issues category: Documentation build-type: Simple -cabal-version: >= 1.10 +cabal-version: >= 2.0 stability: experimental library @@ -78,6 +78,9 @@ test-suite spec , hspec , QuickCheck == 2.* + build-tool-depends: + hspec-discover:hspec-discover + source-repository head type: git subdir: haddock-library diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs index e1e920f2..50616c7f 100644 --- a/haddock-test/src/Test/Haddock/Config.hs +++ b/haddock-test/src/Test/Haddock/Config.hs @@ -165,11 +165,18 @@ loadConfig ccfg dcfg flags files = do cfgEnv <- (:) ("haddock_datadir", dcfgResDir dcfg) <$> getEnvironment systemHaddockPath <- List.lookup "HADDOCK_PATH" <$> getEnvironment - cfgHaddockPath <- case flagsHaddockPath flags <|> systemHaddockPath of + haddockOnPath <- findExecutable "haddock" + + let haddock_path = msum [ flagsHaddockPath flags + , systemHaddockPath + , haddockOnPath + ] + + cfgHaddockPath <- case haddock_path of Just path -> pure path - Nothing -> do - hPutStrLn stderr $ "Haddock executable not specified" - exitFailure + Nothing -> do + hPutStrLn stderr "Haddock executable not found" + exitFailure ghcPath <- init <$> rawSystemStdout normal cfgHaddockPath ["--print-ghc-path"] @@ -195,7 +202,7 @@ loadConfig ccfg dcfg flags files = do let cfgAccept = FlagAccept `elem` flags let cfgCheckConfig = ccfg - let cfgDirConfig = dcfg + let cfgDirConfig = dcfg return $ Config { .. } diff --git a/haddock.cabal b/haddock.cabal index a79f8c78..fa8a3531 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -12,9 +12,10 @@ bug-reports: https://github.com/haskell/haddock/issues copyright: (c) Simon Marlow, David Waern category: Documentation build-type: Simple -cabal-version: >= 1.10 +cabal-version: >= 2.0 stability: experimental - +tested-with: GHC==8.2.*, GHC==8.3 + extra-source-files: CHANGES README.md @@ -130,32 +131,40 @@ test-suite driver-test test-suite html-test type: exitcode-stdio-1.0 - default-language: Haskell2010 - main-is: Main.hs - hs-source-dirs: html-test - build-depends: base, filepath, haddock-test == 0.0.1 + -- This tells cabal that this test depends on the executable + -- component 'haddock' from this very same package, as well + -- as adding the build-folder where the `haddock` + -- executable can be found in front of $PATH + build-tool-depends: haddock:haddock + default-language: Haskell2010 + main-is: Main.hs + hs-source-dirs: html-test + build-depends: base, filepath, haddock-test == 0.0.1 test-suite hypsrc-test - type: exitcode-stdio-1.0 - default-language: Haskell2010 - main-is: Main.hs - hs-source-dirs: hypsrc-test - build-depends: base, filepath, haddock-test == 0.0.1 - ghc-options: -Wall -fwarn-tabs + type: exitcode-stdio-1.0 + build-tool-depends: haddock:haddock + default-language: Haskell2010 + main-is: Main.hs + hs-source-dirs: hypsrc-test + build-depends: base, filepath, haddock-test == 0.0.1 + ghc-options: -Wall -fwarn-tabs test-suite latex-test - type: exitcode-stdio-1.0 - default-language: Haskell2010 - main-is: Main.hs - hs-source-dirs: latex-test - build-depends: base, filepath, haddock-test == 0.0.1 + type: exitcode-stdio-1.0 + build-tool-depends: haddock:haddock + default-language: Haskell2010 + main-is: Main.hs + hs-source-dirs: latex-test + build-depends: base, filepath, haddock-test == 0.0.1 test-suite hoogle-test - type: exitcode-stdio-1.0 - default-language: Haskell2010 - main-is: Main.hs - hs-source-dirs: hoogle-test - build-depends: base, filepath, haddock-test == 0.0.1 + type: exitcode-stdio-1.0 + build-tool-depends: haddock:haddock + default-language: Haskell2010 + main-is: Main.hs + hs-source-dirs: hoogle-test + build-depends: base, filepath, haddock-test == 0.0.1 source-repository head type: git -- cgit v1.2.3 From c0b1d8b7dc6331efb62e05ad317af781069c13be Mon Sep 17 00:00:00 2001 From: Alexander Biehl Date: Tue, 25 Apr 2017 11:33:10 +0200 Subject: Expand signatures for class declarations --- haddock-api/src/Haddock/Interface/Create.hs | 24 +++++++++++++++++------- 1 file changed, 17 insertions(+), 7 deletions(-) (limited to 'haddock-api') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 6ff1223c..26ac0281 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -819,20 +819,30 @@ fullModuleContents :: DynFlags -> [LHsDecl Name] -- ^ All the renamed declarations -> ErrMsgGhc [ExportItem Name] fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap splices decls = - liftM catMaybes $ mapM mkExportItem (expandSig decls) + liftM catMaybes $ mapM mkExportItem (expandSigDecls decls) where -- A type signature can have multiple names, like: -- foo, bar :: Types.. -- -- We go through the list of declarations and expand type signatures, so -- that every type signature has exactly one name! - expandSig :: [LHsDecl name] -> [LHsDecl name] - expandSig = foldr f [] + expandSigDecls :: [LHsDecl name] -> [LHsDecl name] + expandSigDecls = concatMap f where - f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name] - f (L l (SigD (TypeSig names t))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t)) : acc) xs names - f (L l (SigD (ClassOpSig b names t))) xs = foldr (\n acc -> L l (SigD (ClassOpSig b [n] t)) : acc) xs names - f x xs = x : xs + f (L l (SigD sig)) = [ L l (SigD s) | s <- expandSig sig ] + + -- also expand type signatures for class methods + f (L l (TyClD cls@ClassDecl{})) = + [ L l (TyClD cls { tcdSigs = concatMap expandLSig (tcdSigs cls) }) ] + f x = [x] + + expandLSig :: LSig name -> [LSig name] + expandLSig (L l sig) = [ L l s | s <- expandSig sig ] + + expandSig :: Sig name -> [Sig name] + expandSig (TypeSig names t) = [ TypeSig [n] t | n <- names ] + expandSig (ClassOpSig b names t) = [ ClassOpSig b [n] t | n <- names ] + expandSig x = [x] mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name)) mkExportItem (L _ (DocD (DocGroup lev docStr))) = do -- cgit v1.2.3 From 968045e574783fe8bdde7afbb825d4dcd82ae0e7 Mon Sep 17 00:00:00 2001 From: Alexander Biehl Date: Tue, 25 Apr 2017 13:39:49 +0200 Subject: Hoogle: Correctly print classes with associated data types --- haddock-api/src/Haddock/Backends/Hoogle.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'haddock-api') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 86a73c33..183b669e 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -22,6 +22,7 @@ import Haddock.GhcUtils import Haddock.Types hiding (Version) import Haddock.Utils hiding (out) +import HsBinds (emptyLHsBinds) import GHC import Outputable import NameSet @@ -157,7 +158,9 @@ pp_sig dflags names (L _ typ) = -- note: does not yet output documentation for class methods ppClass :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String] -ppClass dflags decl subdocs = (out dflags decl{tcdSigs=[]} ++ ppTyFams) : ppMethods +ppClass dflags decl subdocs = + (out dflags decl{tcdSigs=[], tcdATs=[], tcdATDefs=[], tcdMeths=emptyLHsBinds} + ++ ppTyFams) : ppMethods where ppMethods = concat . map (ppSig' . unLoc . add_ctxt) $ tcdSigs decl -- cgit v1.2.3 From ce3647ea278606f43615817ecb2865d96ca8b39e Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Sat, 22 Apr 2017 20:38:26 -0700 Subject: Render (signature) only if it actually is a signature! I forgot a conditional, oops! Signed-off-by: Edward Z. Yang (cherry picked from commit a0c4790e15a2d3fab8d830eee8fcd639fe6d39c9) --- haddock-api/src/Haddock/Backends/Xhtml.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'haddock-api') diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index c5caa6a2..31a748cb 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -485,10 +485,13 @@ ppHtmlModule odir doctitle themes mdl_str_annot = mdl_str ++ if ifaceIsSig iface then " (signature)" else "" - mdl_str_linked = mdl_str +++ - " (signature" +++ + mdl_str_linked + | ifaceIsSig iface + = mdl_str +++ " (signature" +++ sup << ("[" +++ anchor ! [href signatureDocURL] << "?" +++ "]" ) +++ ")" + | otherwise + = toHtml mdl_str real_qual = makeModuleQual qual aliases mdl html = headHtml mdl_str_annot (Just $ "mini_" ++ moduleHtmlFile mdl) themes maybe_mathjax_url +++ -- cgit v1.2.3 From 4346ad26ac1346aa5e59991315f6969c844bea60 Mon Sep 17 00:00:00 2001 From: alexbiehl Date: Wed, 26 Apr 2017 07:07:04 +0200 Subject: Remove anything related to obsolete frames mode --- .../resources/html/Ocean.std-theme/ocean.css | 4 - haddock-api/resources/html/haddock-util.js | 132 +-------------------- haddock-api/src/Haddock/Backends/Xhtml.hs | 70 ++--------- html-test/ref/A.html | 4 +- html-test/ref/B.html | 4 +- html-test/ref/Bold.html | 4 +- html-test/ref/Bug1.html | 4 +- html-test/ref/Bug195.html | 4 +- html-test/ref/Bug2.html | 4 +- html-test/ref/Bug201.html | 4 +- html-test/ref/Bug253.html | 4 +- html-test/ref/Bug26.html | 4 +- html-test/ref/Bug280.html | 21 ++-- html-test/ref/Bug294.html | 4 +- html-test/ref/Bug298.html | 4 +- html-test/ref/Bug3.html | 4 +- html-test/ref/Bug308.html | 4 +- html-test/ref/Bug308CrossModule.html | 4 +- html-test/ref/Bug310.html | 4 +- html-test/ref/Bug313.html | 4 +- html-test/ref/Bug335.html | 4 +- html-test/ref/Bug387.html | 4 +- html-test/ref/Bug4.html | 4 +- html-test/ref/Bug6.html | 4 +- html-test/ref/Bug7.html | 4 +- html-test/ref/Bug8.html | 2 +- html-test/ref/Bug85.html | 4 +- html-test/ref/BugDeprecated.html | 4 +- html-test/ref/BugExportHeadings.html | 4 +- html-test/ref/Bugs.html | 4 +- html-test/ref/DeprecatedClass.html | 4 +- html-test/ref/DeprecatedData.html | 4 +- html-test/ref/DeprecatedFunction.html | 4 +- html-test/ref/DeprecatedFunction2.html | 4 +- html-test/ref/DeprecatedFunction3.html | 4 +- html-test/ref/DeprecatedModule.html | 4 +- html-test/ref/DeprecatedModule2.html | 4 +- html-test/ref/DeprecatedNewtype.html | 4 +- html-test/ref/DeprecatedReExport.html | 4 +- html-test/ref/DeprecatedRecord.html | 4 +- html-test/ref/DeprecatedTypeFamily.html | 4 +- html-test/ref/DeprecatedTypeSynonym.html | 4 +- html-test/ref/Examples.html | 4 +- html-test/ref/Extensions.html | 4 +- html-test/ref/FunArgs.html | 4 +- html-test/ref/GADTRecords.html | 4 +- html-test/ref/Hash.html | 4 +- html-test/ref/HiddenInstances.html | 4 +- html-test/ref/HiddenInstancesB.html | 4 +- html-test/ref/Hyperlinks.html | 4 +- html-test/ref/IgnoreExports.html | 4 +- html-test/ref/ImplicitParams.html | 4 +- html-test/ref/Instances.html | 2 +- html-test/ref/Math.html | 4 +- html-test/ref/Minimal.html | 2 +- html-test/ref/ModuleWithWarning.html | 4 +- html-test/ref/NamedDoc.html | 4 +- html-test/ref/Nesting.html | 4 +- html-test/ref/NoLayout.html | 4 +- html-test/ref/NonGreedy.html | 4 +- html-test/ref/Operators.html | 2 +- html-test/ref/OrphanInstances.html | 4 +- html-test/ref/OrphanInstancesClass.html | 4 +- html-test/ref/OrphanInstancesType.html | 4 +- html-test/ref/PatternSyns.html | 2 +- html-test/ref/PromotedTypes.html | 4 +- html-test/ref/Properties.html | 4 +- html-test/ref/PruneWithWarning.html | 4 +- html-test/ref/QuasiExpr.html | 4 +- html-test/ref/QuasiQuote.html | 4 +- html-test/ref/SpuriousSuperclassConstraints.html | 2 +- html-test/ref/TH.html | 4 +- html-test/ref/TH2.html | 2 +- html-test/ref/Test.html | 4 +- html-test/ref/Threaded.html | 4 +- html-test/ref/Threaded_TH.html | 2 +- html-test/ref/Ticket112.html | 4 +- html-test/ref/Ticket61.html | 4 +- html-test/ref/Ticket75.html | 4 +- html-test/ref/TitledPicture.html | 4 +- html-test/ref/TypeFamilies.html | 4 +- html-test/ref/TypeFamilies2.html | 4 +- html-test/ref/TypeOperators.html | 4 +- html-test/ref/Unicode.html | 4 +- html-test/ref/Visible.html | 4 +- html-test/ref/haddock-util.js | 132 +-------------------- 86 files changed, 174 insertions(+), 493 deletions(-) (limited to 'haddock-api') diff --git a/haddock-api/resources/html/Ocean.std-theme/ocean.css b/haddock-api/resources/html/Ocean.std-theme/ocean.css index 9d2c644f..3bfc8982 100644 --- a/haddock-api/resources/html/Ocean.std-theme/ocean.css +++ b/haddock-api/resources/html/Ocean.std-theme/ocean.css @@ -327,10 +327,6 @@ div#style-menu-holder { } #synopsis { - display: none; -} - -.no-frame #synopsis { display: block; position: fixed; right: 0; diff --git a/haddock-api/resources/html/haddock-util.js b/haddock-api/resources/html/haddock-util.js index 92d07d2a..05bdaef5 100644 --- a/haddock-api/resources/html/haddock-util.js +++ b/haddock-api/resources/html/haddock-util.js @@ -1,7 +1,7 @@ // Haddock JavaScript utilities var rspace = /\s\s+/g, - rtrim = /^\s+|\s+$/g; + rtrim = /^\s+|\s+$/g; function spaced(s) { return (" " + s + " ").replace(rspace, " "); } function trim(s) { return s.replace(rtrim, ""); } @@ -109,136 +109,6 @@ function getCookie(name) { return null; } - - -var max_results = 75; // 50 is not enough to search for map in the base libraries -var shown_range = null; -var last_search = null; - -function quick_search() -{ - perform_search(false); -} - -function full_search() -{ - perform_search(true); -} - - -function perform_search(full) -{ - var text = document.getElementById("searchbox").value.toLowerCase(); - if (text == last_search && !full) return; - last_search = text; - - var table = document.getElementById("indexlist"); - var status = document.getElementById("searchmsg"); - var children = table.firstChild.childNodes; - - // first figure out the first node with the prefix - var first = bisect(-1); - var last = (first == -1 ? -1 : bisect(1)); - - if (first == -1) - { - table.className = ""; - status.innerHTML = "No results found, displaying all"; - } - else if (first == 0 && last == children.length - 1) - { - table.className = ""; - status.innerHTML = ""; - } - else if (last - first >= max_results && !full) - { - table.className = ""; - status.innerHTML = "More than " + max_results + ", press Search to display"; - } - else - { - // decide what you need to clear/show - if (shown_range) - setclass(shown_range[0], shown_range[1], "indexrow"); - setclass(first, last, "indexshow"); - shown_range = [first, last]; - table.className = "indexsearch"; - status.innerHTML = ""; - } - - - function setclass(first, last, status) - { - for (var i = first; i <= last; i++) - { - children[i].className = status; - } - } - - - // do a binary search, treating 0 as ... - // return either -1 (no 0's found) or location of most far match - function bisect(dir) - { - var first = 0, finish = children.length - 1; - var mid, success = false; - - while (finish - first > 3) - { - mid = Math.floor((finish + first) / 2); - - var i = checkitem(mid); - if (i == 0) i = dir; - if (i == -1) - finish = mid; - else - first = mid; - } - var a = (dir == 1 ? first : finish); - var b = (dir == 1 ? finish : first); - for (var i = b; i != a - dir; i -= dir) - { - if (checkitem(i) == 0) return i; - } - return -1; - } - - - // from an index, decide what the result is - // 0 = match, -1 is lower, 1 is higher - function checkitem(i) - { - var s = getitem(i).toLowerCase().substr(0, text.length); - if (s == text) return 0; - else return (s > text ? -1 : 1); - } - - - // from an index, get its string - // this abstracts over alternates - function getitem(i) - { - for ( ; i >= 0; i--) - { - var s = children[i].firstChild.firstChild.data; - if (s.indexOf(' ') == -1) - return s; - } - return ""; // should never be reached - } -} - -function setSynopsis(filename) { - if (parent.window.synopsis && parent.window.synopsis.location) { - if (parent.window.synopsis.location.replace) { - // In Firefox this avoids adding the change to the history. - parent.window.synopsis.location.replace(filename); - } else { - parent.window.synopsis.location = filename; - } - } -} - function addMenuItem(html) { var menu = document.getElementById("page-menu"); if (menu) { diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 31a748cb..34ecc5b8 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -108,8 +108,8 @@ copyHtmlBits odir libdir themes = do return () -headHtml :: String -> Maybe String -> Themes -> Maybe String -> Html -headHtml docTitle miniPage themes mathjax_url = +headHtml :: String -> Themes -> Maybe String -> Html +headHtml docTitle themes mathjax_url = header << [ meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"], thetitle << docTitle, @@ -118,14 +118,11 @@ headHtml docTitle miniPage themes mathjax_url = script ! [src mjUrl, thetype "text/javascript"] << noHtml, script ! [thetype "text/javascript"] -- NB: Within XHTML, the content of script tags needs to be - -- a " in it! - << primHtml ( - "//\n") + -- a \n" ] where - setSynopsis = maybe "" (\p -> "setSynopsis(\"" ++ p ++ "\");") miniPage mjUrl = maybe "https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" id mathjax_url @@ -271,7 +268,7 @@ ppHtmlContents dflags odir doctitle _maybe_package | iface <- ifaces , instIsSig iface] html = - headHtml doctitle Nothing themes mathjax_url +++ + headHtml doctitle themes mathjax_url +++ bodyHtml doctitle Nothing maybe_source_url maybe_wiki_url Nothing maybe_index_url << [ @@ -372,7 +369,7 @@ ppHtmlIndex odir doctitle _maybe_package themes where indexPage showLetters ch items = - headHtml (doctitle ++ " (" ++ indexName ch ++ ")") Nothing themes maybe_mathjax_url +++ + headHtml (doctitle ++ " (" ++ indexName ch ++ ")") themes maybe_mathjax_url +++ bodyHtml doctitle Nothing maybe_source_url maybe_wiki_url maybe_contents_url Nothing << [ @@ -494,7 +491,7 @@ ppHtmlModule odir doctitle themes = toHtml mdl_str real_qual = makeModuleQual qual aliases mdl html = - headHtml mdl_str_annot (Just $ "mini_" ++ moduleHtmlFile mdl) themes maybe_mathjax_url +++ + headHtml mdl_str_annot themes maybe_mathjax_url +++ bodyHtml doctitle (Just iface) maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url << [ @@ -504,24 +501,10 @@ ppHtmlModule odir doctitle themes createDirectoryIfMissing True odir writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html) - ppHtmlModuleMiniSynopsis odir doctitle themes maybe_mathjax_url iface unicode real_qual debug signatureDocURL :: String signatureDocURL = "https://wiki.haskell.org/Module_signature" -ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes - -> Maybe String -> Interface -> Bool -> Qualification -> Bool -> IO () -ppHtmlModuleMiniSynopsis odir _doctitle themes maybe_mathjax_url iface unicode qual debug = do - let mdl = ifaceMod iface - html = - headHtml (moduleString mdl) Nothing themes maybe_mathjax_url +++ - miniBody << - (divModuleHeader << sectionName << moduleString mdl +++ - miniSynopsis mdl iface unicode qual) - createDirectoryIfMissing True odir - writeFile (joinPath [odir, "mini_" ++ moduleHtmlFile mdl]) (renderToString debug html) - - ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Qualification -> Html ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual = ppModuleContents qual exports (not . null $ ifaceRnOrphanInstances iface) +++ @@ -572,43 +555,6 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual linksInfo = (maybe_source_url, maybe_wiki_url) -miniSynopsis :: Module -> Interface -> Bool -> Qualification -> Html -miniSynopsis mdl iface unicode qual = - divInterface << concatMap (processForMiniSynopsis mdl unicode qual) exports - where - exports = numberSectionHeadings (ifaceRnExportItems iface) - - -processForMiniSynopsis :: Module -> Bool -> Qualification -> ExportItem DocName - -> [Html] -processForMiniSynopsis mdl unicode qual ExportDecl { expItemDecl = L _loc decl0 } = - ((divTopDecl <<).(declElem <<)) <$> case decl0 of - TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of - (FamDecl decl) -> [ppTyFamHeader True False decl unicode qual] - (DataDecl{}) -> [keyword "data" <+> b] - (SynDecl{}) -> [keyword "type" <+> b] - (ClassDecl {}) -> [keyword "class" <+> b] - SigD (TypeSig lnames _) -> - map (ppNameMini Prefix mdl . nameOccName . getName . unLoc) lnames - _ -> [] -processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) = - [groupTag lvl << docToHtml Nothing qual (mkMeta txt)] -processForMiniSynopsis _ _ _ _ = [] - - -ppNameMini :: Notation -> Module -> OccName -> Html -ppNameMini notation mdl nm = - anchor ! [ href (moduleNameUrl mdl nm) - , target mainFrameName ] - << ppBinder' notation nm - - -ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html -ppTyClBinderWithVarsMini mdl decl = - let n = tcdName decl - ns = tyvarNames $ tcdTyVars decl -- it's safe to use tcdTyVars, see code above - in ppTypeApp n [] ns (\is_infix -> ppNameMini is_infix mdl . nameOccName . getName) ppTyName - ppModuleContents :: Qualification -> [ExportItem DocName] -> Bool -- ^ Orphans sections diff --git a/html-test/ref/A.html b/html-test/ref/A.html index 64a2916b..edd95fe8 100644 --- a/html-test/ref/A.html +++ b/html-test/ref/A.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/B.html b/html-test/ref/B.html index b1e43a51..f4ce89d4 100644 --- a/html-test/ref/B.html +++ b/html-test/ref/B.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bold.html b/html-test/ref/Bold.html index d8f8b3d4..a7cb4e7f 100644 --- a/html-test/ref/Bold.html +++ b/html-test/ref/Bold.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug1.html b/html-test/ref/Bug1.html index 5ea4ff26..37a37527 100644 --- a/html-test/ref/Bug1.html +++ b/html-test/ref/Bug1.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug195.html b/html-test/ref/Bug195.html index b7f10741..ca5c2cc0 100644 --- a/html-test/ref/Bug195.html +++ b/html-test/ref/Bug195.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug2.html b/html-test/ref/Bug2.html index 98d7f06d..5b88feae 100644 --- a/html-test/ref/Bug2.html +++ b/html-test/ref/Bug2.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug201.html b/html-test/ref/Bug201.html index 19cb1aae..04cb0991 100644 --- a/html-test/ref/Bug201.html +++ b/html-test/ref/Bug201.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug253.html b/html-test/ref/Bug253.html index 2210b023..28482b24 100644 --- a/html-test/ref/Bug253.html +++ b/html-test/ref/Bug253.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug26.html b/html-test/ref/Bug26.html index 9382a738..8b0644aa 100644 --- a/html-test/ref/Bug26.html +++ b/html-test/ref/Bug26.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug280.html b/html-test/ref/Bug280.html index fa8ca0de..6c533a28 100644 --- a/html-test/ref/Bug280.html +++ b/html-test/ref/Bug280.html @@ -1,4 +1,3 @@ -

 

CopyrightFoo
Bar
BazBar
Baz

Description

The module description

The module description

+> \ No newline at end of file diff --git a/html-test/ref/Bug294.html b/html-test/ref/Bug294.html index 44aad9d1..3a82af80 100644 --- a/html-test/ref/Bug294.html +++ b/html-test/ref/Bug294.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug298.html b/html-test/ref/Bug298.html index a748e92a..cba626b6 100644 --- a/html-test/ref/Bug298.html +++ b/html-test/ref/Bug298.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug3.html b/html-test/ref/Bug3.html index d5f589ed..4a9cf8bc 100644 --- a/html-test/ref/Bug3.html +++ b/html-test/ref/Bug3.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug308.html b/html-test/ref/Bug308.html index 03f287d5..d816fef5 100644 --- a/html-test/ref/Bug308.html +++ b/html-test/ref/Bug308.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug308CrossModule.html b/html-test/ref/Bug308CrossModule.html index d9ed0b19..60f371af 100644 --- a/html-test/ref/Bug308CrossModule.html +++ b/html-test/ref/Bug308CrossModule.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug310.html b/html-test/ref/Bug310.html index 2ba8dfb9..468e64eb 100644 --- a/html-test/ref/Bug310.html +++ b/html-test/ref/Bug310.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug313.html b/html-test/ref/Bug313.html index a6573eaa..4fc1682c 100644 --- a/html-test/ref/Bug313.html +++ b/html-test/ref/Bug313.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug335.html b/html-test/ref/Bug335.html index f9eec481..d1602c7b 100644 --- a/html-test/ref/Bug335.html +++ b/html-test/ref/Bug335.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug387.html b/html-test/ref/Bug387.html index 6305a38d..27d47e75 100644 --- a/html-test/ref/Bug387.html +++ b/html-test/ref/Bug387.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug4.html b/html-test/ref/Bug4.html index 722d4102..fe6f47d1 100644 --- a/html-test/ref/Bug4.html +++ b/html-test/ref/Bug4.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug6.html b/html-test/ref/Bug6.html index 34fc4054..678f4070 100644 --- a/html-test/ref/Bug6.html +++ b/html-test/ref/Bug6.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug7.html b/html-test/ref/Bug7.html index cf6f2f2a..ef26d62f 100644 --- a/html-test/ref/Bug7.html +++ b/html-test/ref/Bug7.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug8.html b/html-test/ref/Bug8.html index d6cef1b2..1b6c1525 100644 --- a/html-test/ref/Bug8.html +++ b/html-test/ref/Bug8.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/BugDeprecated.html b/html-test/ref/BugDeprecated.html index 2fb509d8..96fdab34 100644 --- a/html-test/ref/BugDeprecated.html +++ b/html-test/ref/BugDeprecated.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/BugExportHeadings.html b/html-test/ref/BugExportHeadings.html index 8d444e26..2a05bed9 100644 --- a/html-test/ref/BugExportHeadings.html +++ b/html-test/ref/BugExportHeadings.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bugs.html b/html-test/ref/Bugs.html index b83036c8..c29004f3 100644 --- a/html-test/ref/Bugs.html +++ b/html-test/ref/Bugs.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/DeprecatedClass.html b/html-test/ref/DeprecatedClass.html index ac14b0d4..f055f36f 100644 --- a/html-test/ref/DeprecatedClass.html +++ b/html-test/ref/DeprecatedClass.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/DeprecatedData.html b/html-test/ref/DeprecatedData.html index 248de4cb..aeb2a7c8 100644 --- a/html-test/ref/DeprecatedData.html +++ b/html-test/ref/DeprecatedData.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/DeprecatedFunction.html b/html-test/ref/DeprecatedFunction.html index 59206ac9..f4381d96 100644 --- a/html-test/ref/DeprecatedFunction.html +++ b/html-test/ref/DeprecatedFunction.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/DeprecatedFunction2.html b/html-test/ref/DeprecatedFunction2.html index 36159359..b8985bcd 100644 --- a/html-test/ref/DeprecatedFunction2.html +++ b/html-test/ref/DeprecatedFunction2.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/DeprecatedFunction3.html b/html-test/ref/DeprecatedFunction3.html index 1bfc7d90..b62e1ee3 100644 --- a/html-test/ref/DeprecatedFunction3.html +++ b/html-test/ref/DeprecatedFunction3.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/DeprecatedModule.html b/html-test/ref/DeprecatedModule.html index a6b2e0e8..84c7a885 100644 --- a/html-test/ref/DeprecatedModule.html +++ b/html-test/ref/DeprecatedModule.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/DeprecatedModule2.html b/html-test/ref/DeprecatedModule2.html index bd7a7f31..862f79ee 100644 --- a/html-test/ref/DeprecatedModule2.html +++ b/html-test/ref/DeprecatedModule2.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/DeprecatedNewtype.html b/html-test/ref/DeprecatedNewtype.html index 3d826f57..a03d63fb 100644 --- a/html-test/ref/DeprecatedNewtype.html +++ b/html-test/ref/DeprecatedNewtype.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/DeprecatedReExport.html b/html-test/ref/DeprecatedReExport.html index e5a3c38c..52f2b8e9 100644 --- a/html-test/ref/DeprecatedReExport.html +++ b/html-test/ref/DeprecatedReExport.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/DeprecatedRecord.html b/html-test/ref/DeprecatedRecord.html index ff217c4d..79b7b7f9 100644 --- a/html-test/ref/DeprecatedRecord.html +++ b/html-test/ref/DeprecatedRecord.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/DeprecatedTypeFamily.html b/html-test/ref/DeprecatedTypeFamily.html index 4a5028f3..1d94e99b 100644 --- a/html-test/ref/DeprecatedTypeFamily.html +++ b/html-test/ref/DeprecatedTypeFamily.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/DeprecatedTypeSynonym.html b/html-test/ref/DeprecatedTypeSynonym.html index 8f1896df..cb7a3afe 100644 --- a/html-test/ref/DeprecatedTypeSynonym.html +++ b/html-test/ref/DeprecatedTypeSynonym.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Examples.html b/html-test/ref/Examples.html index 7f742f2f..f706eef1 100644 --- a/html-test/ref/Examples.html +++ b/html-test/ref/Examples.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Extensions.html b/html-test/ref/Extensions.html index 01dde2d3..e21785c0 100644 --- a/html-test/ref/Extensions.html +++ b/html-test/ref/Extensions.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/FunArgs.html b/html-test/ref/FunArgs.html index 4c285c41..df597e12 100644 --- a/html-test/ref/FunArgs.html +++ b/html-test/ref/FunArgs.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/GADTRecords.html b/html-test/ref/GADTRecords.html index 6c091ac3..3b036aae 100644 --- a/html-test/ref/GADTRecords.html +++ b/html-test/ref/GADTRecords.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Hash.html b/html-test/ref/Hash.html index ac422955..4ad1c27e 100644 --- a/html-test/ref/Hash.html +++ b/html-test/ref/Hash.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/HiddenInstances.html b/html-test/ref/HiddenInstances.html index 5071e702..8c7312d7 100644 --- a/html-test/ref/HiddenInstances.html +++ b/html-test/ref/HiddenInstances.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/HiddenInstancesB.html b/html-test/ref/HiddenInstancesB.html index b3cf9ef9..77af69d0 100644 --- a/html-test/ref/HiddenInstancesB.html +++ b/html-test/ref/HiddenInstancesB.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Hyperlinks.html b/html-test/ref/Hyperlinks.html index 66b14d7a..db1953e3 100644 --- a/html-test/ref/Hyperlinks.html +++ b/html-test/ref/Hyperlinks.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/IgnoreExports.html b/html-test/ref/IgnoreExports.html index 235d601c..262bb769 100644 --- a/html-test/ref/IgnoreExports.html +++ b/html-test/ref/IgnoreExports.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/ImplicitParams.html b/html-test/ref/ImplicitParams.html index c08a565a..d22e7f4c 100644 --- a/html-test/ref/ImplicitParams.html +++ b/html-test/ref/ImplicitParams.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Instances.html b/html-test/ref/Instances.html index ba6ef185..b014e8df 100644 --- a/html-test/ref/Instances.html +++ b/html-test/ref/Instances.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Minimal.html b/html-test/ref/Minimal.html index ac28b0d9..b7507bd7 100644 --- a/html-test/ref/Minimal.html +++ b/html-test/ref/Minimal.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/NamedDoc.html b/html-test/ref/NamedDoc.html index 631f2043..a10aa305 100644 --- a/html-test/ref/NamedDoc.html +++ b/html-test/ref/NamedDoc.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Nesting.html b/html-test/ref/Nesting.html index 370c6a88..7ce0c0d8 100644 --- a/html-test/ref/Nesting.html +++ b/html-test/ref/Nesting.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/NoLayout.html b/html-test/ref/NoLayout.html index d8148b0e..43352864 100644 --- a/html-test/ref/NoLayout.html +++ b/html-test/ref/NoLayout.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/NonGreedy.html b/html-test/ref/NonGreedy.html index c389fc6a..6ed1563f 100644 --- a/html-test/ref/NonGreedy.html +++ b/html-test/ref/NonGreedy.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Operators.html b/html-test/ref/Operators.html index 27b3427d..d498a906 100644 --- a/html-test/ref/Operators.html +++ b/html-test/ref/Operators.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/OrphanInstancesClass.html b/html-test/ref/OrphanInstancesClass.html index 98641d0b..93594d90 100644 --- a/html-test/ref/OrphanInstancesClass.html +++ b/html-test/ref/OrphanInstancesClass.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/OrphanInstancesType.html b/html-test/ref/OrphanInstancesType.html index d616edf9..5d7a76c9 100644 --- a/html-test/ref/OrphanInstancesType.html +++ b/html-test/ref/OrphanInstancesType.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/PatternSyns.html b/html-test/ref/PatternSyns.html index 2052d87c..9f0caaa2 100644 --- a/html-test/ref/PatternSyns.html +++ b/html-test/ref/PatternSyns.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Properties.html b/html-test/ref/Properties.html index 27f3a93a..4ce37acd 100644 --- a/html-test/ref/Properties.html +++ b/html-test/ref/Properties.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/PruneWithWarning.html b/html-test/ref/PruneWithWarning.html index 7523c657..e714ec21 100644 --- a/html-test/ref/PruneWithWarning.html +++ b/html-test/ref/PruneWithWarning.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/QuasiExpr.html b/html-test/ref/QuasiExpr.html index c51ac526..0b5b8054 100644 --- a/html-test/ref/QuasiExpr.html +++ b/html-test/ref/QuasiExpr.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/QuasiQuote.html b/html-test/ref/QuasiQuote.html index 251c48dc..4919e48d 100644 --- a/html-test/ref/QuasiQuote.html +++ b/html-test/ref/QuasiQuote.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/SpuriousSuperclassConstraints.html b/html-test/ref/SpuriousSuperclassConstraints.html index 285ab05c..b7c707c5 100644 --- a/html-test/ref/SpuriousSuperclassConstraints.html +++ b/html-test/ref/SpuriousSuperclassConstraints.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/TH2.html b/html-test/ref/TH2.html index 71bc1083..5562cb67 100644 --- a/html-test/ref/TH2.html +++ b/html-test/ref/TH2.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Threaded.html b/html-test/ref/Threaded.html index bb31f300..ac6a66b9 100644 --- a/html-test/ref/Threaded.html +++ b/html-test/ref/Threaded.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Threaded_TH.html b/html-test/ref/Threaded_TH.html index 2890ca6b..89f276c9 100644 --- a/html-test/ref/Threaded_TH.html +++ b/html-test/ref/Threaded_TH.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Ticket61.html b/html-test/ref/Ticket61.html index cb9ba8bd..cfc2e7f7 100644 --- a/html-test/ref/Ticket61.html +++ b/html-test/ref/Ticket61.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Ticket75.html b/html-test/ref/Ticket75.html index 07e75296..616f5d47 100644 --- a/html-test/ref/Ticket75.html +++ b/html-test/ref/Ticket75.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/TitledPicture.html b/html-test/ref/TitledPicture.html index 04d1476b..927631f8 100644 --- a/html-test/ref/TitledPicture.html +++ b/html-test/ref/TitledPicture.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/TypeFamilies.html b/html-test/ref/TypeFamilies.html index db6ee1c3..c6301a56 100644 --- a/html-test/ref/TypeFamilies.html +++ b/html-test/ref/TypeFamilies.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/TypeFamilies2.html b/html-test/ref/TypeFamilies2.html index 156486d0..65ab0317 100644 --- a/html-test/ref/TypeFamilies2.html +++ b/html-test/ref/TypeFamilies2.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/TypeOperators.html b/html-test/ref/TypeOperators.html index 53428892..b461ac71 100644 --- a/html-test/ref/TypeOperators.html +++ b/html-test/ref/TypeOperators.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Unicode.html b/html-test/ref/Unicode.html index 59f715e8..ae1d4293 100644 --- a/html-test/ref/Unicode.html +++ b/html-test/ref/Unicode.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Visible.html b/html-test/ref/Visible.html index 47568b65..d9b8cd11 100644 --- a/html-test/ref/Visible.html +++ b/html-test/ref/Visible.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/haddock-util.js b/html-test/ref/haddock-util.js index 92d07d2a..05bdaef5 100644 --- a/html-test/ref/haddock-util.js +++ b/html-test/ref/haddock-util.js @@ -1,7 +1,7 @@ // Haddock JavaScript utilities var rspace = /\s\s+/g, - rtrim = /^\s+|\s+$/g; + rtrim = /^\s+|\s+$/g; function spaced(s) { return (" " + s + " ").replace(rspace, " "); } function trim(s) { return s.replace(rtrim, ""); } @@ -109,136 +109,6 @@ function getCookie(name) { return null; } - - -var max_results = 75; // 50 is not enough to search for map in the base libraries -var shown_range = null; -var last_search = null; - -function quick_search() -{ - perform_search(false); -} - -function full_search() -{ - perform_search(true); -} - - -function perform_search(full) -{ - var text = document.getElementById("searchbox").value.toLowerCase(); - if (text == last_search && !full) return; - last_search = text; - - var table = document.getElementById("indexlist"); - var status = document.getElementById("searchmsg"); - var children = table.firstChild.childNodes; - - // first figure out the first node with the prefix - var first = bisect(-1); - var last = (first == -1 ? -1 : bisect(1)); - - if (first == -1) - { - table.className = ""; - status.innerHTML = "No results found, displaying all"; - } - else if (first == 0 && last == children.length - 1) - { - table.className = ""; - status.innerHTML = ""; - } - else if (last - first >= max_results && !full) - { - table.className = ""; - status.innerHTML = "More than " + max_results + ", press Search to display"; - } - else - { - // decide what you need to clear/show - if (shown_range) - setclass(shown_range[0], shown_range[1], "indexrow"); - setclass(first, last, "indexshow"); - shown_range = [first, last]; - table.className = "indexsearch"; - status.innerHTML = ""; - } - - - function setclass(first, last, status) - { - for (var i = first; i <= last; i++) - { - children[i].className = status; - } - } - - - // do a binary search, treating 0 as ... - // return either -1 (no 0's found) or location of most far match - function bisect(dir) - { - var first = 0, finish = children.length - 1; - var mid, success = false; - - while (finish - first > 3) - { - mid = Math.floor((finish + first) / 2); - - var i = checkitem(mid); - if (i == 0) i = dir; - if (i == -1) - finish = mid; - else - first = mid; - } - var a = (dir == 1 ? first : finish); - var b = (dir == 1 ? finish : first); - for (var i = b; i != a - dir; i -= dir) - { - if (checkitem(i) == 0) return i; - } - return -1; - } - - - // from an index, decide what the result is - // 0 = match, -1 is lower, 1 is higher - function checkitem(i) - { - var s = getitem(i).toLowerCase().substr(0, text.length); - if (s == text) return 0; - else return (s > text ? -1 : 1); - } - - - // from an index, get its string - // this abstracts over alternates - function getitem(i) - { - for ( ; i >= 0; i--) - { - var s = children[i].firstChild.firstChild.data; - if (s.indexOf(' ') == -1) - return s; - } - return ""; // should never be reached - } -} - -function setSynopsis(filename) { - if (parent.window.synopsis && parent.window.synopsis.location) { - if (parent.window.synopsis.location.replace) { - // In Firefox this avoids adding the change to the history. - parent.window.synopsis.location.replace(filename); - } else { - parent.window.synopsis.location = filename; - } - } -} - function addMenuItem(html) { var menu = document.getElementById("page-menu"); if (menu) { -- cgit v1.2.3 From 67d6345e7b941008080ea79ea462229f0f377d50 Mon Sep 17 00:00:00 2001 From: Alex Biehl Date: Wed, 26 Apr 2017 07:49:10 +0200 Subject: Cherry-picked remaining commits from haddock-2.17.4-release (#603) * Release haddock/haddock-api 2.17.4 and haddock-library 1.4.3 * Set version bounds for haddock-library NB: This allows GHC 8.2.1's base * Set version bounds for haddock & haddock-api The version bounds support GHC 8.2 * Merge (temporary) v2.17.3 branch into v2.17 This allows us to delete the v2.17.3 branch * Fixup changelog * Pin down haddock-api to a single version as otherwise `haddock`'s package version has no proper meaning * fix source-repo spec for haddock-api --- CHANGES | 14 ++++++++++++ haddock-api/haddock-api.cabal | 42 ++++++++++++++++++----------------- haddock-api/src/Haddock/Types.hs | 4 ++-- haddock-library/haddock-library.cabal | 10 ++++----- haddock.cabal | 7 ++++-- 5 files changed, 48 insertions(+), 29 deletions(-) (limited to 'haddock-api') diff --git a/CHANGES b/CHANGES index 4389c58a..7e3d052a 100644 --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,17 @@ +Changes in version 2.17.4 + + * Fix 'internal error: links: UnhelpfulSpan' (#554, #565) + + * Hyperlink backend knows about `DataKinds` (#510) + + * Fix rendering of class methods for `Eq` and `Ord` (#549) + + * Export `MDoc` and `toInstalledIface` from `Haddock.Types` + +Changes in version 2.17.3.1 + + * Disable `NFData` instances for GHC types when GHC >= 8.0.2 (#537) + Changes in version 2.17.3 * Remove framed view of the HTML documentation diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 921e16eb..20b656b9 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -1,5 +1,5 @@ name: haddock-api -version: 2.17.3 +version: 2.17.4 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries @@ -33,28 +33,29 @@ data-files: latex/haddock.sty library - default-language: - Haskell2010 + default-language: Haskell2010 - build-depends: - base >= 4.3 && < 4.11 - , bytestring - , filepath - , directory - , containers - , transformers - , deepseq - , array - , xhtml >= 3000.2 && < 3000.3 - , Cabal >= 1.10 - , ghc-boot - , ghc == 8.2.* + -- this package typically supports only single major versions + build-depends: base == 4.10.* + , Cabal == 2.0.* + , ghc == 8.2.* + , ghc-paths == 0.1.* + , haddock-library >= 1.4.2 && < 1.5 + , xhtml == 3000.2.* - , ghc-paths - , haddock-library == 1.4.* + -- Versions for the dependencies below are transitively pinned by + -- the non-reinstallable `ghc` package and hence need no version + -- bounds + build-depends: array + , bytestring + , containers + , deepseq + , directory + , filepath + , ghc-boot + , transformers - hs-source-dirs: - src + hs-source-dirs: src ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 @@ -125,4 +126,5 @@ test-suite spec source-repository head type: git + subdir: haddock-api location: https://github.com/haskell/haddock.git diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index a6dd6354..803995cc 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -460,8 +460,8 @@ instance (NFData a, NFData mod) DocExamples a -> a `deepseq` () DocHeader a -> a `deepseq` () -#if __GLASGOW_HASKELL__ < 801 --- These were added to GHC itself in 8.2.1 +#if !MIN_VERSION_ghc(8,0,2) +-- These were added to GHC itself in 8.0.2 instance NFData Name where rnf x = seq x () instance NFData OccName where rnf x = seq x () instance NFData ModuleName where rnf x = seq x () diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index b7a20758..be433e6a 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -1,5 +1,5 @@ name: haddock-library -version: 1.4.2 +version: 1.4.3 synopsis: Library exposing some functionality of Haddock. description: Haddock is a documentation-generation tool for Haskell libraries. These modules expose some functionality of it @@ -21,10 +21,10 @@ library default-language: Haskell2010 build-depends: - base >= 4.5 && < 4.11 - , bytestring - , transformers - , deepseq + base >= 4.5 && < 4.11 + , bytestring >= 0.9.2.1 && < 0.11 + , transformers >= 0.3.0 && < 0.6 + , deepseq >= 1.3 && < 1.5 hs-source-dirs: src, vendor/attoparsec-0.12.1.1 ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 diff --git a/haddock.cabal b/haddock.cabal index fa8a3531..598f2b9a 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -1,5 +1,5 @@ name: haddock -version: 2.17.3 +version: 2.17.4 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries @@ -43,6 +43,7 @@ executable haddock hs-source-dirs: driver ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 -threaded + -- haddock typically only supports a single GHC major version build-depends: base >= 4.3 && < 4.11 if flag(in-ghc-tree) @@ -120,7 +121,9 @@ executable haddock Haddock.Syb Haddock.Convert else - build-depends: haddock-api == 2.17.* + -- in order for haddock's advertised version number to have proper meaning, + -- we pin down to a single haddock-api version. + build-depends: haddock-api == 2.17.4 test-suite driver-test type: exitcode-stdio-1.0 -- cgit v1.2.3 From 7ec72d3ad81657f5a5298ac1465229fa7cafb35c Mon Sep 17 00:00:00 2001 From: Alex Biehl Date: Wed, 26 Apr 2017 11:32:33 +0200 Subject: Bump to 2.18.0 (#605) --- CHANGES.md | 2 +- haddock-api/haddock-api.cabal | 2 +- haddock.cabal | 6 +++--- 3 files changed, 5 insertions(+), 5 deletions(-) (limited to 'haddock-api') diff --git a/CHANGES.md b/CHANGES.md index 351d1293..6c2b5d32 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,4 +1,4 @@ -## Changes in version HEAD +## Changes in version 2.18.0 * Synopsis is working again (#599) diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 20b656b9..15215cdb 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -1,5 +1,5 @@ name: haddock-api -version: 2.17.4 +version: 2.18.0 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries diff --git a/haddock.cabal b/haddock.cabal index 935d517f..160316e9 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -1,5 +1,5 @@ name: haddock -version: 2.17.4 +version: 2.18.0 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries @@ -15,7 +15,7 @@ build-type: Simple cabal-version: >= 2.0 stability: experimental tested-with: GHC==8.2.*, GHC==8.3 - + extra-source-files: CHANGES.md README.md @@ -123,7 +123,7 @@ executable haddock else -- in order for haddock's advertised version number to have proper meaning, -- we pin down to a single haddock-api version. - build-depends: haddock-api == 2.17.4 + build-depends: haddock-api == 2.18.0 test-suite driver-test type: exitcode-stdio-1.0 -- cgit v1.2.3 From 393920f125d1870c4fec5a09a5ac2dddc8da746b Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Sun, 30 Oct 2016 17:39:50 +0200 Subject: Improve error message --- haddock-api/src/Haddock.hs | 2 +- html-test/ref/SpuriousSuperclassConstraints.html | 4 ++-- html-test/src/SpuriousSuperclassConstraints.hs | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) (limited to 'haddock-api') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index dec85b79..3971a5b7 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -489,7 +489,7 @@ shortcutFlags flags = do when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) && Flag_Html `elem` flags) $ - throwE "-h cannot be used with --gen-index or --gen-contents" + throwE "-h/--html cannot be used with --gen-index or --gen-contents" when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) && Flag_Hoogle `elem` flags) $ diff --git a/html-test/ref/SpuriousSuperclassConstraints.html b/html-test/ref/SpuriousSuperclassConstraints.html index b7c707c5..0f38d15c 100644 --- a/html-test/ref/SpuriousSuperclassConstraints.html +++ b/html-test/ref/SpuriousSuperclassConstraints.html @@ -56,7 +56,7 @@ window.onload = function () {pageLoad();}; >http://www.haskell.org/pipermail/haskell-cafe/2012-September/103600.html

And here is the corresponding theard on glasgow-haskell-users:

And here is the corresponding thread on glasgow-haskell-users:

http://www.haskell.org/pipermail/glasgow-haskell-users/2012-September/022914.html \ No newline at end of file +> diff --git a/html-test/src/SpuriousSuperclassConstraints.hs b/html-test/src/SpuriousSuperclassConstraints.hs index d9e43e1c..3e230945 100644 --- a/html-test/src/SpuriousSuperclassConstraints.hs +++ b/html-test/src/SpuriousSuperclassConstraints.hs @@ -7,7 +7,7 @@ -- -- -- --- And here is the corresponding theard on glasgow-haskell-users: +-- And here is the corresponding thread on glasgow-haskell-users: -- -- -- -- cgit v1.2.3 From 02787004ffeb16c9d848b77b6e23598b58596348 Mon Sep 17 00:00:00 2001 From: Alex Biehl Date: Sun, 30 Apr 2017 10:07:46 +0200 Subject: Correctly remember collapsed sections (#608) Now the "collapsed" cookie stores which sections have changed state instead of which are collapsed. --- haddock-api/resources/html/haddock-util.js | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'haddock-api') diff --git a/haddock-api/resources/html/haddock-util.js b/haddock-api/resources/html/haddock-util.js index 05bdaef5..967e2026 100644 --- a/haddock-api/resources/html/haddock-util.js +++ b/haddock-api/resources/html/haddock-util.js @@ -52,17 +52,17 @@ function toggleSection(id) { var b = toggleShow(document.getElementById("section." + id)); toggleCollapser(document.getElementById("control." + id), b); - rememberCollapsed(id, b); + rememberCollapsed(id); return b; } var collapsed = {}; -function rememberCollapsed(id, b) +function rememberCollapsed(id) { - if(b) + if(collapsed[id]) delete collapsed[id] else - collapsed[id] = null; + collapsed[id] = true; var sections = []; for(var i in collapsed) -- cgit v1.2.3 From 2163981e773b76212b2265a1eb03208ee2e7edf2 Mon Sep 17 00:00:00 2001 From: Alex Biehl Date: Mon, 1 May 2017 17:40:36 +0200 Subject: Lazily decode docMap and argMap (#610) These are only used in case of a doc reexport so most of the time decoding these is wasted work. --- haddock-api/src/Haddock/InterfaceFile.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'haddock-api') diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index 78853a79..3365581f 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -83,7 +83,7 @@ binaryInterfaceMagic = 0xD0Cface -- binaryInterfaceVersion :: Word16 #if (__GLASGOW_HASKELL__ >= 802) && (__GLASGOW_HASKELL__ < 804) -binaryInterfaceVersion = 29 +binaryInterfaceVersion = 30 binaryInterfaceVersionCompatibility :: [Word16] binaryInterfaceVersionCompatibility = [binaryInterfaceVersion] @@ -377,6 +377,7 @@ instance Binary InstalledInterface where put_ bh modu put_ bh is_sig put_ bh info + lazyPut bh (docMap, argMap) put_ bh docMap put_ bh argMap put_ bh exps @@ -389,8 +390,7 @@ instance Binary InstalledInterface where modu <- get bh is_sig <- get bh info <- get bh - docMap <- get bh - argMap <- get bh + ~(docMap, argMap) <- lazyGet bh exps <- get bh visExps <- get bh opts <- get bh -- cgit v1.2.3 From e0e6615dd421f1b332ce2b11a98de768fa7c29a8 Mon Sep 17 00:00:00 2001 From: Alex Biehl Date: Mon, 1 May 2017 21:59:23 +0200 Subject: Fix Binary instance for InstalledInterface (#611) (#610) introduced lazy decoding for docs from InstalledInterface but forgot to remove the original calls to get and put_ --- haddock-api/src/Haddock/InterfaceFile.hs | 2 -- 1 file changed, 2 deletions(-) (limited to 'haddock-api') diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index 3365581f..e5c2face 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -378,8 +378,6 @@ instance Binary InstalledInterface where put_ bh is_sig put_ bh info lazyPut bh (docMap, argMap) - put_ bh docMap - put_ bh argMap put_ bh exps put_ bh visExps put_ bh opts -- cgit v1.2.3 From b35eed2a9f1c82131f51f55c771ac2372127520d Mon Sep 17 00:00:00 2001 From: Alex Biehl Date: Fri, 12 May 2017 21:02:33 +0200 Subject: Haddock: Fix broken lazy IO in prologue reading (#615) We previously used withFile in conjunction with hGetContents. The list returned by the latter wasn't completely forced by the time we left the withFile block, meaning that we would try to read from a closed handle. --- haddock-api/src/Haddock.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'haddock-api') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 3971a5b7..f0e7e6c7 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -547,9 +547,10 @@ getPrologue :: DynFlags -> [Flag] -> IO (Maybe (MDoc RdrName)) getPrologue dflags flags = case [filename | Flag_Prologue filename <- flags ] of [] -> return Nothing - [filename] -> withFile filename ReadMode $ \h -> do + [filename] -> do + h <- openFile filename ReadMode hSetEncoding h utf8 - str <- hGetContents h + str <- hGetContents h -- semi-closes the handle return . Just $! parseParas dflags str _ -> throwE "multiple -p/--prologue options" -- cgit v1.2.3 From 506f614402192bd7b6a9a608e925a01b373b2bdc Mon Sep 17 00:00:00 2001 From: Doug Wilson Date: Sun, 28 May 2017 05:54:53 +1200 Subject: Improve Syb code (#621) Specialize.hs and Ast.hs are modified to have their Syb code not recurse into Name or Id in HsSyn types. Specialize.hs is refactored to have fewer calls to Syb functions. Syb.hs has some foldl calls replaced with foldl' calls. There is still a lot of performance on the floor of Ast.hs. The RenamedSource is traversed many times, and lookupBySpan is very inefficient. everywhereBut and lookupBySpan dominate the runtime whenever --hyperlinked-source is passed. --- .../src/Haddock/Backends/Hyperlinker/Ast.hs | 28 ++++++----- haddock-api/src/Haddock/Interface/Specialize.hs | 58 +++++++++------------- haddock-api/src/Haddock/Syb.hs | 55 +++++++++++++++++--- 3 files changed, 88 insertions(+), 53 deletions(-) (limited to 'haddock-api') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index b97f0ead..78beacf2 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -2,12 +2,12 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} - +{-# LANGUAGE TypeApplications #-} module Haddock.Backends.Hyperlinker.Ast (enrich) where -import Haddock.Syb +import qualified Haddock.Syb as Syb import Haddock.Backends.Hyperlinker.Types import qualified GHC @@ -16,6 +16,9 @@ import Control.Applicative import Data.Data import Data.Maybe +everythingInRenamedSource :: (Alternative f, Data x) + => (forall a. Data a => a -> f r) -> x -> f r +everythingInRenamedSource f = Syb.everythingButType @GHC.Name (<|>) f -- | Add more detailed information to token stream using GHC API. enrich :: GHC.RenamedSource -> [Token] -> [RichToken] @@ -53,7 +56,7 @@ enrichToken _ _ = Nothing -- | Obtain details map for variables ("normally" used identifiers). variables :: GHC.RenamedSource -> DetailsMap variables = - everything (<|>) (var `combine` rec) + everythingInRenamedSource (var `Syb.combine` rec) where var term = case cast term of (Just (GHC.L sspan (GHC.HsVar name))) -> @@ -68,8 +71,7 @@ variables = -- | Obtain details map for types. types :: GHC.RenamedSource -> DetailsMap -types = - everything (<|>) ty +types = everythingInRenamedSource ty where ty term = case cast term of (Just (GHC.L sspan (GHC.HsTyVar _ name))) -> @@ -81,9 +83,10 @@ types = -- That includes both identifiers bound by pattern matching or declared using -- ordinary assignment (in top-level declarations, let-expressions and where -- clauses). + binds :: GHC.RenamedSource -> DetailsMap -binds = - everything (<|>) (fun `combine` pat `combine` tvar) +binds = everythingInRenamedSource + (fun `Syb.combine` pat `Syb.combine` tvar) where fun term = case cast term of (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name)) -> @@ -93,7 +96,7 @@ binds = (Just (GHC.L sspan (GHC.VarPat name))) -> pure (sspan, RtkBind (GHC.unLoc name)) (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) -> - [(sspan, RtkVar name)] ++ everything (<|>) rec recs + [(sspan, RtkVar name)] ++ everythingInRenamedSource rec recs (Just (GHC.L _ (GHC.AsPat (GHC.L sspan name) _))) -> pure (sspan, RtkBind name) _ -> empty @@ -112,8 +115,8 @@ binds = decls :: GHC.RenamedSource -> DetailsMap decls (group, _, _, _) = concatMap ($ group) [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds - , everything (<|>) fun . GHC.hs_valds - , everything (<|>) (con `combine` ins) + , everythingInRenamedSource fun . GHC.hs_valds + , everythingInRenamedSource (con `Syb.combine` ins) ] where typ (GHC.L _ t) = case t of @@ -127,7 +130,8 @@ decls (group, _, _, _) = concatMap ($ group) _ -> empty con term = case cast term of (Just cdcl) -> - map decl (GHC.getConNames cdcl) ++ everything (<|>) fld cdcl + map decl (GHC.getConNames cdcl) + ++ everythingInRenamedSource fld cdcl Nothing -> empty ins term = case cast term of (Just (GHC.DataFamInstD inst)) -> pure . tyref $ GHC.dfid_tycon inst @@ -149,7 +153,7 @@ decls (group, _, _, _) = concatMap ($ group) -- import lists. imports :: GHC.RenamedSource -> DetailsMap imports src@(_, imps, _, _) = - everything (<|>) ie src ++ mapMaybe (imp . GHC.unLoc) imps + everythingInRenamedSource ie src ++ mapMaybe (imp . GHC.unLoc) imps where ie term = case cast term of (Just (GHC.IEVar v)) -> pure $ var $ GHC.ieLWrappedName v diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 28bbf305..8c28cd5a 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -1,9 +1,9 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE RecordWildCards #-} - module Haddock.Interface.Specialize ( specializeInstHead ) where @@ -27,73 +27,66 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set - - --- | Instantiate all occurrences of given name with particular type. -specialize :: (Eq name, Typeable name) - => Data a - => name -> HsType name -> a -> a -specialize name details = - everywhere $ mkT step - where - step (HsTyVar _ (L _ name')) | name == name' = details - step typ = typ - +import Data.Foldable -- | Instantiate all occurrences of given names with corresponding types. --- --- It is just a convenience function wrapping 'specialize' that supports more --- that one specialization. -specialize' :: (Eq name, Typeable name) +specialize :: forall name a. (Ord name, DataId name, NamedThing name) => Data a => [(name, HsType name)] -> a -> a -specialize' = flip $ foldr (uncurry specialize) +specialize specs = go + where + go :: forall x. Data x => x -> x + go = everywhereButType @name $ mkT $ sugar . specialize_ty_var + specialize_ty_var (HsTyVar _ (L _ name')) + | Just t <- Map.lookup name' spec_map = t + specialize_ty_var typ = typ + -- This is a tricky recursive definition that is guaranteed to terminate + -- because a type binder cannot be instantiated with a type that depends + -- on that binder. i.e. @a -> Maybe a@ is invalid + spec_map = Map.fromList [ (n, go t) | (n, t) <- specs] -- | Instantiate given binders with corresponding types. -- -- Again, it is just a convenience function around 'specialize'. Note that -- length of type list should be the same as the number of binders. -specializeTyVarBndrs :: (Eq name, DataId name) +specializeTyVarBndrs :: (Ord name, DataId name, NamedThing name) => Data a => LHsQTyVars name -> [HsType name] -> a -> a specializeTyVarBndrs bndrs typs = - specialize' $ zip bndrs' typs + specialize $ zip bndrs' typs where bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs bname (UserTyVar (L _ name)) = name bname (KindedTyVar (L _ name) _) = name -specializePseudoFamilyDecl :: (Eq name, DataId name) +specializePseudoFamilyDecl :: (Ord name, DataId name, NamedThing name) => LHsQTyVars name -> [HsType name] -> PseudoFamilyDecl name -> PseudoFamilyDecl name specializePseudoFamilyDecl bndrs typs decl = - decl { pfdTyVars = map specializeTyVars (pfdTyVars decl) } - where - specializeTyVars = specializeTyVarBndrs bndrs typs - + decl {pfdTyVars = map (specializeTyVarBndrs bndrs typs) (pfdTyVars decl)} -specializeSig :: forall name . (Eq name, DataId name, SetName name) +specializeSig :: forall name . (Ord name, DataId name, SetName name, NamedThing name) => LHsQTyVars name -> [HsType name] -> Sig name -> Sig name specializeSig bndrs typs (TypeSig lnames typ) = - TypeSig lnames (typ { hswc_body = (hswc_body typ) { hsib_body = noLoc typ'}}) + TypeSig lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}}) where true_type :: HsType name true_type = unLoc (hsSigWcType typ) typ' :: HsType name - typ' = rename fv . sugar $ specializeTyVarBndrs bndrs typs true_type + typ' = rename fv $ specializeTyVarBndrs bndrs typs true_type fv = foldr Set.union Set.empty . map freeVariables $ typs specializeSig _ _ sig = sig -- | Make all details of instance head (signatures, associated types) -- specialized to that particular instance type. -specializeInstHead :: (Eq name, DataId name, SetName name) +specializeInstHead :: (Ord name, DataId name, SetName name, NamedThing name) => InstHead name -> InstHead name specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } = ihd { ihdInstType = instType' } @@ -115,12 +108,7 @@ specializeInstHead ihd = ihd -- and @(a, b, c)@. sugar :: forall name. (NamedThing name, DataId name) => HsType name -> HsType name -sugar = - everywhere $ mkT step - where - step :: HsType name -> HsType name - step = sugarOperators . sugarTuples . sugarLists - +sugar = sugarOperators . sugarTuples . sugarLists sugarLists :: NamedThing name => HsType name -> HsType name sugarLists (HsAppTy (L _ (HsTyVar _ (L _ name))) ltyp) diff --git a/haddock-api/src/Haddock/Syb.hs b/haddock-api/src/Haddock/Syb.hs index 4847e486..7e34ae8c 100644 --- a/haddock-api/src/Haddock/Syb.hs +++ b/haddock-api/src/Haddock/Syb.hs @@ -1,8 +1,11 @@ {-# LANGUAGE Rank2Types #-} - +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} module Haddock.Syb - ( everything, everythingWithState, everywhere + ( everything, everythingButType, everythingWithState + , everywhere, everywhereButType , mkT , combine ) where @@ -10,16 +13,41 @@ module Haddock.Syb import Data.Data import Control.Applicative +import Data.Maybe +import Data.Foldable +-- | Returns true if a == t. +-- requires AllowAmbiguousTypes +isType :: forall a b. (Typeable a, Typeable b) => b -> Bool +isType _ = isJust $ eqT @a @b -- | Perform a query on each level of a tree. -- -- This is stolen directly from SYB package and copied here to not introduce -- additional dependencies. -everything :: (r -> r -> r) -> (forall a. Data a => a -> r) +everything :: (r -> r -> r) + -> (forall a. Data a => a -> r) -> (forall a. Data a => a -> r) -everything k f x = foldl k (f x) (gmapQ (everything k f) x) +everything k f x = foldl' k (f x) (gmapQ (everything k f) x) + +-- | Variation of "everything" with an added stop condition +-- Just like 'everything', this is stolen from SYB package. +everythingBut :: (r -> r -> r) + -> (forall a. Data a => a -> (r, Bool)) + -> (forall a. Data a => a -> r) +everythingBut k f x = let (v, stop) = f x + in if stop + then v + else foldl' k v (gmapQ (everythingBut k f) x) +-- | Variation of "everything" that does not recurse into children of type t +-- requires AllowAmbiguousTypes +everythingButType :: + forall t r. (Typeable t) + => (r -> r -> r) + -> (forall a. Data a => a -> r) + -> (forall a. Data a => a -> r) +everythingButType k f = everythingBut k $ (,) <$> f <*> isType @t -- | Perform a query with state on each level of a tree. -- @@ -31,8 +59,7 @@ everythingWithState :: s -> (r -> r -> r) -> (forall a. Data a => a -> r) everythingWithState s k f x = let (r, s') = f x s - in foldl k r (gmapQ (everythingWithState s' k f) x) - + in foldl' k r (gmapQ (everythingWithState s' k f) x) -- | Apply transformation on each level of a tree. -- @@ -40,6 +67,22 @@ everythingWithState s k f x = everywhere :: (forall a. Data a => a -> a) -> (forall a. Data a => a -> a) everywhere f = f . gmapT (everywhere f) +-- | Variation on everywhere with an extra stop condition +-- Just like 'everything', this is stolen from SYB package. +everywhereBut :: (forall a. Data a => a -> Bool) + -> (forall a. Data a => a -> a) + -> (forall a. Data a => a -> a) +everywhereBut q f x + | q x = x + | otherwise = f (gmapT (everywhereBut q f) x) + +-- | Variation of "everywhere" that does not recurse into children of type t +-- requires AllowAmbiguousTypes +everywhereButType :: forall t . (Typeable t) + => (forall a. Data a => a -> a) + -> (forall a. Data a => a -> a) +everywhereButType = everywhereBut (isType @t) + -- | Create generic transformation. -- -- Another function stolen from SYB package. -- cgit v1.2.3 From eca0677beaa78f31485055c432bf481dc06007a9 Mon Sep 17 00:00:00 2001 From: Alex Biehl Date: Tue, 30 May 2017 19:01:37 +0200 Subject: Clear fixme comment (#625) --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) (limited to 'haddock-api') diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index ffe42c4f..035c8e9e 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -520,9 +520,8 @@ ppClassDecl summary links instances fixities loc d subdocs , f@(n',_) <- fixities , n == n' ] names = map unLoc lnames ] - -- FIXME: is taking just the first name ok? Is it possible that - -- there are different subdocs for different names in a single - -- type signature? + -- N.B. taking just the first name is ok. Signatures with multiple names + -- are expanded so that each name gets its own signature. minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of -- Miminal complete definition = every shown method -- cgit v1.2.3 From fdf1b017b07e12769a7ca605b41dc76842838855 Mon Sep 17 00:00:00 2001 From: Alex Biehl Date: Tue, 30 May 2017 19:02:12 +0200 Subject: Make haddock-library and haddock-api warning free (#626) --- haddock-api/src/Haddock.hs | 12 ++++++------ haddock-api/src/Haddock/GhcUtils.hs | 4 ---- haddock-api/src/Haddock/Interface/Specialize.hs | 1 - haddock-library/src/Documentation/Haddock/Types.hs | 4 +++- 4 files changed, 9 insertions(+), 12 deletions(-) (limited to 'haddock-api') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index f0e7e6c7..57ea5fea 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -398,12 +398,12 @@ withGhc' libDir flags ghcActs = runGhc (Just libDir) $ do ghcLink = NoLink } let dynflags'' = updOptLevel 0 $ gopt_unset dynflags' Opt_SplitObjs - defaultCleanupHandler dynflags'' $ do - -- ignore the following return-value, which is a list of packages - -- that may need to be re-linked: Haddock doesn't do any - -- dynamic or static linking at all! - _ <- setSessionDynFlags dynflags'' - ghcActs dynflags'' + + -- ignore the following return-value, which is a list of packages + -- that may need to be re-linked: Haddock doesn't do any + -- dynamic or static linking at all! + _ <- setSessionDynFlags dynflags'' + ghcActs dynflags'' where parseGhcFlags :: MonadIO m => DynFlags -> m DynFlags parseGhcFlags dynflags = do diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index c8e5ea8b..dcc1d834 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -17,17 +17,13 @@ module Haddock.GhcUtils where import Control.Arrow -import Data.Function import Exception import Outputable import Name import Lexeme import Module -import RdrName (GlobalRdrEnv) -import GhcMonad (withSession) import HscTypes -import UniqFM import GHC import Class diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 8c28cd5a..da8c3e7b 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -27,7 +27,6 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set -import Data.Foldable -- | Instantiate all occurrences of given names with corresponding types. specialize :: forall name a. (Ord name, DataId name, NamedThing name) diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs index 4d5bb68a..660878ff 100644 --- a/haddock-library/src/Documentation/Haddock/Types.hs +++ b/haddock-library/src/Documentation/Haddock/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +{-# LANGUAGE CPP, DeriveFunctor, DeriveFoldable, DeriveTraversable #-} -- | -- Module : Documentation.Haddock.Types @@ -14,8 +14,10 @@ -- Exposes documentation data types used for (some) of Haddock. module Documentation.Haddock.Types where +#if !MIN_VERSION_base(4,8,0) import Data.Foldable import Data.Traversable +#endif -- | With the advent of 'Version', we may want to start attaching more -- meta-data to comments. We make a structure for this ahead of time -- cgit v1.2.3 From bfb3563f730fd1c973a6611a0fba3435fb1df489 Mon Sep 17 00:00:00 2001 From: Alex Biehl Date: Sat, 3 Jun 2017 20:37:28 +0200 Subject: Allow user defined signatures for pattern synonyms (#631) --- CHANGES.md | 2 ++ haddock-api/src/Haddock/GhcUtils.hs | 5 +++++ haddock-api/src/Haddock/Interface/Create.hs | 1 + html-test/ref/PatternSyns.html | 29 +++++++++++++++++++++++++++++ html-test/src/PatternSyns.hs | 5 +++++ 5 files changed, 42 insertions(+) (limited to 'haddock-api') diff --git a/CHANGES.md b/CHANGES.md index 6c2b5d32..95e1763a 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,7 @@ ## Changes in version 2.18.0 + * Support user defined signatures on pattern synonyms + * Synopsis is working again (#599) ## Changes in version 2.17.4 diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index dcc1d834..4280cd80 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -88,6 +88,10 @@ filterSigNames p (ClassOpSig is_default ns ty) = case filter (p . unLoc) ns of [] -> Nothing filtered -> Just (ClassOpSig is_default filtered ty) +filterSigNames p (PatSynSig ns ty) = + case filter (p . unLoc) ns of + [] -> Nothing + filtered -> Just (PatSynSig filtered ty) filterSigNames _ _ = Nothing ifTrueJust :: Bool -> name -> Maybe name @@ -110,6 +114,7 @@ sigNameNoLoc _ = [] isUserLSig :: LSig name -> Bool isUserLSig (L _(TypeSig {})) = True isUserLSig (L _(ClassOpSig {})) = True +isUserLSig (L _(PatSynSig {})) = True isUserLSig _ = False diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 26ac0281..98d4dbe8 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -842,6 +842,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap expandSig :: Sig name -> [Sig name] expandSig (TypeSig names t) = [ TypeSig [n] t | n <- names ] expandSig (ClassOpSig b names t) = [ ClassOpSig b [n] t | n <- names ] + expandSig (PatSynSig names t) = [ PatSynSig [n] t | n <- names ] expandSig x = [x] mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name)) diff --git a/html-test/ref/PatternSyns.html b/html-test/ref/PatternSyns.html index 9f0caaa2..2cf936b3 100644 --- a/html-test/ref/PatternSyns.html +++ b/html-test/ref/PatternSyns.html @@ -118,6 +118,16 @@ window.onload = function () {pageLoad();}; > k a (b :: k). (><) k a b

  • pattern PatWithExplicitSig :: Eq somex => somex -> FooType somex
  • pattern PatWithExplicitSig :: Eq somex => somex -> FooType somex #

    Earlier ghc versions didn't allow explicit signatures + on pattern synonyms.

    Quux a c (Quux a c b)) a c b0)) #

    Quux a b c)) -> (Quux a c b, a c b0, Quux a c c) a c c0) #

    Quux a b c)) -> (Quux a c b, a c b0, Quux a c c) a c c0) #

    forall a. a -> a) -> (b, forall a. a -> [c]) -> (b, c) c0. c0 -> [c]) -> (b, c1) #

    forall b. (forall a. a -> [c]) -> c) -> b. b -> [c]) -> c0) -> forall a. a -> b c1. c1 -> b #

    baz :: (a -> b) -> (forall c. c -> c) -> (b, a0. a0 -> a0) -> (b0, forall c. c -> a -> b) -> (b, c) c. c -> a -> b) -> (b0, c) #

    baz' :: b -> ( :: b0 -> (forall c. c -> a -> b) -> ( b1. b1 -> a -> b) -> (forall c. c -> a -> b) -> [(b, a -> b)] b2. b2 -> a -> b) -> [(b0, a -> b)] #

    baz'' :: b -> ( :: b0 -> (forall c. ( b1. (forall d. d -> a -> b) -> c) -> b2. b2 -> a -> b) -> c) -> forall c. c -> b c. c -> b0 #

    baz :: (a, b, c) -> (forall d. d -> d) -> (b, a0. a0 -> a0) -> (b0, forall d. d -> (a, b, c)) -> (b, c) c0. c0 -> (a, b, c)) -> (b0, c1) #

    baz' :: b -> ( :: b0 -> (forall d. d -> (a, b, c)) -> ( b1. b1 -> (a, b, c)) -> (forall d. d -> (a, b, c)) -> [(b, (a, b, c))] b2. b2 -> (a, b, c)) -> [(b0, (a, b, c))] #

    baz'' :: b -> ( :: b0 -> (forall d. ( b1. (forall e. e -> (a, b, c)) -> c) -> b2. b2 -> (a, b, c)) -> c0) -> forall d. d -> b c1. c1 -> b0 #

    Quux a b c -> (forall d. d -> d) -> (b, a0. a0 -> a0) -> (b0, forall d. d -> c0. c0 -> Quux a b c) -> (b, c) a b c) -> (b0, c1) #

    baz' :: b -> ( :: b0 -> (forall d. d -> b1. b1 -> Quux a b c) -> (forall d. d -> b2. b2 -> Quux a b c) -> [(b, a b c) -> [(b0, Quux a b c)] #

    baz'' :: b -> ( :: b0 -> (forall d. ( b1. (forall e. e -> b2. b2 -> Quux a b c) -> c) -> a b c) -> c0) -> forall d. d -> b c1. c1 -> b0 #

    baz :: (a, [b], b, a) -> (forall c. c -> c) -> (b, a0. a0 -> a0) -> (b0, forall c. c -> (a, [b], b, a)) -> (b, c) c. c -> (a, [b], b, a)) -> (b0, c) #

    baz' :: b -> ( :: b0 -> (forall c. c -> (a, [b], b, a)) -> ( b1. b1 -> (a, [b], b, a)) -> (forall c. c -> (a, [b], b, a)) -> [(b, (a, [b], b, a))] b2. b2 -> (a, [b], b, a)) -> [(b0, (a, [b], b, a))] #

    baz'' :: b -> ( :: b0 -> (forall c. ( b1. (forall d. d -> (a, [b], b, a)) -> c) -> b2. b2 -> (a, [b], b, a)) -> c) -> forall c. c -> b c. c -> b0 #

    Quux a b Int -> a -> -> a0 -> Quux a b a a b a0 #

    Quux a b (Quux a b a) -> a b a0) -> Int -> QuuxQuux a c (Quux a c b)) a c b0)) #

    Quux a b c)) -> (Quux a c b, a c b0, Quux a c c) a c c0) #

    Quux a b c)) -> (Quux a c b, a c b0, Quux a c c) a c c0) #

    Quux a b c -> (forall d. d -> d) -> (b, a0. a0 -> a0) -> (b0, forall d. d -> c0. c0 -> Quux a b c) -> (b, c) a b c) -> (b0, c1) #

    baz' :: b -> ( :: b0 -> (forall d. d -> b1. b1 -> Quux a b c) -> (forall d. d -> b2. b2 -> Quux a b c) -> [(b, a b c) -> [(b0, Quux a b c)] #

    baz'' :: b -> ( :: b0 -> (forall d. ( b1. (forall e. e -> b2. b2 -> Quux a b c) -> c) -> a b c) -> c0) -> forall d. d -> b c1. c1 -> b0 #

    b) -> f a -> f b + +instance Functor (Either a) where + fmap _ (Left x) = Left x + fmap f (Right y) = Right (f y) + +-- | Phantom type a0 is added to block the first renaming from a to a0. This ensures that the renamer doesn't create a new conflict +data ThreeVars a0 a b = ThreeVars a b + +instance Functor (ThreeVars a0 a) where + fmap f (ThreeVars a b) = ThreeVars a (f b) -- cgit v1.2.3 From 3fddb62913c72f29843335aa796c2e444ded1608 Mon Sep 17 00:00:00 2001 From: Tim Baumann Date: Sun, 6 Aug 2017 11:33:38 +0200 Subject: Fix: Generate pattern signatures for constructors exported as patterns (#663) * Fix pretty-printing of pattern signatures Pattern synonyms can have up to two contexts, both having a different semantic meaning: The first holds the constraints required to perform the matching, the second contains the constraints provided by a successful pattern match. When the first context is empty but the second is not it is necessary to render the first, empty context. * Generate pattern synonym signatures for ctors exported as patterns This fixes #653. * Simplify extractPatternSyn It is not necessary to generate the simplest type signature since it will be simplified when pretty-printed. * Add changelog entries for PR #663 * Fix extractPatternSyn error message --- CHANGES.md | 5 + haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 242 ++++++++++++++----------- haddock-api/src/Haddock/Interface/Create.hs | 34 +++- haddock-api/src/Haddock/Types.hs | 6 + html-test/ref/ConstructorPatternExport.html | 124 +++++++++++++ html-test/ref/PatternSyns.html | 76 ++++++++ html-test/src/ConstructorPatternExport.hs | 26 +++ html-test/src/PatternSyns.hs | 8 +- 8 files changed, 412 insertions(+), 109 deletions(-) create mode 100644 html-test/ref/ConstructorPatternExport.html create mode 100644 html-test/src/ConstructorPatternExport.hs (limited to 'haddock-api') diff --git a/CHANGES.md b/CHANGES.md index 5050339d..f96ac325 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -6,6 +6,11 @@ * Move markup related data types to haddock-library + * Fix: Show empty constraint contexts in pattern type signatures (#663) + + * Fix: Generate constraint signatures for constructors exported as pattern + synonyms (#663) + ## Changes in version 2.18.1 * Synopsis is working again (#599) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index cda0611a..c78bee2d 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -71,9 +71,9 @@ ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> Splice -> Unicode -> Qualification -> Html ppFunSig summary links loc doc docnames typ fixities splice unicode qual = ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ) - splice unicode qual + splice unicode qual HideEmptyContexts where - pp_typ = ppLType unicode qual typ + pp_typ = ppLType unicode qual HideEmptyContexts typ ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> [Located DocName] -> LHsSigType DocName -> @@ -87,20 +87,20 @@ ppLPatSig summary links loc (doc, _argDocs) docnames typ fixities splice unicode pref1 = hsep [ keyword "pattern" , hsep $ punctuate comma $ map (ppBinder summary . getOccName) docnames , dcolon unicode - , ppLType unicode qual (hsSigType typ) + , ppPatSigType unicode qual (hsSigType typ) ] ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> [DocName] -> [(DocName, Fixity)] -> (HsType DocName, Html) -> - Splice -> Unicode -> Qualification -> Html + Splice -> Unicode -> Qualification -> HideEmptyContexts -> Html ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) - splice unicode qual = + splice unicode qual emptyCtxts = ppTypeOrFunSig summary links loc docnames typ doc ( addFixities $ leader <+> ppTypeSig summary occnames pp_typ unicode , addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames , dcolon unicode ) - splice unicode qual + splice unicode qual emptyCtxts where occnames = map (nameOccName . getName) docnames addFixities html @@ -110,8 +110,8 @@ ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocName -> DocForDecl DocName -> (Html, Html, Html) - -> Splice -> Unicode -> Qualification -> Html -ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual + -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual emptyCtxts | summary = pref1 | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curName qual doc | otherwise = topDeclElem links loc splice docnames pref2 +++ @@ -132,14 +132,14 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) | null (unLoc lctxt) = do_largs n leader ltype | otherwise - = (leader <+> ppLContextNoArrow lctxt unicode qual, Nothing, []) + = (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, []) : do_largs n (darrow unicode) ltype do_args n leader (HsFunTy lt r) - = (leader <+> ppLFunLhType unicode qual lt, argDoc n, []) + = (leader <+> ppLFunLhType unicode qual emptyCtxts lt, argDoc n, []) : do_largs (n+1) (arrow unicode) r do_args n leader t - = [(leader <+> ppType unicode qual t, argDoc n, [])] + = [(leader <+> ppType unicode qual emptyCtxts t, argDoc n, [])] ppForAll :: [LHsTyVarBndr DocName] -> Unicode -> Qualification -> Html ppForAll tvs unicode qual = @@ -197,11 +197,11 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars splice unicode qual = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals) - splice unicode qual + splice unicode qual ShowEmptyToplevelContexts where hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars unicode qual (hsQTvExplicit ltyvars)) - full = hdr <+> equals <+> ppLType unicode qual ltype + full = hdr <+> equals <+> ppPatSigType unicode qual ltype occ = nameOccName . getName $ name fixs | summary = noHtml @@ -220,14 +220,14 @@ ppTyName :: Name -> Html ppTyName = ppName Prefix -ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> SrcSpan +ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> SrcSpan -> [DocName] -> HsType DocName -> Html -ppSimpleSig links splice unicode qual loc names typ = +ppSimpleSig links splice unicode qual emptyCtxts loc names typ = topDeclElem' names $ ppTypeSig True occNames ppTyp unicode where topDeclElem' = topDeclElem links loc splice - ppTyp = ppType unicode qual typ + ppTyp = ppType unicode qual emptyCtxts typ occNames = map getOccName names @@ -321,7 +321,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs , tfe_pats = HsIB { hsib_body = ts }} = ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual - <+> equals <+> ppType unicode qual (unLoc rhs) + <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs) , Nothing, [] ) @@ -377,7 +377,7 @@ ppAppDocNameTyVarBndrs summ unicode qual n vs = ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName] -> Unicode -> Qualification -> Html ppAppNameTypes n ks ts unicode qual = - ppTypeApp n ks ts (\p -> ppDocName qual p True) (ppParendType unicode qual) + ppTypeApp n ks ts (\p -> ppDocName qual p True) (ppParendType unicode qual HideEmptyContexts) -- | General printing of type applications @@ -398,32 +398,35 @@ ppTypeApp n ks ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT $ ks ++ ts) ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Unicode - -> Qualification -> Html + -> Qualification -> HideEmptyContexts -> Html ppLContext = ppContext . unLoc ppLContextNoArrow = ppContextNoArrow . unLoc -ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> Html -ppContextNoArrow cxt unicode qual = fromMaybe noHtml $ - ppContextNoLocsMaybe (map unLoc cxt) unicode qual +ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppContextNoArrow cxt unicode qual emptyCtxts = fromMaybe noHtml $ + ppContextNoLocsMaybe (map unLoc cxt) unicode qual emptyCtxts -ppContextNoLocs :: [HsType DocName] -> Unicode -> Qualification -> Html -ppContextNoLocs cxt unicode qual = maybe noHtml (<+> darrow unicode) $ - ppContextNoLocsMaybe cxt unicode qual +ppContextNoLocs :: [HsType DocName] -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppContextNoLocs cxt unicode qual emptyCtxts = maybe noHtml (<+> darrow unicode) $ + ppContextNoLocsMaybe cxt unicode qual emptyCtxts -ppContextNoLocsMaybe :: [HsType DocName] -> Unicode -> Qualification -> Maybe Html -ppContextNoLocsMaybe [] _ _ = Nothing -ppContextNoLocsMaybe cxt unicode qual = Just $ ppHsContext cxt unicode qual +ppContextNoLocsMaybe :: [HsType DocName] -> Unicode -> Qualification -> HideEmptyContexts -> Maybe Html +ppContextNoLocsMaybe [] _ _ emptyCtxts = + case emptyCtxts of + HideEmptyContexts -> Nothing + ShowEmptyToplevelContexts -> Just (toHtml "()") +ppContextNoLocsMaybe cxt unicode qual _ = Just $ ppHsContext cxt unicode qual -ppContext :: HsContext DocName -> Unicode -> Qualification -> Html -ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual +ppContext :: HsContext DocName -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppContext cxt unicode qual emptyCtxts = ppContextNoLocs (map unLoc cxt) unicode qual emptyCtxts -ppHsContext :: [HsType DocName] -> Unicode -> Qualification-> Html -ppHsContext [] _ _ = noHtml +ppHsContext :: [HsType DocName] -> Unicode -> Qualification -> Html +ppHsContext [] _ _ = noHtml ppHsContext [p] unicode qual = ppCtxType unicode qual p -ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt) +ppHsContext cxt unicode qual = parenList (map (ppType unicode qual HideEmptyContexts) cxt) ------------------------------------------------------------------------------- @@ -436,7 +439,7 @@ ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName -> Unicode -> Qualification -> Html ppClassHdr summ lctxt n tvs fds unicode qual = keyword "class" - <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual else noHtml) + <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual HideEmptyContexts else noHtml) <+> ppAppDocNameTyVarBndrs summ unicode qual n (hsQTvExplicit tvs) <+> ppFds fds unicode qual @@ -592,7 +595,7 @@ ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) = case ihdInstType of ClassInst { .. } -> - ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual <+> typ + ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual HideEmptyContexts <+> typ , mdoc , [subInstDetails iid ats sigs] ) @@ -607,7 +610,7 @@ ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) = where ptype = keyword "type" <+> typ prhs = ptype <+> maybe noHtml - (\t -> equals <+> ppType unicode qual t) rhs + (\t -> equals <+> ppType unicode qual HideEmptyContexts t) rhs DataInst dd -> ( subInstHead iid pdata , mdoc @@ -636,9 +639,9 @@ ppInstanceSigs links splice unicode qual sigs = do TypeSig lnames typ <- sigs let names = map unLoc lnames L _ rtyp = hsSigWcType typ - -- Instance methods signatures are synified and thus don't have a useful + -- Instance methods signatures are synified and thus don't have a useful -- SrcSpan value. Use the methods name location instead. - return $ ppSimpleSig links splice unicode qual (getLoc $ head $ lnames) names rtyp + return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLoc $ head $ lnames) names rtyp lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 @@ -698,7 +701,7 @@ ppShortDataDecl summary dataInst dataDecl pats unicode qual pats1 = [ hsep [ keyword "pattern" , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames , dcolon unicode - , ppLType unicode qual (hsSigType typ) + , ppPatSigType unicode qual (hsSigType typ) ] | (SigD (PatSynSig lnames typ),_) <- pats ] @@ -744,7 +747,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats [ (hsep [ keyword "pattern" , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames , dcolon unicode - , ppLType unicode qual (hsSigType typ) + , ppPatSigType unicode qual (hsSigType typ) ] <+> ppFixities subfixs qual ,combineDocumentation (fst d), []) | (SigD (PatSynSig lnames typ),d) <- pats @@ -769,17 +772,17 @@ ppShortConstrParts summary dataInst con unicode qual = case con of ConDeclH98{} -> case con_details con of PrefixCon args -> (header_ unicode qual +++ hsep (ppOcc - : map (ppLParendType unicode qual) args), noHtml, noHtml) + : map (ppLParendType unicode qual HideEmptyContexts) args), noHtml, noHtml) RecCon (L _ fields) -> (header_ unicode qual +++ ppOcc <+> char '{', doRecordFields fields, char '}') InfixCon arg1 arg2 -> - (header_ unicode qual +++ hsep [ppLParendType unicode qual arg1, - ppOccInfix, ppLParendType unicode qual arg2], + (header_ unicode qual +++ hsep [ppLParendType unicode qual HideEmptyContexts arg1, + ppOccInfix, ppLParendType unicode qual HideEmptyContexts arg2], noHtml, noHtml) - ConDeclGADT {} -> (ppOcc <+> dcolon unicode <+> ppLType unicode qual resTy,noHtml,noHtml) + ConDeclGADT {} -> (ppOcc <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts resTy,noHtml,noHtml) where resTy = hsib_body (con_type con) @@ -811,7 +814,7 @@ ppConstrHdr forall_ tvs ctxt unicode qual = (if null tvs then noHtml else ppForall) +++ (if null ctxt then noHtml - else ppContextNoArrow ctxt unicode qual + else ppContextNoArrow ctxt unicode qual HideEmptyContexts <+> darrow unicode +++ toHtml " ") where ppForall | forall_ = forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) @@ -827,15 +830,15 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) ConDeclH98{} -> case con_details con of PrefixCon args -> hsep ((header_ +++ ppOcc) - : map (ppLParendType unicode qual) args) + : map (ppLParendType unicode qual HideEmptyContexts) args) <+> fixity RecCon _ -> header_ +++ ppOcc <+> fixity InfixCon arg1 arg2 -> - hsep [header_ +++ ppLParendType unicode qual arg1, + hsep [header_ +++ ppLParendType unicode qual HideEmptyContexts arg1, ppOccInfix, - ppLParendType unicode qual arg2] + ppLParendType unicode qual HideEmptyContexts arg2] <+> fixity ConDeclGADT{} -> doGADTCon resTy @@ -852,7 +855,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) doGADTCon :: Located (HsType DocName) -> Html doGADTCon ty = ppOcc <+> dcolon unicode -- ++AZ++ make this prepend "{..}" when it is a record style GADT - <+> ppLType unicode qual ty + <+> ppLType unicode qual HideEmptyContexts ty <+> fixity fixity = ppFixities fixities qual @@ -879,9 +882,12 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification -> ConDeclField DocName -> SubDecl ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) = - (hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual ltype, - mbDoc, - []) + ( hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) + <+> dcolon unicode + <+> ppLType unicode qual HideEmptyContexts ltype + , mbDoc + , [] + ) where -- don't use cd_fld_doc for same reason we don't use con_doc above -- Where there is more than one name, they all have the same documentation @@ -891,7 +897,7 @@ ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) = ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html ppShortField summary unicode qual (ConDeclField names ltype _) = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) - <+> dcolon unicode <+> ppLType unicode qual ltype + <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype -- | Print the LHS of a data\/newtype declaration. @@ -906,7 +912,7 @@ ppDataHeader summary decl@(DataDecl { tcdDataDefn = (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+> -- context - ppLContext ctxt unicode qual <+> + ppLContext ctxt unicode qual HideEmptyContexts <+> -- T a b c ..., or a :+: b ppDataBinderWithVars summary unicode qual decl <+> case ks of @@ -958,19 +964,18 @@ maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p | otherwise = p -ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification - -> Located (HsType DocName) -> Html -ppLType unicode qual y = ppType unicode qual (unLoc y) -ppLParendType unicode qual y = ppParendType unicode qual (unLoc y) -ppLFunLhType unicode qual y = ppFunLhType unicode qual (unLoc y) +ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> Located (HsType DocName) -> Html +ppLType unicode qual emptyCtxts y = ppType unicode qual emptyCtxts (unLoc y) +ppLParendType unicode qual emptyCtxts y = ppParendType unicode qual emptyCtxts (unLoc y) +ppLFunLhType unicode qual emptyCtxts y = ppFunLhType unicode qual emptyCtxts (unLoc y) +ppCtxType :: Unicode -> Qualification -> HsType DocName -> Html +ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual HideEmptyContexts -ppType, ppCtxType, ppParendType, ppFunLhType :: Unicode -> Qualification - -> HsType DocName -> Html -ppType unicode qual ty = ppr_mono_ty pREC_TOP ty unicode qual -ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual -ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual -ppFunLhType unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual +ppType, ppParendType, ppFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> HsType DocName -> Html +ppType unicode qual emptyCtxts ty = ppr_mono_ty pREC_TOP ty unicode qual emptyCtxts +ppParendType unicode qual emptyCtxts ty = ppr_mono_ty pREC_CON ty unicode qual emptyCtxts +ppFunLhType unicode qual emptyCtxts ty = ppr_mono_ty pREC_FUN ty unicode qual emptyCtxts ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocName -> Html ppHsTyVarBndr _ qual (UserTyVar (L _ name)) = @@ -983,62 +988,85 @@ ppLKind :: Unicode -> Qualification -> LHsKind DocName -> Html ppLKind unicode qual y = ppKind unicode qual (unLoc y) ppKind :: Unicode -> Qualification -> HsKind DocName -> Html -ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual +ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual HideEmptyContexts + +ppPatSigType :: Unicode -> Qualification -> LHsType DocName -> Html +ppPatSigType unicode qual typ = + let emptyCtxts = + if hasNonEmptyContext typ && isFirstContextEmpty typ + then ShowEmptyToplevelContexts + else HideEmptyContexts + in ppLType unicode qual emptyCtxts typ + where + hasNonEmptyContext :: LHsType name -> Bool + hasNonEmptyContext t = + case unLoc t of + HsForAllTy _ s -> hasNonEmptyContext s + HsQualTy cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True + HsFunTy _ s -> hasNonEmptyContext s + _ -> False + isFirstContextEmpty :: LHsType name -> Bool + isFirstContextEmpty t = + case unLoc t of + HsForAllTy _ s -> isFirstContextEmpty s + HsQualTy cxt _ -> null (unLoc cxt) + HsFunTy _ s -> isFirstContextEmpty s + _ -> False ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocName] -> Html ppForAllPart unicode qual tvs = hsep (forallSymbol unicode : ppTyVars unicode qual tvs) +++ dot -ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html +ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> HideEmptyContexts -> Html ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) -ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> Html -ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual +ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual emptyCtxts = maybeParen ctxt_prec pREC_FUN $ - ppForAllPart unicode qual tvs <+> ppr_mono_lty pREC_TOP ty unicode qual + ppForAllPart unicode qual tvs <+> ppr_mono_lty pREC_TOP ty unicode qual emptyCtxts -ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual +ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual emptyCtxts = maybeParen ctxt_prec pREC_FUN $ - ppLContext ctxt unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual + ppLContext ctxt unicode qual emptyCtxts <+> ppr_mono_lty pREC_TOP ty unicode qual emptyCtxts -- UnicodeSyntax alternatives -ppr_mono_ty _ (HsTyVar _ (L _ name)) True _ +ppr_mono_ty _ (HsTyVar _ (L _ name)) True _ _ | getOccString (getName name) == "*" = toHtml "★" | getOccString (getName name) == "(->)" = toHtml "(→)" -ppr_mono_ty _ (HsBangTy b ty) u q = ppBang b +++ ppLParendType u q ty -ppr_mono_ty _ (HsTyVar _ (L _ name)) _ q = ppDocName q Prefix True name -ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q = ppr_fun_ty ctxt_prec ty1 ty2 u q -ppr_mono_ty _ (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys) -ppr_mono_ty _ (HsSumTy tys) u q = sumParens (map (ppLType u q) tys) -ppr_mono_ty _ (HsKindSig ty kind) u q = - parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppLKind u q kind) -ppr_mono_ty _ (HsListTy ty) u q = brackets (ppr_mono_lty pREC_TOP ty u q) -ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TOP ty u q) -ppr_mono_ty ctxt_prec (HsIParamTy (L _ n) ty) u q = - maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q -ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy" -ppr_mono_ty _ (HsRecTy {}) _ _ = toHtml "{..}" +ppr_mono_ty _ (HsBangTy b ty) u q _ = ppBang b +++ ppLParendType u q HideEmptyContexts ty +ppr_mono_ty _ (HsTyVar _ (L _ name)) _ q _ = ppDocName q Prefix True name +ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q e = ppr_fun_ty ctxt_prec ty1 ty2 u q e +ppr_mono_ty _ (HsTupleTy con tys) u q _ = tupleParens con (map (ppLType u q HideEmptyContexts) tys) +ppr_mono_ty _ (HsSumTy tys) u q _ = sumParens (map (ppLType u q HideEmptyContexts) tys) +ppr_mono_ty _ (HsKindSig ty kind) u q e = + parens (ppr_mono_lty pREC_TOP ty u q e <+> dcolon u <+> ppLKind u q kind) +ppr_mono_ty _ (HsListTy ty) u q _ = brackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts) +ppr_mono_ty _ (HsPArrTy ty) u q _ = pabrackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts) +ppr_mono_ty ctxt_prec (HsIParamTy (L _ n) ty) u q _ = + maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q HideEmptyContexts +ppr_mono_ty _ (HsSpliceTy {}) _ _ _ = error "ppr_mono_ty HsSpliceTy" +ppr_mono_ty _ (HsRecTy {}) _ _ _ = toHtml "{..}" -- Can now legally occur in ConDeclGADT, the output here is to provide a -- placeholder in the signature, which is followed by the field -- declarations. -ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy" -ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) u q = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys -ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u q = brackets $ hsep $ punctuate comma $ map (ppLType u q) tys -ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = promoQuote $ parenList $ map (ppLType u q) tys -ppr_mono_ty _ (HsAppsTy {}) _ _ = error "ppr_mono_ty HsAppsTy" +ppr_mono_ty _ (HsCoreTy {}) _ _ _ = error "ppr_mono_ty HsCoreTy" +ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys +ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys +ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q _ = promoQuote $ parenList $ map (ppLType u q HideEmptyContexts) tys +ppr_mono_ty _ (HsAppsTy {}) _ _ _ = error "ppr_mono_ty HsAppsTy" -ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual +ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual _ = maybeParen ctxt_prec pREC_CTX $ - ppr_mono_lty pREC_OP ty1 unicode qual <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual + ppr_mono_lty pREC_OP ty1 unicode qual HideEmptyContexts <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual HideEmptyContexts -ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual +ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual _ = maybeParen ctxt_prec pREC_CON $ - hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual, ppr_mono_lty pREC_CON arg_ty unicode qual] + hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual HideEmptyContexts, ppr_mono_lty pREC_CON arg_ty unicode qual HideEmptyContexts] -ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual +ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual _ = maybeParen ctxt_prec pREC_FUN $ - ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual + ppr_mono_lty pREC_OP ty1 unicode qual HideEmptyContexts <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual HideEmptyContexts where -- `(:)` is valid in type signature only as constructor to promoted list -- and needs to be quoted in code so we explicitly quote it here too. @@ -1047,25 +1075,25 @@ ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual | otherwise = ppr_op' ppr_op' = ppLDocName qual Infix op -ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual +ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual emptyCtxts -- = parens (ppr_mono_lty pREC_TOP ty) - = ppr_mono_lty ctxt_prec ty unicode qual + = ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts -ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual - = ppr_mono_lty ctxt_prec ty unicode qual +ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual emptyCtxts + = ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts -ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ = char '_' -ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n +ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ _ = char '_' +ppr_mono_ty _ (HsTyLit n) _ _ _ = ppr_tylit n ppr_tylit :: HsTyLit -> Html ppr_tylit (HsNumTy _ n) = toHtml (show n) ppr_tylit (HsStrTy _ s) = toHtml (show s) -ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Unicode -> Qualification -> Html -ppr_fun_ty ctxt_prec ty1 ty2 unicode qual - = let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual - p2 = ppr_mono_lty pREC_TOP ty2 unicode qual +ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppr_fun_ty ctxt_prec ty1 ty2 unicode qual emptyCtxts + = let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual HideEmptyContexts + p2 = ppr_mono_lty pREC_TOP ty2 unicode qual emptyCtxts in maybeParen ctxt_prec pREC_FUN $ hsep [p1, arrow unicode <+> p2] diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index b9179d11..89f7f71b 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -985,7 +985,9 @@ extractDecl name decl O.$$ O.nest 4 (O.ppr matches)) TyClD d@DataDecl {} -> let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d)) - in SigD <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d)) + in if isDataConName name + then SigD <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d)) + else SigD <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d)) InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n , dfid_pats = HsIB { hsib_body = tys } , dfid_defn = defn }) -> @@ -1003,6 +1005,36 @@ extractDecl name decl _ -> error "internal: extractDecl (ClsInstD)" _ -> error "internal: extractDecl" +extractPatternSyn :: Name -> Name -> [LHsType Name] -> [LConDecl Name] -> LSig Name +extractPatternSyn nm t tvs cons = + case filter matches cons of + [] -> error "extractPatternSyn: constructor pattern not found" + con:_ -> extract <$> con + where + matches :: LConDecl Name -> Bool + matches (L _ con) = nm `elem` (unLoc <$> getConNames con) + extract :: ConDecl Name -> Sig Name + extract con = + let args = + case getConDetails con of + PrefixCon args' -> args' + RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields + InfixCon arg1 arg2 -> [arg1, arg2] + typ = longArrow args (data_ty con) + typ' = + case con of + ConDeclH98 { con_cxt = Just cxt } -> noLoc (HsQualTy cxt typ) + _ -> typ + typ'' = noLoc (HsQualTy (noLoc []) typ') + in PatSynSig [noLoc nm] (mkEmptyImplicitBndrs typ'') + + longArrow :: [LHsType name] -> LHsType name -> LHsType name + longArrow inputs output = foldr (\x y -> noLoc (HsFunTy x y)) output inputs + + data_ty con + | ConDeclGADT{} <- con = hsib_body $ con_type con + | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs + extractRecSel :: Name -> Name -> [LHsType Name] -> [LConDecl Name] -> LSig Name extractRecSel _ _ _ [] = error "extractRecSel: selector not found" diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index de599bd8..724f59bc 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -579,6 +579,12 @@ makeModuleQual qual aliases mdl = OptFullQual -> FullQual OptNoQual -> NoQual +-- | Whether to hide empty contexts +-- Since pattern synonyms have two contexts with different semantics, it is +-- important to all of them, even if one of them is empty. +data HideEmptyContexts + = HideEmptyContexts + | ShowEmptyToplevelContexts ----------------------------------------------------------------------------- -- * Error handling diff --git a/html-test/ref/ConstructorPatternExport.html b/html-test/ref/ConstructorPatternExport.html new file mode 100644 index 00000000..20f00d0f --- /dev/null +++ b/html-test/ref/ConstructorPatternExport.html @@ -0,0 +1,124 @@ +ConstructorPatternExport
    Safe HaskellSafe

    ConstructorPatternExport

    Documentation

    pattern FooCons :: String -> a -> Foo a #

    pattern MyRecCons :: Bool -> Int -> MyRec #

    pattern (:+) :: String -> a -> MyInfix a #

    pattern BlubCons :: () => Show b => b -> Blub #

    pattern MyGADTCons :: () => forall a. Eq a => a -> Int -> MyGADT (Maybe String) #

    \ No newline at end of file diff --git a/html-test/ref/PatternSyns.html b/html-test/ref/PatternSyns.html index 2cf936b3..37596645 100644 --- a/html-test/ref/PatternSyns.html +++ b/html-test/ref/PatternSyns.html @@ -99,6 +99,28 @@ window.onload = function () {pageLoad();}; >FooType x1))
  • data BlubType = Show x => BlubCtor x
  • pattern Blub :: () => forall x. Show x => x -> BlubType
  • data (a ::

    data BlubType #

    BlubType is existentially quantified

    Constructors

    Show x => BlubCtor x

    pattern Blub :: () => forall x. Show x => x -> BlubType #

    Pattern synonym for Blub x

    data BlubCons b + +data MyGADT :: * -> * where + MyGADTCons :: forall a. Eq a => a -> Int -> MyGADT (Maybe String) + +pattern MyGADTCons' :: () => forall a. Eq a => a -> Int -> MyGADT (Maybe String) +pattern MyGADTCons' x y = MyGADTCons x y \ No newline at end of file diff --git a/html-test/src/PatternSyns.hs b/html-test/src/PatternSyns.hs index a8de113c..bf0f7848 100644 --- a/html-test/src/PatternSyns.hs +++ b/html-test/src/PatternSyns.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE PatternSynonyms, PolyKinds, TypeOperators #-} +{-# LANGUAGE ExistentialQuantification, PatternSynonyms, PolyKinds, TypeOperators #-} -- | Testing some pattern synonyms module PatternSyns where @@ -15,6 +15,12 @@ pattern Bar x = FooCtor (Foo x) -- | Pattern synonym for (':<->') pattern x :<-> y = (Foo x, Bar y) +-- | BlubType is existentially quantified +data BlubType = forall x. Show x => BlubCtor x + +-- | Pattern synonym for 'Blub' x +pattern Blub x = BlubCtor x + -- | Doc for ('><') data (a :: *) >< b = Empty -- cgit v1.2.3 From a677f1592d292a422b9a8d681b0b63a9af611722 Mon Sep 17 00:00:00 2001 From: Alexander Biehl Date: Sun, 6 Aug 2017 12:44:07 +0200 Subject: Bump haddock-library in haddock-api --- haddock-api/haddock-api.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'haddock-api') diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 6cde7266..ef4bb98c 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -42,7 +42,7 @@ library , Cabal ^>= 2.0.0 , ghc ^>= 8.2 , ghc-paths ^>= 0.1.0.9 - , haddock-library ^>= 1.4.5 + , haddock-library ^>= 1.4.6 , xhtml ^>= 3000.2.2 -- Versions for the dependencies below are transitively pinned by -- cgit v1.2.3 From f1d326b53fbed5d37f2a83c66e73dbbc94a4354f Mon Sep 17 00:00:00 2001 From: Alexander Biehl Date: Sun, 6 Aug 2017 13:18:02 +0200 Subject: Provide --show-interface option to dump interfaces (#645) * WIP: Provide --show-interface option to dump interfaces Like ghcs own --show-iface this flag dumps a binary interface file to stdout in a human (and machine) readable fashion. Currently it uses json as output format. * Fill all the jsonNull stubs * Rework Bifunctor instance of DocH, update changelog and documentation * replace changelog, bring DocMarkupH doc back * Update CHANGES.md * Update CHANGES.md * Move Control.Arrow up It would result in unused import if the Bifunctor instance is not generated. --- doc/invoking.rst | 5 + haddock-api/haddock-api.cabal | 1 + haddock-api/src/Haddock.hs | 7 ++ haddock-api/src/Haddock/Interface/Json.hs | 109 +++++++++++++++++++++ haddock-api/src/Haddock/Options.hs | 6 ++ haddock-library/CHANGES.md | 6 ++ haddock-library/src/Documentation/Haddock/Types.hs | 33 ++++++- haddock.cabal | 1 + 8 files changed, 167 insertions(+), 1 deletion(-) create mode 100644 haddock-api/src/Haddock/Interface/Json.hs (limited to 'haddock-api') diff --git a/doc/invoking.rst b/doc/invoking.rst index 83087bac..fc1e4410 100644 --- a/doc/invoking.rst +++ b/doc/invoking.rst @@ -88,6 +88,11 @@ The following options are available: :option:`--read-interface` option for more details. The interface file is in a binary format; don't try to read it. +.. option:: --show-interface= + + Dumps a binary interface file to stdout in a human readable fashion. + Uses json as output format. + .. [1] Haddock interface files are not the same as Haskell interface files, I just couldn't think of a better name. diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index ef4bb98c..d38e9149 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -73,6 +73,7 @@ library Haddock.Interface.Rename Haddock.Interface.Create Haddock.Interface.AttachInstances + Haddock.Interface.Json Haddock.Interface.LexParseRn Haddock.Interface.ParseModuleHeader Haddock.Interface.Specialize diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 57ea5fea..554cb416 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -32,6 +32,7 @@ import Haddock.Backends.LaTeX import Haddock.Backends.Hoogle import Haddock.Backends.Hyperlinker import Haddock.Interface +import Haddock.Interface.Json import Haddock.Parser import Haddock.Types import Haddock.Version @@ -68,6 +69,7 @@ import System.Directory (doesDirectoryExist) import GHC hiding (verbosity) import Config import DynFlags hiding (projectVersion, verbosity) +import ErrUtils import Packages import Panic (handleGhcException) import Module @@ -164,6 +166,11 @@ haddockWithGhc ghc args = handleTopExceptions $ do dflags <- getDynFlags + forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do + mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] + forM_ mIfaceFile $ \(_, ifaceFile) -> do + putMsg dflags (renderJson (jsonInterfaceFile ifaceFile)) + if not (null files) then do (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs new file mode 100644 index 00000000..9a569204 --- /dev/null +++ b/haddock-api/src/Haddock/Interface/Json.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE RecordWildCards #-} +module Haddock.Interface.Json ( + jsonInstalledInterface + , jsonInterfaceFile + , renderJson + ) where + +import BasicTypes +import Json +import Module +import Name +import Outputable + +import Control.Arrow +import Data.Map (Map) +import Data.Bifunctor +import qualified Data.Map as Map + +import Haddock.Types +import Haddock.InterfaceFile + +jsonInterfaceFile :: InterfaceFile -> JsonDoc +jsonInterfaceFile InterfaceFile{..} = + jsonObject [ ("link_env" , jsonMap nameStableString (jsonString . moduleNameString . moduleName) ifLinkEnv) + , ("inst_ifaces", jsonArray (map jsonInstalledInterface ifInstalledIfaces)) + ] + +jsonInstalledInterface :: InstalledInterface -> JsonDoc +jsonInstalledInterface InstalledInterface{..} = jsonObject properties + where + properties = + [ ("module" , jsonModule instMod) + , ("is_sig" , jsonBool instIsSig) + , ("info" , jsonHaddockModInfo instInfo) + , ("doc_map" , jsonMap nameStableString jsonMDoc instDocMap) + , ("arg_map" , jsonMap nameStableString (jsonMap show jsonMDoc) instArgMap) + , ("exports" , jsonArray (map jsonName instExports)) + , ("visible_exports" , jsonArray (map jsonName instVisibleExports)) + , ("options" , jsonArray (map (jsonString . show) instOptions)) + , ("sub_map" , jsonMap nameStableString (jsonArray . map jsonName) instSubMap) + , ("bundled_patsyns" , jsonMap nameStableString (jsonArray . map jsonName) instBundledPatSynMap) + , ("fix_map" , jsonMap nameStableString jsonFixity instFixMap) + ] + +jsonHaddockModInfo :: HaddockModInfo Name -> JsonDoc +jsonHaddockModInfo HaddockModInfo{..} = + jsonObject [ ("description" , jsonMaybe jsonDoc hmi_description) + , ("copyright" , jsonMaybe jsonString hmi_copyright) + , ("maintainer" , jsonMaybe jsonString hmi_maintainer) + , ("stability" , jsonMaybe jsonString hmi_stability) + , ("protability" , jsonMaybe jsonString hmi_portability) + , ("safety" , jsonMaybe jsonString hmi_safety) + , ("language" , jsonMaybe (jsonString . show) hmi_language) + , ("extensions" , jsonArray (map (jsonString . show) hmi_extensions)) + ] + +jsonMap :: (a -> String) -> (b -> JsonDoc) -> Map a b -> JsonDoc +jsonMap f g = jsonObject . map (f *** g) . Map.toList + +jsonMDoc :: MDoc Name -> JsonDoc +jsonMDoc MetaDoc{..} = + jsonObject [ ("meta", jsonObject [("version", jsonMaybe (jsonString . show) (_version _meta))]) + , ("doc", jsonDoc _doc) + ] + +jsonDoc :: Doc Name -> JsonDoc +jsonDoc doc = jsonString (show (bimap (moduleNameString . fst) nameStableString doc)) + +jsonModule :: Module -> JsonDoc +jsonModule = JSString . moduleStableString + +jsonName :: Name -> JsonDoc +jsonName = JSString . nameStableString + +jsonFixity :: Fixity -> JsonDoc +jsonFixity (Fixity _ prec dir) = + jsonObject [ ("prec" , jsonInt prec) + , ("direction" , jsonFixityDirection dir) + ] + +jsonFixityDirection :: FixityDirection -> JsonDoc +jsonFixityDirection InfixL = jsonString "infixl" +jsonFixityDirection InfixR = jsonString "infixr" +jsonFixityDirection InfixN = jsonString "infix" + +renderJson :: JsonDoc -> SDoc +renderJson = renderJSON + +jsonMaybe :: (a -> JsonDoc) -> Maybe a -> JsonDoc +jsonMaybe = maybe jsonNull + +jsonString :: String -> JsonDoc +jsonString = JSString + +jsonObject :: [(String, JsonDoc)] -> JsonDoc +jsonObject = JSObject + +jsonArray :: [JsonDoc] -> JsonDoc +jsonArray = JSArray + +jsonNull :: JsonDoc +jsonNull = JSNull + +jsonInt :: Int -> JsonDoc +jsonInt = JSInt + +jsonBool :: Bool -> JsonDoc +jsonBool = JSBool + diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs index 0449c829..d73d1a79 100644 --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -25,6 +25,7 @@ module Haddock.Options ( sourceUrls, wikiUrls, optDumpInterfaceFile, + optShowInterfaceFile, optLaTeXStyle, optMathjax, qualification, @@ -53,6 +54,7 @@ data Flag -- | Flag_DocBook | Flag_ReadInterface String | Flag_DumpInterface String + | Flag_ShowInterface String | Flag_Heading String | Flag_Html | Flag_Hoogle @@ -112,6 +114,8 @@ options backwardsCompat = "read an interface from FILE", Option ['D'] ["dump-interface"] (ReqArg Flag_DumpInterface "FILE") "write the resulting interface to FILE", + Option [] ["show-interface"] (ReqArg Flag_ShowInterface "FILE") + "print the interface in a human readable form", -- Option ['S'] ["docbook"] (NoArg Flag_DocBook) -- "output in DocBook XML", Option ['h'] ["html"] (NoArg Flag_Html) @@ -270,6 +274,8 @@ wikiUrls flags = optDumpInterfaceFile :: [Flag] -> Maybe FilePath optDumpInterfaceFile flags = optLast [ str | Flag_DumpInterface str <- flags ] +optShowInterfaceFile :: [Flag] -> Maybe FilePath +optShowInterfaceFile flags = optLast [ str | Flag_ShowInterface str <- flags ] optLaTeXStyle :: [Flag] -> Maybe String optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ] diff --git a/haddock-library/CHANGES.md b/haddock-library/CHANGES.md index bebb9982..c52908e1 100644 --- a/haddock-library/CHANGES.md +++ b/haddock-library/CHANGES.md @@ -1,3 +1,9 @@ +## Changes in version 1.4.6 + + * to be released + + * Bifunctor instance for DocH + ## Changes in version 1.4.5 * Move markup related data types to haddock-library diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs index 0ab6bb4c..22cab425 100644 --- a/haddock-library/src/Documentation/Haddock/Types.hs +++ b/haddock-library/src/Documentation/Haddock/Types.hs @@ -19,6 +19,11 @@ import Data.Foldable import Data.Traversable #endif +#if MIN_VERSION_base(4,8,0) +import Control.Arrow ((***)) +import Data.Bifunctor +#endif + -- | With the advent of 'Version', we may want to start attaching more -- meta-data to comments. We make a structure for this ahead of time -- so we don't have to gut half the core each time we want to add such @@ -81,6 +86,33 @@ data DocH mod id | DocHeader (Header (DocH mod id)) deriving (Eq, Show, Functor, Foldable, Traversable) +#if MIN_VERSION_base(4,8,0) +instance Bifunctor DocH where + bimap _ _ DocEmpty = DocEmpty + bimap f g (DocAppend docA docB) = DocAppend (bimap f g docA) (bimap f g docB) + bimap _ _ (DocString s) = DocString s + bimap f g (DocParagraph doc) = DocParagraph (bimap f g doc) + bimap _ g (DocIdentifier i) = DocIdentifier (g i) + bimap f _ (DocIdentifierUnchecked m) = DocIdentifierUnchecked (f m) + bimap _ _ (DocModule s) = DocModule s + bimap f g (DocWarning doc) = DocWarning (bimap f g doc) + bimap f g (DocEmphasis doc) = DocEmphasis (bimap f g doc) + bimap f g (DocMonospaced doc) = DocMonospaced (bimap f g doc) + bimap f g (DocBold doc) = DocBold (bimap f g doc) + bimap f g (DocUnorderedList docs) = DocUnorderedList (map (bimap f g) docs) + bimap f g (DocOrderedList docs) = DocOrderedList (map (bimap f g) docs) + bimap f g (DocDefList docs) = DocDefList (map (bimap f g *** bimap f g) docs) + bimap f g (DocCodeBlock doc) = DocCodeBlock (bimap f g doc) + bimap _ _ (DocHyperlink hyperlink) = DocHyperlink hyperlink + bimap _ _ (DocPic picture) = DocPic picture + bimap _ _ (DocMathInline s) = DocMathInline s + bimap _ _ (DocMathDisplay s) = DocMathDisplay s + bimap _ _ (DocAName s) = DocAName s + bimap _ _ (DocProperty s) = DocProperty s + bimap _ _ (DocExamples examples) = DocExamples examples + bimap f g (DocHeader (Header level title)) = DocHeader (Header level (bimap f g title)) +#endif + -- | 'DocMarkupH' is a set of instructions for marking up documentation. -- In fact, it's really just a mapping from 'Doc' to some other -- type [a], where [a] is usually the type of the output (HTML, say). @@ -114,4 +146,3 @@ data DocMarkupH mod id a = Markup , markupExample :: [Example] -> a , markupHeader :: Header a -> a } - diff --git a/haddock.cabal b/haddock.cabal index 36c80f33..5ae3443c 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -106,6 +106,7 @@ executable haddock Documentation.Haddock Haddock Haddock.Interface + Haddock.Interface.Json Haddock.Interface.Rename Haddock.Interface.Create Haddock.Interface.AttachInstances -- cgit v1.2.3 From f7032e5e48c7a6635e1dca607a37a16c8893e94b Mon Sep 17 00:00:00 2001 From: alexbiehl Date: Wed, 16 Aug 2017 09:06:40 +0200 Subject: Refactoring: Make doc renaming monadic This allows us to later throw warnings if can't find an identifier --- haddock-api/src/Haddock/Interface/Create.hs | 127 ++++++++++++--------- haddock-api/src/Haddock/Interface/LexParseRn.hs | 81 ++++++------- haddock-library/src/Documentation/Haddock/Types.hs | 3 + 3 files changed, 116 insertions(+), 95 deletions(-) (limited to 'haddock-api') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 89f7f71b..87cdb01f 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -30,6 +30,7 @@ import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Ast as Hyperlinker import Haddock.Backends.Hyperlinker.Parser as Hyperlinker +import Data.Bitraversable import qualified Data.ByteString as BS import qualified Data.Map as M import Data.Map (Map) @@ -38,8 +39,6 @@ import Data.Maybe import Data.Monoid import Data.Ord import Control.Applicative -import Control.Arrow (second) -import Control.DeepSeq (force) import Control.Exception (evaluate) import Control.Monad import Data.Traversable @@ -109,7 +108,6 @@ createInterface tm flags modMap instIfaceMap = do exports | OptIgnoreExports `elem` opts = Nothing | otherwise = exports0 - warningMap = mkWarningMap dflags warnings gre exportedNames localBundledPatSyns :: Map Name [Name] localBundledPatSyns = @@ -134,8 +132,10 @@ createInterface tm flags modMap instIfaceMap = do -- Locations of all TH splices splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ] - maps@(!docMap, !argMap, !subMap, !declMap, _) = - mkMaps dflags gre localInsts declsWithDocs + warningMap <- liftErrMsg (mkWarningMap dflags warnings gre exportedNames) + + maps@(!docMap, !argMap, !subMap, !declMap, _) <- + liftErrMsg (mkMaps dflags gre localInsts declsWithDocs) let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap)) @@ -161,7 +161,8 @@ createInterface tm flags modMap instIfaceMap = do let !aliases = mkAliasMap dflags $ tm_renamed_source tm - modWarn = moduleWarning dflags gre warnings + + modWarn <- liftErrMsg (moduleWarning dflags gre warnings) tokenizedSrc <- mkMaybeTokenizedSrc flags tm @@ -245,27 +246,29 @@ lookupModuleDyn dflags Nothing mdlName = -- Warnings ------------------------------------------------------------------------------- -mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> WarningMap +mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> ErrMsgM WarningMap mkWarningMap dflags warnings gre exps = case warnings of - NoWarnings -> M.empty - WarnAll _ -> M.empty + NoWarnings -> pure M.empty + WarnAll _ -> pure M.empty WarnSome ws -> - let ws' = [ (n, w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ + let ws' = [ (n, w) + | (occ, w) <- ws + , elt <- lookupGlobalRdrEnv gre occ , let n = gre_name elt, n `elem` exps ] - in M.fromList $ map (second $ parseWarning dflags gre) ws' + in M.fromList <$> traverse (bitraverse pure (parseWarning dflags gre)) ws' -moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> Maybe (Doc Name) -moduleWarning _ _ NoWarnings = Nothing -moduleWarning _ _ (WarnSome _) = Nothing -moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w +moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> ErrMsgM (Maybe (Doc Name)) +moduleWarning _ _ NoWarnings = pure Nothing +moduleWarning _ _ (WarnSome _) = pure Nothing +moduleWarning dflags gre (WarnAll w) = Just <$> parseWarning dflags gre w -parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name -parseWarning dflags gre w = force $ case w of +parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Doc Name) +parseWarning dflags gre w = case w of DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map (sl_fs . unLoc) msg) WarningTxt _ msg -> format "Warning: " (concatFS $ map (sl_fs . unLoc) msg) where format x xs = DocWarning . DocParagraph . DocAppend (DocString x) - . processDocString dflags gre $ HsDocString xs + <$> processDocString dflags gre (HsDocString xs) ------------------------------------------------------------------------------- @@ -313,16 +316,15 @@ mkMaps :: DynFlags -> GlobalRdrEnv -> [Name] -> [(LHsDecl Name, [HsDocString])] - -> Maps -mkMaps dflags gre instances decls = - let - (a, b, c, d) = unzip4 $ map mappings decls - in ( f' (map (nubByName fst) a) - , f (filterMapping (not . M.null) b) - , f (filterMapping (not . null) c) - , f (filterMapping (not . null) d) - , instanceMap - ) + -> ErrMsgM Maps +mkMaps dflags gre instances decls = do + (a, b, c, d) <- unzip4 <$> traverse mappings decls + pure ( f' (map (nubByName fst) a) + , f (filterMapping (not . M.null) b) + , f (filterMapping (not . null) c) + , f (filterMapping (not . null) d) + , instanceMap + ) where f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b f = M.fromListWith (<>) . concat @@ -334,35 +336,42 @@ mkMaps dflags gre instances decls = filterMapping p = map (filter (p . snd)) mappings :: (LHsDecl Name, [HsDocString]) - -> ( [(Name, MDoc Name)] - , [(Name, Map Int (MDoc Name))] - , [(Name, [Name])] - , [(Name, [LHsDecl Name])] - ) - mappings (ldecl, docStrs) = + -> ErrMsgM ( [(Name, MDoc Name)] + , [(Name, Map Int (MDoc Name))] + , [(Name, [Name])] + , [(Name, [LHsDecl Name])] + ) + mappings (ldecl, docStrs) = do let L l decl = ldecl declDoc :: [HsDocString] -> Map Int HsDocString - -> (Maybe (MDoc Name), Map Int (MDoc Name)) - declDoc strs m = - let doc' = processDocStrings dflags gre strs - m' = M.map (processDocStringParas dflags gre) m - in (doc', m') - (doc, args) = declDoc docStrs (typeDocs decl) + -> ErrMsgM (Maybe (MDoc Name), Map Int (MDoc Name)) + declDoc strs m = do + doc' <- processDocStrings dflags gre strs + m' <- traverse (processDocStringParas dflags gre) m + pure (doc', m') + + (doc, args) <- declDoc docStrs (typeDocs decl) + + let subs :: [(Name, [HsDocString], Map Int HsDocString)] subs = subordinates instanceMap decl - (subDocs, subArgs) = unzip $ map (\(_, strs, m) -> declDoc strs m) subs + + (subDocs, subArgs) <- unzip <$> traverse (\(_, strs, m) -> declDoc strs m) subs + + let ns = names l decl subNs = [ n | (n, _, _) <- subs ] dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ] am = [ (n, args) | n <- ns ] ++ zip subNs subArgs sm = [ (n, subNs) | n <- ns ] cm = [ (n, [ldecl]) | n <- ns ++ subNs ] - in seqList ns `seq` - seqList subNs `seq` - doc `seq` - seqList subDocs `seq` - seqList subArgs `seq` - (dm, am, sm, cm) + + seqList ns `seq` + seqList subNs `seq` + doc `seq` + seqList subDocs `seq` + seqList subArgs `seq` + pure (dm, am, sm, cm) instanceMap :: Map SrcSpan Name instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ] @@ -602,16 +611,20 @@ mkExportItems -- do so. -- NB: Pass in identity module, so we can look it up in index correctly moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices - lookupExport (IEGroup lev docStr) = return $ - return . ExportGroup lev "" $ processDocString dflags gre docStr + lookupExport (IEGroup lev docStr) = liftErrMsg $ do + doc <- processDocString dflags gre docStr + return [ExportGroup lev "" doc] - lookupExport (IEDoc docStr) = return $ - return . ExportDoc $ processDocStringParas dflags gre docStr + lookupExport (IEDoc docStr) = liftErrMsg $ do + doc <- processDocStringParas dflags gre docStr + return [ExportDoc doc] lookupExport (IEDocNamed str) = liftErrMsg $ - findNamedDoc str [ unL d | d <- decls ] >>= return . \case - Nothing -> [] - Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc + findNamedDoc str [ unL d | d <- decls ] >>= \case + Nothing -> return [] + Just docStr -> do + doc <- processDocStringParas dflags gre docStr + return [ExportDoc doc] declWith :: [(HsDecl Name, DocForDecl Name)] -> Name -> ErrMsgGhc [ ExportItem Name ] declWith pats t = do @@ -924,9 +937,11 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name)) mkExportItem (L _ (DocD (DocGroup lev docStr))) = do - return . Just . ExportGroup lev "" $ processDocString dflags gre docStr + doc <- liftErrMsg (processDocString dflags gre docStr) + return . Just . ExportGroup lev "" $ doc mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do - return . Just . ExportDoc $ processDocStringParas dflags gre docStr + doc <- liftErrMsg (processDocStringParas dflags gre docStr) + return . Just . ExportDoc $ doc mkExportItem (L l (ValD d)) | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap = -- Top-level binding without type signature. diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 4f6b2c09..a38e7667 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -34,20 +34,21 @@ import RdrName import RnEnv (dataTcOccs) processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] - -> Maybe (MDoc Name) -processDocStrings dflags gre strs = - case metaDocConcat $ map (processDocStringParas dflags gre) strs of + -> ErrMsgM (Maybe (MDoc Name)) +processDocStrings dflags gre strs = do + mdoc <- metaDocConcat <$> traverse (processDocStringParas dflags gre) strs + case mdoc of -- We check that we don't have any version info to render instead -- of just checking if there is no comment: there may not be a -- comment but we still want to pass through any meta data. - MetaDoc { _meta = Meta { _version = Nothing }, _doc = DocEmpty } -> Nothing - x -> Just x + MetaDoc { _meta = Meta { _version = Nothing }, _doc = DocEmpty } -> pure Nothing + x -> pure (Just x) -processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> MDoc Name +processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (MDoc Name) processDocStringParas dflags gre (HsDocString fs) = - overDoc (rename dflags gre) $ parseParas dflags (unpackFS fs) + overDocF (rename dflags gre) $ parseParas dflags (unpackFS fs) -processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name +processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Doc Name) processDocString dflags gre (HsDocString fs) = rename dflags gre $ parseString dflags (unpackFS fs) @@ -60,9 +61,11 @@ processModuleHeader dflags gre safety mayStr = do Just (L _ (HsDocString fs)) -> do let str = unpackFS fs (hmi, doc) = parseModuleHeader dflags str - !descr = rename dflags gre <$> hmi_description hmi - hmi' = hmi { hmi_description = descr } - doc' = overDoc (rename dflags gre) doc + !descr <- case hmi_description hmi of + Just hmi_descr -> Just <$> rename dflags gre hmi_descr + Nothing -> pure Nothing + let hmi' = hmi { hmi_description = descr } + doc' <- overDocF (rename dflags gre) doc return (hmi', Just doc') let flags :: [LangExt.Extension] @@ -82,12 +85,12 @@ processModuleHeader dflags gre safety mayStr = do -- fallbacks in case we can't locate the identifiers. -- -- See the comments in the source for implementation commentary. -rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name +rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> ErrMsgM (Doc Name) rename dflags gre = rn where rn d = case d of - DocAppend a b -> DocAppend (rn a) (rn b) - DocParagraph doc -> DocParagraph (rn doc) + DocAppend a b -> DocAppend <$> rn a <*> rn b + DocParagraph doc -> DocParagraph <$> rn doc DocIdentifier x -> do -- Generate the choices for the possible kind of thing this -- is. @@ -100,7 +103,7 @@ rename dflags gre = rn -- We found no names in the env so we start guessing. [] -> case choices of - [] -> DocMonospaced (DocString (showPpr dflags x)) + [] -> pure (DocMonospaced (DocString (showPpr dflags x))) -- There was nothing in the environment so we need to -- pick some default from what's available to us. We -- diverge here from the old way where we would default @@ -109,37 +112,37 @@ rename dflags gre = rn -- type constructor names (such as in #253). So now we -- only get type constructor links if they are actually -- in scope. - a:_ -> outOfScope dflags a + a:_ -> pure (outOfScope dflags a) -- There is only one name in the environment that matches so -- use it. - [a] -> DocIdentifier a + [a] -> pure (DocIdentifier a) -- But when there are multiple names available, default to -- type constructors: somewhat awfully GHC returns the -- values in the list positionally. - a:b:_ | isTyConName a -> DocIdentifier a - | otherwise -> DocIdentifier b + a:b:_ | isTyConName a -> pure (DocIdentifier a) + | otherwise -> pure (DocIdentifier b) - DocWarning doc -> DocWarning (rn doc) - DocEmphasis doc -> DocEmphasis (rn doc) - DocBold doc -> DocBold (rn doc) - DocMonospaced doc -> DocMonospaced (rn doc) - DocUnorderedList docs -> DocUnorderedList (map rn docs) - DocOrderedList docs -> DocOrderedList (map rn docs) - DocDefList list -> DocDefList [ (rn a, rn b) | (a, b) <- list ] - DocCodeBlock doc -> DocCodeBlock (rn doc) - DocIdentifierUnchecked x -> DocIdentifierUnchecked x - DocModule str -> DocModule str - DocHyperlink l -> DocHyperlink l - DocPic str -> DocPic str - DocMathInline str -> DocMathInline str - DocMathDisplay str -> DocMathDisplay str - DocAName str -> DocAName str - DocProperty p -> DocProperty p - DocExamples e -> DocExamples e - DocEmpty -> DocEmpty - DocString str -> DocString str - DocHeader (Header l t) -> DocHeader $ Header l (rn t) + DocWarning doc -> DocWarning <$> rn doc + DocEmphasis doc -> DocEmphasis <$> rn doc + DocBold doc -> DocBold <$> rn doc + DocMonospaced doc -> DocMonospaced <$> rn doc + DocUnorderedList docs -> DocUnorderedList <$> traverse rn docs + DocOrderedList docs -> DocOrderedList <$> traverse rn docs + DocDefList list -> DocDefList <$> traverse (\(a, b) -> (,) <$> rn a <*> rn b) list + DocCodeBlock doc -> DocCodeBlock <$> rn doc + DocIdentifierUnchecked x -> pure (DocIdentifierUnchecked x) + DocModule str -> pure (DocModule str) + DocHyperlink l -> pure (DocHyperlink l) + DocPic str -> pure (DocPic str) + DocMathInline str -> pure (DocMathInline str) + DocMathDisplay str -> pure (DocMathDisplay str) + DocAName str -> pure (DocAName str) + DocProperty p -> pure (DocProperty p) + DocExamples e -> pure (DocExamples e) + DocEmpty -> pure (DocEmpty) + DocString str -> pure (DocString str) + DocHeader (Header l t) -> DocHeader . Header l <$> rn t -- | Wrap an identifier that's out of scope (i.e. wasn't found in -- 'GlobalReaderEnv' during 'rename') in an appropriate doc. Currently diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs index 48b29075..1e76c631 100644 --- a/haddock-library/src/Documentation/Haddock/Types.hs +++ b/haddock-library/src/Documentation/Haddock/Types.hs @@ -56,6 +56,9 @@ instance Bitraversable MetaDoc where overDoc :: (DocH a b -> DocH c d) -> MetaDoc a b -> MetaDoc c d overDoc f d = d { _doc = f $ _doc d } +overDocF :: Functor f => (DocH a b -> f (DocH c d)) -> MetaDoc a b -> f (MetaDoc c d) +overDocF f d = (\x -> d { _doc = x }) <$> f (_doc d) + type Version = [Int] data Hyperlink = Hyperlink -- cgit v1.2.3 From 740458ac4d2acf197f2ef8dc94a66f9b160b9c3c Mon Sep 17 00:00:00 2001 From: Alexander Biehl Date: Sat, 19 Aug 2017 20:35:27 +0200 Subject: Hyperlinker: Avoid linear lookup in enrichToken (#669) * Make Span strict in Position * Hyperlinker: Use a proper map to enrich tokens --- .../src/Haddock/Backends/Hyperlinker/Ast.hs | 80 ++++++++++++---------- .../src/Haddock/Backends/Hyperlinker/Types.hs | 14 ++-- 2 files changed, 53 insertions(+), 41 deletions(-) (limited to 'haddock-api') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 78beacf2..9d273417 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} @@ -13,9 +14,13 @@ import Haddock.Backends.Hyperlinker.Types import qualified GHC import Control.Applicative +import Control.Monad (guard) import Data.Data +import qualified Data.Map.Strict as Map import Data.Maybe +import Prelude hiding (span) + everythingInRenamedSource :: (Alternative f, Data x) => (forall a. Data a => a -> f r) -> x -> f r everythingInRenamedSource f = Syb.everythingButType @GHC.Name (<|>) f @@ -28,25 +33,45 @@ enrich src = , rtkDetails = enrichToken token detailsMap } where - detailsMap = concatMap ($ src) - [ variables - , types - , decls - , binds - , imports - ] + detailsMap = + mkDetailsMap (concatMap ($ src) + [ variables + , types + , decls + , binds + , imports + ]) + +type LTokenDetails = [(GHC.SrcSpan, TokenDetails)] -- | A map containing association between source locations and "details" of -- this location. -- --- For the time being, it is just a list of pairs. However, looking up things --- in such structure has linear complexity. We cannot use any hashmap-like --- stuff because source locations are not ordered. In the future, this should --- be replaced with interval tree data structure. -type DetailsMap = [(GHC.SrcSpan, TokenDetails)] +type DetailsMap = Map.Map Position (Span, TokenDetails) + +mkDetailsMap :: [(GHC.SrcSpan, TokenDetails)] -> DetailsMap +mkDetailsMap xs = + Map.fromListWith select_details [ (start, (token_span, token_details)) + | (ghc_span, token_details) <- xs + , Just !token_span <- [ghcSrcSpanToSpan ghc_span] + , let start = spStart token_span + ] + where + -- favour token details which appear earlier in the list + select_details _new old = old lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails -lookupBySpan tspan = listToMaybe . map snd . filter (matches tspan . fst) +lookupBySpan span details = do + (_, (tok_span, tok_details)) <- Map.lookupLE (spStart span) details + guard (tok_span `containsSpan` span ) + return tok_details + +ghcSrcSpanToSpan :: GHC.SrcSpan -> Maybe Span +ghcSrcSpanToSpan (GHC.RealSrcSpan span) = + Just (Span { spStart = Position (GHC.srcSpanStartLine span) (GHC.srcSpanStartCol span) + , spEnd = Position (GHC.srcSpanEndLine span) (GHC.srcSpanEndCol span) + }) +ghcSrcSpanToSpan _ = Nothing enrichToken :: Token -> DetailsMap -> Maybe TokenDetails enrichToken (Token typ _ spn) dm @@ -54,7 +79,7 @@ enrichToken (Token typ _ spn) dm enrichToken _ _ = Nothing -- | Obtain details map for variables ("normally" used identifiers). -variables :: GHC.RenamedSource -> DetailsMap +variables :: GHC.RenamedSource -> LTokenDetails variables = everythingInRenamedSource (var `Syb.combine` rec) where @@ -70,7 +95,7 @@ variables = _ -> empty -- | Obtain details map for types. -types :: GHC.RenamedSource -> DetailsMap +types :: GHC.RenamedSource -> LTokenDetails types = everythingInRenamedSource ty where ty term = case cast term of @@ -84,7 +109,7 @@ types = everythingInRenamedSource ty -- ordinary assignment (in top-level declarations, let-expressions and where -- clauses). -binds :: GHC.RenamedSource -> DetailsMap +binds :: GHC.RenamedSource -> LTokenDetails binds = everythingInRenamedSource (fun `Syb.combine` pat `Syb.combine` tvar) where @@ -112,7 +137,7 @@ binds = everythingInRenamedSource _ -> empty -- | Obtain details map for top-level declarations. -decls :: GHC.RenamedSource -> DetailsMap +decls :: GHC.RenamedSource -> LTokenDetails decls (group, _, _, _) = concatMap ($ group) [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds , everythingInRenamedSource fun . GHC.hs_valds @@ -151,7 +176,7 @@ decls (group, _, _, _) = concatMap ($ group) -- -- This map also includes type and variable details for items in export and -- import lists. -imports :: GHC.RenamedSource -> DetailsMap +imports :: GHC.RenamedSource -> LTokenDetails imports src@(_, imps, _, _) = everythingInRenamedSource ie src ++ mapMaybe (imp . GHC.unLoc) imps where @@ -168,22 +193,3 @@ imports src@(_, imps, _, _) = let (GHC.L sspan name) = GHC.ideclName idecl in Just (sspan, RtkModule name) imp _ = Nothing - --- | Check whether token stream span matches GHC source span. --- --- Currently, it is implemented as checking whether "our" span is contained --- in GHC span. The reason for that is because GHC span are generally wider --- and may spread across couple tokens. For example, @(>>=)@ consists of three --- tokens: @(@, @>>=@, @)@, but GHC source span associated with @>>=@ variable --- contains @(@ and @)@. Similarly, qualified identifiers like @Foo.Bar.quux@ --- are tokenized as @Foo@, @.@, @Bar@, @.@, @quux@ but GHC source span --- associated with @quux@ contains all five elements. -matches :: Span -> GHC.SrcSpan -> Bool -matches tspan (GHC.RealSrcSpan aspan) - | saspan <= stspan && etspan <= easpan = True - where - stspan = (posRow . spStart $ tspan, posCol . spStart $ tspan) - etspan = (posRow . spEnd $ tspan, posCol . spEnd $ tspan) - saspan = (GHC.srcSpanStartLine aspan, GHC.srcSpanStartCol aspan) - easpan = (GHC.srcSpanEndLine aspan, GHC.srcSpanEndCol aspan) -matches _ _ = False diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs index b27ec4d8..d8ae89e4 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs @@ -10,7 +10,7 @@ import qualified Data.Map as Map data Token = Token { tkType :: TokenType , tkValue :: String - , tkSpan :: Span + , tkSpan :: {-# UNPACK #-} !Span } deriving (Show) @@ -18,14 +18,20 @@ data Position = Position { posRow :: !Int , posCol :: !Int } - deriving (Show) + deriving (Eq, Ord, Show) data Span = Span - { spStart :: Position - , spEnd :: Position + { spStart :: !Position + , spEnd :: !Position } deriving (Show) +-- | Tests whether the first span "contains" the other span, meaning +-- that it covers at least as much source code. True where spans are equal. +containsSpan :: Span -> Span -> Bool +containsSpan s1 s2 = + spStart s1 <= spStart s2 && spEnd s1 >= spEnd s2 + data TokenType = TkIdentifier | TkKeyword -- cgit v1.2.3