diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,42 @@ +## Changes in version 2.19.0.1 + + * Support for linking unicode operators (#458) + + * Hyperlinker: Fix file handle leak in (#763) + +## Changes in version 2.19.0 + + * Haddock now supports tables in documentation inspired by reSTs grid tables + + * `--quickjump` allows for quick navigation in documentation on hackage and + other documentation hosting sites. + + * A --reexport flag, which can be used to add extra modules to the + top-level module tree + + * Haddock no longer reports coverage statistics for hidden modules. By default + cabal-install marks all package internal modules as hidden. + + * Haddock now writes additional information about the documentation to `meta.json` + + * Fix renaming of type variables after specializing instance method signatures (#613) + + * 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) + + * The hyperlinker backend now uses the GHC lexer instead of a custom one. + This notably fixes rendering of quasiquotes. + + * Overhaul Haddock's rendering of kind signatures so that invisible kind + parameters are not printed (#681) + + * Recognise `SPDX-License-Identifier` as alias for `License` in module header + parser (#743) + ## Changes in version 2.18.1 * Synopsis is working again (#599) diff --git a/doc/invoking.rst b/doc/invoking.rst --- a/doc/invoking.rst +++ b/doc/invoking.rst @@ -39,7 +39,7 @@ .. option:: -B - Tell GHC that that its lib directory is dir. Can be used to override + Tell GHC that its lib directory is dir. Can be used to override the default path. .. option:: -o @@ -87,6 +87,11 @@ that refers to the modules currently being processed - see the :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, diff --git a/doc/markup.rst b/doc/markup.rst --- a/doc/markup.rst +++ b/doc/markup.rst @@ -1078,6 +1078,26 @@ inside the documentation. For example, the HTML backend will display the mathematics via `MathJax `__. +Grid Tables +~~~~~~~~~~~ + +Inspired by reSTs grid tables Haddock supports a complete table representation via a grid-like "ASCII art". Grid tables are described with a visual grid made up of the characters "-", "=", "|", and "+". The hyphen ("-") is used for horizontal lines (row separators). The equals sign ("=") may be used to separate optional header rows from the table body. The vertical bar ("|") is used for vertical lines (column separators). The plus sign ("+") is used for intersections of horizontal and vertical lines. :: + + -- | This is a grid table: + -- + -- +------------------------+------------+----------+----------+ + -- | Header row, column 1 | Header 2 | Header 3 | Header 4 | + -- | (header rows optional) | | | | + -- +========================+============+==========+==========+ + -- | body row 1, column 1 | column 2 | column 3 | column 4 | + -- +------------------------+------------+----------+----------+ + -- | body row 2 | Cells may span columns. | + -- +------------------------+------------+---------------------+ + -- | body row 3 | Cells may | \[ | + -- +------------------------+ span rows. | f(n) = \sum_{i=1} | + -- | body row 4 | | \] | + -- +------------------------+------------+---------------------+ + Anchors ~~~~~~~ diff --git a/haddock-api/src/Documentation/Haddock.hs b/haddock-api/src/Documentation/Haddock.hs --- a/haddock-api/src/Documentation/Haddock.hs +++ b/haddock-api/src/Documentation/Haddock.hs @@ -39,7 +39,8 @@ DocH(..), Example(..), Hyperlink(..), - DocMarkup(..), + DocMarkup, + DocMarkupH(..), Documentation(..), ArgMap, AliasMap, @@ -69,12 +70,11 @@ withGhc ) where - +import Documentation.Haddock.Markup (markup) import Haddock.InterfaceFile import Haddock.Interface import Haddock.Types import Haddock.Options -import Haddock.Utils import Haddock diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -27,11 +27,13 @@ import Data.Version import Haddock.Backends.Xhtml +import Haddock.Backends.Xhtml.Meta import Haddock.Backends.Xhtml.Themes (getThemes) 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 @@ -41,7 +43,8 @@ import Control.Monad hiding (forM_) import Control.Applicative -import Data.Foldable (forM_) +import Data.Foldable (forM_, foldl') +import Data.Traversable (for) import Data.List (isPrefixOf) import Control.Exception import Data.Maybe @@ -65,9 +68,11 @@ import System.Directory (doesDirectoryExist) #endif +import Text.ParserCombinators.ReadP (readP_to_S) import GHC hiding (verbosity) import Config import DynFlags hiding (projectVersion, verbosity) +import ErrUtils import Packages import Panic (handleGhcException) import Module @@ -161,9 +166,13 @@ hPutStrLn stderr warning ghc flags' $ 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 @@ -268,7 +277,7 @@ | Flag_HyperlinkedSource `elem` flags = Just hypSrcModuleUrlFormat | otherwise = srcModule - srcMap = mkSrcMap $ Map.union + srcMap = Map.union (Map.map SrcExternal extSrcMap) (Map.fromList [ (ifaceMod iface, SrcLocal) | iface <- ifaces ]) @@ -288,30 +297,52 @@ sourceUrls' = (srcBase, srcModule', pkgSrcMap', pkgSrcLMap') + installedMap :: Map Module InstalledInterface + installedMap = Map.fromList [ (unwire (instMod iface), iface) | iface <- installedIfaces ] + + -- The user gives use base-4.9.0.0, but the InstalledInterface + -- records the *wired in* identity base. So untranslate it + -- so that we can service the request. + unwire :: Module -> Module + unwire m = m { moduleUnitId = unwireUnitId dflags (moduleUnitId m) } + + reexportedIfaces <- concat `fmap` (for (reexportFlags flags) $ \mod_str -> do + let warn = hPutStrLn stderr . ("Warning: " ++) + case readP_to_S parseModuleId mod_str of + [(m, "")] + | Just iface <- Map.lookup m installedMap + -> return [iface] + | otherwise + -> warn ("Cannot find reexported module '" ++ mod_str ++ "'") >> return [] + _ -> warn ("Cannot parse reexported module flag '" ++ mod_str ++ "'") >> return []) + libDir <- getHaddockLibDir flags prologue <- getPrologue dflags' flags themes <- getThemes libDir flags >>= either bye return + let withQuickjump = Flag_QuickJumpIndex `elem` flags + when (Flag_GenIndex `elem` flags) $ do ppHtmlIndex odir title pkgStr themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls allVisibleIfaces pretty - copyHtmlBits odir libDir themes + copyHtmlBits odir libDir themes withQuickjump when (Flag_GenContents `elem` flags) $ do ppHtmlContents dflags' odir title pkgStr themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls allVisibleIfaces True prologue pretty (makeContentsQual qual) - copyHtmlBits odir libDir themes + copyHtmlBits odir libDir themes withQuickjump when (Flag_Html `elem` flags) $ do - ppHtml dflags' title pkgStr visibleIfaces odir + ppHtml dflags' title pkgStr visibleIfaces reexportedIfaces odir prologue themes opt_mathjax sourceUrls' opt_wiki_urls opt_contents_url opt_index_url unicode qual - pretty - copyHtmlBits odir libDir themes + pretty withQuickjump + copyHtmlBits odir libDir themes withQuickjump + writeHaddockMeta odir withQuickjump -- TODO: we throw away Meta for both Hoogle and LaTeX right now, -- might want to fix that if/when these two get some work on them @@ -397,23 +428,50 @@ ghcMode = CompManager, ghcLink = NoLink } - let dynflags'' = updOptLevel 0 $ gopt_unset dynflags' Opt_SplitObjs - + -- We disable pattern match warnings because than can be very + -- expensive to check + let dynflags'' = unsetPatternMatchWarnings $ + updOptLevel 0 $ + gopt_unset dynflags' Opt_SplitObjs -- 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 + + -- ignore sublists of flags that start with "+RTS" and end in "-RTS" + -- + -- See https://github.com/haskell/haddock/issues/666 + filterRtsFlags :: [String] -> [String] + filterRtsFlags flgs = foldr go (const []) flgs True + where go "-RTS" func _ = func True + go "+RTS" func _ = func False + go _ func False = func False + go arg func True = arg : func True + + parseGhcFlags :: MonadIO m => DynFlags -> m DynFlags parseGhcFlags dynflags = do -- TODO: handle warnings? - (dynflags', rest, _) <- parseDynamicFlags dynflags (map noLoc flags) + let flags' = filterRtsFlags flags + (dynflags', rest, _) <- parseDynamicFlags dynflags (map noLoc flags') if not (null rest) - then throwE ("Couldn't parse GHC options: " ++ unwords flags) + then throwE ("Couldn't parse GHC options: " ++ unwords flags') else return dynflags' +unsetPatternMatchWarnings :: DynFlags -> DynFlags +unsetPatternMatchWarnings dflags = + foldl' wopt_unset dflags pattern_match_warnings + where + pattern_match_warnings = + [ Opt_WarnIncompletePatterns + , Opt_WarnIncompleteUniPatterns + , Opt_WarnIncompletePatternsRecUpd + , Opt_WarnOverlappingPatterns + ] + ------------------------------------------------------------------------------- -- * Misc ------------------------------------------------------------------------------- @@ -438,9 +496,9 @@ exists <- doesDirectoryExist p pure $ if exists then Just p else Nothing - dirs <- mapM check res_dirs + dirs <- mapM check res_dirs case [p | Just p <- dirs] of - (p : _) -> return p + (p : _) -> return p _ -> die "Haddock's resource directory does not exist!\n" #endif fs -> return (last fs) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -18,6 +18,7 @@ import BasicTypes (OverlapFlag(..), OverlapMode(..), SourceText(..)) import InstEnv (ClsInst(..)) +import Documentation.Haddock.Markup import Haddock.GhcUtils import Haddock.Types hiding (Version) import Haddock.Utils hiding (out) @@ -86,7 +87,7 @@ f (HsDocTy a _) = f $ unL a f x = x -outHsType :: (OutputableBndrId a) +outHsType :: (SourceTextX a, OutputableBndrId a) => DynFlags -> HsType a -> String outHsType dflags = out dflags . dropHsDocTy @@ -117,7 +118,7 @@ --------------------------------------------------------------------- -- How to print each export -ppExport :: DynFlags -> ExportItem Name -> [String] +ppExport :: DynFlags -> ExportItem GhcRn -> [String] ppExport dflags ExportDecl { expItemDecl = L _ decl , expItemMbDoc = (dc, _) , expItemSubDocs = subdocs @@ -135,29 +136,29 @@ ppFixities = concatMap (ppFixity dflags) fixities ppExport _ _ = [] -ppSigWithDoc :: DynFlags -> Sig Name -> [(Name, DocForDecl Name)] -> [String] +ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String] ppSigWithDoc dflags (TypeSig names sig) subdocs = concatMap mkDocSig names where mkDocSig n = concatMap (ppDocumentation dflags) (getDoc n) - ++ [pp_sig dflags names (hsSigWcType sig)] + ++ [pp_sig dflags [n] (hsSigWcType sig)] getDoc :: Located Name -> [Documentation Name] getDoc n = maybe [] (return . fst) (lookup (unL n) subdocs) ppSigWithDoc _ _ _ = [] -ppSig :: DynFlags -> Sig Name -> [String] +ppSig :: DynFlags -> Sig GhcRn -> [String] ppSig dflags x = ppSigWithDoc dflags x [] -pp_sig :: DynFlags -> [Located Name] -> LHsType Name -> String +pp_sig :: DynFlags -> [Located Name] -> LHsType GhcRn -> String pp_sig dflags names (L _ typ) = operator prettyNames ++ " :: " ++ outHsType dflags typ where prettyNames = intercalate ", " $ map (out dflags) names -- note: does not yet output documentation for class methods -ppClass :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String] +ppClass :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String] ppClass dflags decl subdocs = (out dflags decl{tcdSigs=[], tcdATs=[], tcdATDefs=[], tcdMeths=emptyLHsBinds} ++ ppTyFams) : ppMethods @@ -177,17 +178,17 @@ whereWrapper elems = vcat' [ text "where" <+> lbrace - , nest 4 . vcat . map (<> semi) $ elems + , nest 4 . vcat . map (Outputable.<> semi) $ elems , rbrace ] - tyFamEqnToSyn :: TyFamDefltEqn Name -> TyClDecl Name + tyFamEqnToSyn :: TyFamDefltEqn GhcRn -> TyClDecl GhcRn tyFamEqnToSyn tfe = SynDecl - { tcdLName = tfe_tycon tfe - , tcdTyVars = tfe_pats tfe - , tcdFixity = tfe_fixity tfe - , tcdRhs = tfe_rhs tfe - , tcdFVs = emptyNameSet + { tcdLName = feqn_tycon tfe + , tcdTyVars = feqn_pats tfe + , tcdFixity = feqn_fixity tfe + , tcdRhs = feqn_rhs tfe + , tcdFVs = emptyNameSet } @@ -203,10 +204,10 @@ cls = x { is_flag = OverlapFlag { overlapMode = NoOverlap NoSourceText , isSafeOverlap = False } } -ppSynonym :: DynFlags -> TyClDecl Name -> [String] +ppSynonym :: DynFlags -> TyClDecl GhcRn -> [String] ppSynonym dflags x = [out dflags x] -ppData :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String] +ppData :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String] ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=noLoc [] }} : concatMap (ppCtor dflags decl subdocs . unL) (dd_cons defn) @@ -227,7 +228,7 @@ Just (d, _) -> ppDocumentation dflags d _ -> [] -ppCtor :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String] +ppCtor :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> ConDecl GhcRn -> [String] ppCtor dflags dat subdocs con@ConDeclH98 {} -- AZ:TODO get rid of the concatMap = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConDetails con) @@ -261,7 +262,7 @@ ppFixity :: DynFlags -> (Name, Fixity) -> [String] -ppFixity dflags (name, fixity) = [out dflags (FixitySig [noLoc name] fixity)] +ppFixity dflags (name, fixity) = [out dflags ((FixitySig [noLoc name] fixity) :: FixitySig GhcRn)] --------------------------------------------------------------------- @@ -327,7 +328,8 @@ markupAName = const $ str "", markupProperty = box TagPre . str, markupExample = box TagPre . str . unlines . map exampleToString, - markupHeader = \(Header l h) -> box (TagInline $ "h" ++ show l) h + markupHeader = \(Header l h) -> box (TagInline $ "h" ++ show l) h, + markupTable = \(Table _ _) -> str "TODO: table" } diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs --- 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 #-} @@ -11,11 +12,16 @@ import Haddock.Backends.Hyperlinker.Types import qualified GHC +import qualified SrcLoc 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 +34,39 @@ , 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, (span, token_details)) + | (ghc_span, token_details) <- xs + , GHC.RealSrcSpan span <- [ghc_span] + , let start = SrcLoc.realSrcSpanStart 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 + let pos = SrcLoc.realSrcSpanStart span + (_, (tok_span, tok_details)) <- Map.lookupLE pos details + guard (tok_span `SrcLoc.containsSpan` span) + return tok_details enrichToken :: Token -> DetailsMap -> Maybe TokenDetails enrichToken (Token typ _ spn) dm @@ -54,28 +74,31 @@ 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 var term = case cast term of - (Just (GHC.L sspan (GHC.HsVar name))) -> + (Just ((GHC.L sspan (GHC.HsVar name)) :: GHC.LHsExpr GHC.GhcRn)) -> pure (sspan, RtkVar (GHC.unLoc name)) (Just (GHC.L _ (GHC.RecordCon (GHC.L sspan name) _ _ _))) -> pure (sspan, RtkVar name) _ -> empty rec term = case cast term of - Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LHsExpr GHC.Name) _) -> + Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LHsExpr GHC.GhcRn) _) -> pure (sspan, RtkVar name) _ -> empty -- | Obtain details map for types. -types :: GHC.RenamedSource -> DetailsMap +types :: GHC.RenamedSource -> LTokenDetails types = everythingInRenamedSource ty where + ty :: forall a. Data a => a -> [(GHC.SrcSpan, TokenDetails)] ty term = case cast term of - (Just (GHC.L sspan (GHC.HsTyVar _ name))) -> + (Just ((GHC.L sspan (GHC.HsTyVar _ name)) :: GHC.LHsType GHC.GhcRn)) -> pure (sspan, RtkType (GHC.unLoc name)) + (Just ((GHC.L sspan (GHC.HsOpTy l name r)) :: GHC.LHsType GHC.GhcRn)) -> + (sspan, RtkType (GHC.unLoc name)):(ty l ++ ty r) _ -> empty -- | Obtain details map for identifier bindings. @@ -84,16 +107,21 @@ -- 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 fun term = case cast term of - (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name)) -> + (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GhcRn)) -> pure (sspan, RtkBind name) + (Just (GHC.PatSynBind (GHC.PSB (GHC.L sspan name) _ args _ _))) -> + pure (sspan, RtkBind name) ++ everythingInRenamedSource patsyn_binds args _ -> empty + patsyn_binds term = case cast term of + (Just (GHC.L sspan (name :: GHC.Name))) -> pure (sspan, RtkVar name) + _ -> empty pat term = case cast term of - (Just (GHC.L sspan (GHC.VarPat name))) -> + (Just ((GHC.L sspan (GHC.VarPat name)) :: GHC.LPat GHC.GhcRn)) -> pure (sspan, RtkBind (GHC.unLoc name)) (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) -> [(sspan, RtkVar name)] ++ everythingInRenamedSource rec recs @@ -101,21 +129,22 @@ pure (sspan, RtkBind name) _ -> empty rec term = case cast term of - (Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LPat GHC.Name) _)) -> + (Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LPat GHC.GhcRn) _)) -> pure (sspan, RtkVar name) _ -> empty tvar term = case cast term of - (Just (GHC.L sspan (GHC.UserTyVar name))) -> + (Just ((GHC.L sspan (GHC.UserTyVar name)) :: GHC.LHsTyVarBndr GHC.GhcRn)) -> pure (sspan, RtkBind (GHC.unLoc name)) (Just (GHC.L _ (GHC.KindedTyVar (GHC.L sspan name) _))) -> pure (sspan, RtkBind name) _ -> 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 + , everythingInRenamedSource fix . GHC.hs_fixds , everythingInRenamedSource (con `Syb.combine` ins) ] where @@ -123,26 +152,40 @@ GHC.DataDecl { tcdLName = name } -> pure . decl $ name GHC.SynDecl name _ _ _ _ -> pure . decl $ name GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam - GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs + GHC.ClassDecl{..} -> + [decl tcdLName] + ++ concatMap sig tcdSigs + ++ concatMap tyfam tcdATs fun term = case cast term of - (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name)) + (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GhcRn)) | GHC.isExternalName name -> pure (sspan, RtkDecl name) + (Just (GHC.PatSynBind (GHC.PSB (GHC.L sspan name) _ _ _ _))) + | GHC.isExternalName name -> pure (sspan, RtkDecl name) _ -> empty con term = case cast term of - (Just cdcl) -> + (Just (cdcl :: GHC.ConDecl GHC.GhcRn)) -> 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 - (Just (GHC.TyFamInstD (GHC.TyFamInstDecl (GHC.L _ eqn) _))) -> - pure . tyref $ GHC.tfe_tycon eqn + (Just ((GHC.DataFamInstD (GHC.DataFamInstDecl eqn)) + :: GHC.InstDecl GHC.GhcRn)) + -> pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn + (Just (GHC.TyFamInstD (GHC.TyFamInstDecl eqn))) -> + pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn _ -> empty fld term = case cast term of - Just (field :: GHC.ConDeclField GHC.Name) + Just (field :: GHC.ConDeclField GHC.GhcRn) -> map (decl . fmap GHC.selectorFieldOcc) $ GHC.cd_fld_names field Nothing -> empty + fix term = case cast term of + Just ((GHC.FixitySig names _) :: GHC.FixitySig GHC.GhcRn) + -> map decl names + Nothing -> empty + tyfam (GHC.L _ (GHC.FamilyDecl{..})) = [decl fdLName] sig (GHC.L _ (GHC.TypeSig names _)) = map decl names + sig (GHC.L _ (GHC.PatSynSig names _)) = map decl names + sig (GHC.L _ (GHC.ClassOpSig _ names _)) = map decl names sig _ = [] decl (GHC.L sspan name) = (sspan, RtkDecl name) tyref (GHC.L sspan name) = (sspan, RtkType name) @@ -151,39 +194,21 @@ -- -- 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 ie term = case cast term of - (Just (GHC.IEVar v)) -> pure $ var $ GHC.ieLWrappedName v + (Just ((GHC.IEVar v) :: GHC.IE GHC.GhcRn)) -> pure $ var $ GHC.ieLWrappedName v (Just (GHC.IEThingAbs t)) -> pure $ typ $ GHC.ieLWrappedName t (Just (GHC.IEThingAll t)) -> pure $ typ $ GHC.ieLWrappedName t (Just (GHC.IEThingWith t _ vs _fls)) -> [typ $ GHC.ieLWrappedName t] ++ map (var . GHC.ieLWrappedName) vs + (Just (GHC.IEModuleContents m)) -> pure $ modu m _ -> empty typ (GHC.L sspan name) = (sspan, RtkType name) var (GHC.L sspan name) = (sspan, RtkVar name) - imp idecl | not . GHC.ideclImplicit $ idecl = - 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 + modu (GHC.L sspan name) = (sspan, RtkModule name) + imp idecl + | not . GHC.ideclImplicit $ idecl = Just (modu (GHC.ideclName idecl)) + | otherwise = Nothing diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -1,11 +1,17 @@ module Haddock.Backends.Hyperlinker.Parser (parse) where +import Data.Either ( isRight, isLeft ) +import Data.List ( foldl', isPrefixOf, isSuffixOf ) +import Data.Maybe ( maybeToList ) -import Data.Char -import Data.List -import Data.Maybe +import GHC ( DynFlags, addSourceToTokens ) +import SrcLoc +import FastString ( mkFastString ) +import StringBuffer ( stringToStringBuffer ) +import Lexer ( Token(..) ) +import qualified Lexer as L -import Haddock.Backends.Hyperlinker.Types +import Haddock.Backends.Hyperlinker.Types as T -- | Turn source code string into a stream of more descriptive tokens. @@ -13,202 +19,404 @@ -- Result should retain original file layout (including comments, whitespace, -- etc.), i.e. the following "law" should hold: -- --- @concat . map 'tkValue' . 'parse' = id@ -parse :: String -> [Token] -parse = tokenize . tag . chunk +-- prop> concat . map tkValue . parse = id +-- +-- (In reality, this only holds for input not containing '\r', '\t', '\f', '\v', +-- characters, since GHC transforms those into ' ' and '\n') +parse :: DynFlags -> FilePath -> String -> [T.Token] +parse dflags fp s = ghcToks (processCPP dflags fp s) --- | Split raw source string to more meaningful chunks. + +-- | Parse the source into tokens using the GHC lexer. -- --- This is the initial stage of tokenization process. Each chunk is either --- a comment (including comment delimiters), a whitespace string, preprocessor --- macro (and all its content until the end of a line) or valid Haskell lexeme. -chunk :: String -> [String] -chunk [] = [] -chunk str@(c:_) - | isSpace c = - let (space, mcpp, rest) = spanSpaceOrCpp str - in [space] ++ maybeToList mcpp ++ chunk rest -chunk str - | "--" `isPrefixOf` str = chunk' $ spanToNewline str - | "{-" `isPrefixOf` str = chunk' $ chunkComment 0 str - | otherwise = case lex' str of - (tok:_) -> chunk' tok - [] -> [str] +-- * CPP lines are removed and reinserted as line-comments +-- * top-level file pragmas are parsed as block comments (see the +-- 'ITblockComment' case of 'classify' for more details) +-- +processCPP :: DynFlags -- ^ GHC's flags + -> FilePath -- ^ source file name (for position information) + -> String -- ^ source file contents + -> [(Located L.Token, String)] +processCPP dflags fpath s = addSrc . go start . splitCPP $ s where - chunk' (c, rest) = c:(chunk rest) + start = mkRealSrcLoc (mkFastString fpath) 1 1 + addSrc = addSourceToTokens start (stringToStringBuffer s) --- | A bit better lexer then the default, i.e. handles DataKinds quotes -lex' :: ReadS String -lex' ('\'' : '\'' : rest) = [("''", rest)] -lex' str@('\'' : '\\' : _ : '\'' : _) = lex str -lex' str@('\'' : _ : '\'' : _) = lex str -lex' ('\'' : rest) = [("'", rest)] -lex' str = lex str + -- Transform a list of Haskell/CPP lines into a list of tokens + go :: RealSrcLoc -> [Either String String] -> [Located L.Token] + go _ [] = [] + go pos ls = + let (hLinesRight, ls') = span isRight ls + (cppLinesLeft, rest) = span isLeft ls' --- | Split input to "first line" string and the rest of it. + hSrc = concat [ hLine | Right hLine <- hLinesRight ] + cppSrc = concat [ cppLine | Left cppLine <- cppLinesLeft ] + + in case L.lexTokenStream (stringToStringBuffer hSrc) pos dflags of + + -- Stuff that fails to lex gets turned into comments + L.PFailed _ _ss _msg -> + let (src_pos, failed) = mkToken ITunknown pos hSrc + (new_pos, cpp) = mkToken ITlineComment src_pos cppSrc + in failed : cpp : go new_pos rest + + -- Successfully lexed + L.POk ss toks -> + let (new_pos, cpp) = mkToken ITlineComment (L.loc ss) cppSrc + in toks ++ [cpp] ++ go new_pos rest + + -- Manually make a token from a 'String', advancing the cursor position + mkToken tok start' str = + let end = foldl' advanceSrcLoc start' str + in (end, L (RealSrcSpan $ mkRealSrcSpan start' end) (tok str)) + + +-- | Split apart the initial file into Haskell source lines ('Left' entries) and +-- CPP lines ('Right' entries). -- --- Ideally, this should be done simply with @'break' (== '\n')@. However, --- Haskell also allows line-unbreaking (or whatever it is called) so things --- are not as simple and this function deals with that. -spanToNewline :: String -> (String, String) -spanToNewline [] = ([], []) -spanToNewline ('\\':'\n':str) = - let (str', rest) = spanToNewline str - in ('\\':'\n':str', rest) -spanToNewline str@('\n':_) = ("", str) -spanToNewline (c:str) = - let (str', rest) = spanToNewline str - in (c:str', rest) +-- All characters in the input are present in the output: +-- +-- prop> concat . map (either id id) . splitCPP = id +splitCPP :: String -> [Either String String] +splitCPP "" = [] +splitCPP s | isCPPline s = Left l : splitCPP rest + | otherwise = Right l : splitCPP rest + where + ~(l, rest) = spanToNewline 0 s --- | Split input to whitespace string, (optional) preprocessor directive and --- the rest of it. + +-- | Heuristic to decide if a line is going to be a CPP line. This should be a +-- cheap operation since it is going to be run on every line being processed. -- --- Again, using something like @'span' 'isSpace'@ would be nice to chunk input --- to whitespace. The problem is with /#/ symbol - if it is placed at the very --- beginning of a line, it should be recognized as preprocessor macro. In any --- other case, it is ordinary Haskell symbol and can be used to declare --- operators. Hence, while dealing with whitespace we also check whether there --- happens to be /#/ symbol just after a newline character - if that is the --- case, we begin treating the whole line as preprocessor macro. -spanSpaceOrCpp :: String -> (String, Maybe String, String) -spanSpaceOrCpp ('\n':'#':str) = - let (str', rest) = spanToNewline str - in ("\n", Just $ '#':str', rest) -spanSpaceOrCpp (c:str') - | isSpace c = - let (space, mcpp, rest) = spanSpaceOrCpp str' - in (c:space, mcpp, rest) -spanSpaceOrCpp str = ("", Nothing, str) +-- Right now it just checks if the first non-whitespace character in the first +-- five characters of the line is a '#': +-- +-- >>> isCPPline "#define FOO 1" +-- True +-- +-- >>> isCPPline "\t\t #ifdef GHC" +-- True +-- +-- >>> isCPPline " #endif" +-- False +-- +isCPPline :: String -> Bool +isCPPline = isPrefixOf "#" . dropWhile (`elem` " \t") . take 5 --- | Split input to comment content (including delimiters) and the rest. + +-- | Split a "line" off the front of a string, supporting newline escapes. -- --- Again, some more logic than simple 'span' is required because of Haskell --- comment nesting policy. -chunkComment :: Int -> String -> (String, String) -chunkComment _ [] = ("", "") -chunkComment depth ('{':'-':str) = - let (c, rest) = chunkComment (depth + 1) str - in ("{-" ++ c, rest) -chunkComment depth ('-':'}':str) - | depth == 1 = ("-}", str) - | otherwise = - let (c, rest) = chunkComment (depth - 1) str - in ("-}" ++ c, rest) -chunkComment depth (e:str) = - let (c, rest) = chunkComment depth str - in (e:c, rest) +-- By "line", we understand: the shortest substring ending in a '\n' that is not +-- +-- 1. immediately preceded by a '\\' +-- 2. not inside some (possibly nested) block comment +-- +-- All characters in the input are present in the output: +-- +-- prop> curry (++) . spanToNewLine 0 = id +spanToNewline :: Int -- ^ open '{-' + -> String -- ^ input + -> (String, String) +spanToNewline _ [] = ([], []) +spanToNewline n ('\n':str) | n <= 0 = ("\n", str) +spanToNewline n ('\\':'\n':str) = + let (str', rest) = spanToNewline n str + in ('\\':'\n':str', rest) +spanToNewline n ('{':'-':str) = + let (str', rest) = spanToNewline (n+1) str + in ('{':'-':str', rest) +spanToNewline n ('-':'}':str) = + let (str', rest) = spanToNewline (n-1) str + in ('-':'}':str', rest) +spanToNewline n (c:str) = + let (str', rest) = spanToNewline n str + in (c:str', rest) --- | Assign source location for each chunk in given stream. -tag :: [String] -> [(Span, String)] -tag = - reverse . snd . foldl aux (Position 1 1, []) - where - aux (pos, cs) str = - let pos' = foldl move pos str - in (pos', (Span pos pos', str):cs) - move pos '\n' = pos { posRow = posRow pos + 1, posCol = 1 } - move pos _ = pos { posCol = posCol pos + 1 } --- | Turn unrecognised chunk stream to more descriptive token stream. -tokenize :: [(Span, String)] -> [Token] -tokenize = - map aux +-- | Turn a list of GHC's 'L.Token' (and their source 'String') into a list of +-- Haddock's 'T.Token'. +ghcToks :: [(Located L.Token, String)] -> [T.Token] +ghcToks = reverse . (\(_,ts,_) -> ts) . foldl' go (start, [], False) where - aux (sp, str) = Token - { tkType = classify str - , tkValue = str - , tkSpan = sp - } + start = mkRealSrcLoc (mkFastString "lexing") 1 1 --- | Classify given string as appropriate Haskell token. --- --- This method is based on Haskell 98 Report lexical structure description: --- https://www.haskell.org/onlinereport/lexemes.html --- --- However, this is probably far from being perfect and most probably does not --- handle correctly all corner cases. -classify :: String -> TokenType -classify str - | "--" `isPrefixOf` str = TkComment - | "{-#" `isPrefixOf` str = TkPragma - | "{-" `isPrefixOf` str = TkComment -classify "''" = TkSpecial -classify "'" = TkSpecial -classify str@(c:_) - | isSpace c = TkSpace - | isDigit c = TkNumber - | c `elem` special = TkSpecial - | str `elem` glyphs = TkGlyph - | all (`elem` symbols) str = TkOperator - | c == '#' = TkCpp - | c == '"' = TkString - | c == '\'' = TkChar -classify str - | str `elem` keywords = TkKeyword - | isIdentifier str = TkIdentifier - | otherwise = TkUnknown + go :: (RealSrcLoc, [T.Token], Bool) + -- ^ current position, tokens accumulated, currently in pragma (or not) + + -> (Located L.Token, String) + -- ^ next token, its content + + -> (RealSrcLoc, [T.Token], Bool) + -- ^ new position, new tokens accumulated, currently in pragma (or not) -keywords :: [String] -keywords = - [ "as" - , "case" - , "class" - , "data" - , "default" - , "deriving" - , "do" - , "else" - , "hiding" - , "if" - , "import" - , "in" - , "infix" - , "infixl" - , "infixr" - , "instance" - , "let" - , "module" - , "newtype" - , "of" - , "qualified" - , "then" - , "type" - , "where" - , "forall" - , "family" - , "mdo" - ] + go (pos, toks, in_prag) (L l tok, raw) = + ( next_pos + , classifiedTok ++ maybeToList white ++ toks + , inPragma in_prag tok + ) + where + (next_pos, white) = mkWhitespace pos l + + classifiedTok = [ Token (classify' tok) raw rss + | RealSrcSpan rss <- [l] + , not (null raw) + ] + + classify' | in_prag = const TkPragma + | otherwise = classify -glyphs :: [String] -glyphs = - [ ".." - , ":" - , "::" - , "=" - , "\\" - , "|" - , "<-" - , "->" - , "@" - , "~" - , "~#" - , "=>" - , "-" - , "!" - ] -special :: [Char] -special = "()[]{},;`" +-- | Find the correct amount of whitespace between tokens. +mkWhitespace :: RealSrcLoc -> SrcSpan -> (RealSrcLoc, Maybe T.Token) +mkWhitespace prev spn = + case spn of + UnhelpfulSpan _ -> (prev,Nothing) + RealSrcSpan s | null wsstring -> (end, Nothing) + | otherwise -> (end, Just (Token TkSpace wsstring wsspan)) + where + start = realSrcSpanStart s + end = realSrcSpanEnd s + wsspan = mkRealSrcSpan prev start + nls = srcLocLine start - srcLocLine prev + spaces = if nls == 0 then srcLocCol start - srcLocCol prev + else srcLocCol start - 1 + wsstring = replicate nls '\n' ++ replicate spaces ' ' --- TODO: Add support for any Unicode symbol or punctuation. --- source: http://stackoverflow.com/questions/10548170/what-characters-are-permitted-for-haskell-operators -symbols :: [Char] -symbols = "!#$%&*+./<=>?@\\^|-~:" -isIdentifier :: String -> Bool -isIdentifier (s:str) - | (isLower' s || isUpper s) && all isAlphaNum' str = True - where - isLower' c = isLower c || c == '_' - isAlphaNum' c = isAlphaNum c || c == '_' || c == '\'' -isIdentifier _ = False +-- | Classify given tokens as appropriate Haskell token type. +classify :: L.Token -> TokenType +classify tok = + case tok of + ITas -> TkKeyword + ITcase -> TkKeyword + ITclass -> TkKeyword + ITdata -> TkKeyword + ITdefault -> TkKeyword + ITderiving -> TkKeyword + ITdo -> TkKeyword + ITelse -> TkKeyword + IThiding -> TkKeyword + ITforeign -> TkKeyword + ITif -> TkKeyword + ITimport -> TkKeyword + ITin -> TkKeyword + ITinfix -> TkKeyword + ITinfixl -> TkKeyword + ITinfixr -> TkKeyword + ITinstance -> TkKeyword + ITlet -> TkKeyword + ITmodule -> TkKeyword + ITnewtype -> TkKeyword + ITof -> TkKeyword + ITqualified -> TkKeyword + ITthen -> TkKeyword + ITtype -> TkKeyword + ITwhere -> TkKeyword + + ITforall {} -> TkKeyword + ITexport -> TkKeyword + ITlabel -> TkKeyword + ITdynamic -> TkKeyword + ITsafe -> TkKeyword + ITinterruptible -> TkKeyword + ITunsafe -> TkKeyword + ITstdcallconv -> TkKeyword + ITccallconv -> TkKeyword + ITcapiconv -> TkKeyword + ITprimcallconv -> TkKeyword + ITjavascriptcallconv -> TkKeyword + ITmdo -> TkKeyword + ITfamily -> TkKeyword + ITrole -> TkKeyword + ITgroup -> TkKeyword + ITby -> TkKeyword + ITusing -> TkKeyword + ITpattern -> TkKeyword + ITstatic -> TkKeyword + ITstock -> TkKeyword + ITanyclass -> TkKeyword + + ITunit -> TkKeyword + ITsignature -> TkKeyword + ITdependency -> TkKeyword + ITrequires -> TkKeyword + + ITinline_prag {} -> TkPragma + ITspec_prag {} -> TkPragma + ITspec_inline_prag {} -> TkPragma + ITsource_prag {} -> TkPragma + ITrules_prag {} -> TkPragma + ITwarning_prag {} -> TkPragma + ITdeprecated_prag {} -> TkPragma + ITline_prag {} -> TkPragma + ITcolumn_prag {} -> TkPragma + ITscc_prag {} -> TkPragma + ITgenerated_prag {} -> TkPragma + ITcore_prag {} -> TkPragma + ITunpack_prag {} -> TkPragma + ITnounpack_prag {} -> TkPragma + ITann_prag {} -> TkPragma + ITcomplete_prag {} -> TkPragma + ITclose_prag -> TkPragma + IToptions_prag {} -> TkPragma + ITinclude_prag {} -> TkPragma + ITlanguage_prag -> TkPragma + ITvect_prag {} -> TkPragma + ITvect_scalar_prag {} -> TkPragma + ITnovect_prag {} -> TkPragma + ITminimal_prag {} -> TkPragma + IToverlappable_prag {} -> TkPragma + IToverlapping_prag {} -> TkPragma + IToverlaps_prag {} -> TkPragma + ITincoherent_prag {} -> TkPragma + ITctype {} -> TkPragma + + ITdotdot -> TkGlyph + ITcolon -> TkGlyph + ITdcolon {} -> TkGlyph + ITequal -> TkGlyph + ITlam -> TkGlyph + ITlcase -> TkGlyph + ITvbar -> TkGlyph + ITlarrow {} -> TkGlyph + ITrarrow {} -> TkGlyph + ITat -> TkGlyph + ITtilde -> TkGlyph + ITtildehsh -> TkGlyph + ITdarrow {} -> TkGlyph + ITminus -> TkGlyph + ITbang -> TkGlyph + ITdot -> TkOperator + ITtypeApp -> TkGlyph + + ITbiglam -> TkGlyph + + ITocurly -> TkSpecial + ITccurly -> TkSpecial + ITvocurly -> TkSpecial + ITvccurly -> TkSpecial + ITobrack -> TkSpecial + ITopabrack -> TkSpecial + ITcpabrack -> TkSpecial + ITcbrack -> TkSpecial + IToparen -> TkSpecial + ITcparen -> TkSpecial + IToubxparen -> TkSpecial + ITcubxparen -> TkSpecial + ITsemi -> TkSpecial + ITcomma -> TkSpecial + ITunderscore -> TkIdentifier + ITbackquote -> TkSpecial + ITsimpleQuote -> TkSpecial + + ITvarid {} -> TkIdentifier + ITconid {} -> TkIdentifier + ITvarsym {} -> TkOperator + ITconsym {} -> TkOperator + ITqvarid {} -> TkIdentifier + ITqconid {} -> TkIdentifier + ITqvarsym {} -> TkOperator + ITqconsym {} -> TkOperator + + ITdupipvarid {} -> TkUnknown + ITlabelvarid {} -> TkUnknown + + ITchar {} -> TkChar + ITstring {} -> TkString + ITinteger {} -> TkNumber + ITrational {} -> TkNumber + + ITprimchar {} -> TkChar + ITprimstring {} -> TkString + ITprimint {} -> TkNumber + ITprimword {} -> TkNumber + ITprimfloat {} -> TkNumber + ITprimdouble {} -> TkNumber + + ITopenExpQuote {} -> TkSpecial + ITopenPatQuote -> TkSpecial + ITopenDecQuote -> TkSpecial + ITopenTypQuote -> TkSpecial + ITcloseQuote {} -> TkSpecial + ITopenTExpQuote {} -> TkSpecial + ITcloseTExpQuote -> TkSpecial + ITidEscape {} -> TkUnknown + ITparenEscape -> TkSpecial + ITidTyEscape {} -> TkUnknown + ITparenTyEscape -> TkSpecial + ITtyQuote -> TkSpecial + ITquasiQuote {} -> TkUnknown + ITqQuasiQuote {} -> TkUnknown + + ITproc -> TkKeyword + ITrec -> TkKeyword + IToparenbar {} -> TkGlyph + ITcparenbar {} -> TkGlyph + ITlarrowtail {} -> TkGlyph + ITrarrowtail {} -> TkGlyph + ITLarrowtail {} -> TkGlyph + ITRarrowtail {} -> TkGlyph + + ITunknown {} -> TkUnknown + ITeof -> TkUnknown + + -- Line comments are only supposed to start with '--'. Starting with '#' + -- means that this was probably a CPP. + ITlineComment s + | isCPPline s -> TkCpp + | otherwise -> TkComment + + ITdocCommentNext {} -> TkComment + ITdocCommentPrev {} -> TkComment + ITdocCommentNamed {} -> TkComment + ITdocSection {} -> TkComment + ITdocOptions {} -> TkComment + + -- The lexer considers top-level pragmas as comments (see `pragState` in + -- the GHC lexer for more), so we have to manually reverse this. The + -- following is a hammer: it smashes _all_ pragma-like block comments into + -- pragmas. + ITblockComment c + | isPrefixOf "{-#" c + , isSuffixOf "#-}" c -> TkPragma + | otherwise -> TkComment + +-- | Classify given tokens as beginning pragmas (or not). +inPragma :: Bool -- ^ currently in pragma + -> L.Token -- ^ current token + -> Bool -- ^ new information about whether we are in a pragma +inPragma _ ITclose_prag = False +inPragma True _ = True +inPragma False tok = + case tok of + ITinline_prag {} -> True + ITspec_prag {} -> True + ITspec_inline_prag {} -> True + ITsource_prag {} -> True + ITrules_prag {} -> True + ITwarning_prag {} -> True + ITdeprecated_prag {} -> True + ITline_prag {} -> True + ITcolumn_prag {} -> True + ITscc_prag {} -> True + ITgenerated_prag {} -> True + ITcore_prag {} -> True + ITunpack_prag {} -> True + ITnounpack_prag {} -> True + ITann_prag {} -> True + ITcomplete_prag {} -> True + IToptions_prag {} -> True + ITinclude_prag {} -> True + ITlanguage_prag -> True + ITvect_prag {} -> True + ITvect_scalar_prag {} -> True + ITnovect_prag {} -> True + ITminimal_prag {} -> True + IToverlappable_prag {} -> True + IToverlapping_prag {} -> True + IToverlaps_prag {} -> True + ITincoherent_prag {} -> True + ITctype {} -> True + + _ -> False + diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -15,7 +15,6 @@ import Data.List import Data.Maybe -import Data.Monoid import qualified Data.Map as Map import Text.XHtml (Html, HtmlAttr, (!)) @@ -82,7 +81,7 @@ tokenGroup :: SrcMap -> TokenGroup -> Html tokenGroup _ (GrpNormal tok@(Token { .. })) - | tkType == TkSpace = renderSpace (posRow . spStart $ tkSpan) tkValue + | tkType == TkSpace = renderSpace (GHC.srcSpanStartLine tkSpan) tkValue | otherwise = tokenSpan tok ! attrs where attrs = [ multiclass . tokenStyle $ tkType ] @@ -155,7 +154,7 @@ Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] externalNameHyperlink :: SrcMap -> GHC.Name -> Html -> Html -externalNameHyperlink (srcs, _) name content = case Map.lookup mdl srcs of +externalNameHyperlink srcs name content = case Map.lookup mdl srcs of Just SrcLocal -> Html.anchor content ! [ Html.href $ hypSrcModuleNameUrl mdl name ] Just (SrcExternal path) -> Html.anchor content ! @@ -165,12 +164,14 @@ mdl = GHC.nameModule name externalModHyperlink :: SrcMap -> GHC.ModuleName -> Html -> Html -externalModHyperlink (_, srcs) name content = case Map.lookup name srcs of - Just SrcLocal -> Html.anchor content ! +externalModHyperlink srcs name content = + let srcs' = Map.mapKeys GHC.moduleName srcs in + case Map.lookup name srcs' of + Just SrcLocal -> Html.anchor content ! [ Html.href $ hypSrcModuleUrl' name ] - Just (SrcExternal path) -> Html.anchor content ! + Just (SrcExternal path) -> Html.anchor content ! [ Html.href $ path hypSrcModuleUrl' name ] - Nothing -> content + Nothing -> content renderSpace :: Int -> String -> Html diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs @@ -4,27 +4,16 @@ import qualified GHC import Data.Map (Map) -import qualified Data.Map as Map - data Token = Token { tkType :: TokenType , tkValue :: String - , tkSpan :: Span - } - deriving (Show) - -data Position = Position - { posRow :: !Int - , posCol :: !Int + , tkSpan :: {-# UNPACK #-} !Span } deriving (Show) -data Span = Span - { spStart :: Position - , spEnd :: Position - } - deriving (Show) +type Position = GHC.RealSrcLoc +type Span = GHC.RealSrcSpan data TokenType = TkIdentifier @@ -74,15 +63,5 @@ | SrcLocal -- | Mapping from modules to cross-package source paths. --- --- This mapping is actually a pair of maps instead of just one map. The reason --- for this is because when hyperlinking modules in import lists we have no --- 'GHC.Module' available. On the other hand, we can't just use map with --- 'GHC.ModuleName' as indices because certain modules may have common name --- but originate in different packages. Hence, we use both /rich/ and /poor/ --- versions, where the /poor/ is just projection of /rich/ one cached in pair --- for better performance. -type SrcMap = (Map GHC.Module SrcPath, Map GHC.ModuleName SrcPath) +type SrcMap = Map GHC.Module SrcPath -mkSrcMap :: Map GHC.Module SrcPath -> SrcMap -mkSrcMap srcs = (srcs, Map.mapKeys GHC.moduleName srcs) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -16,6 +16,7 @@ ) where +import Documentation.Haddock.Markup import Haddock.Types import Haddock.Utils import Haddock.GhcUtils @@ -36,6 +37,7 @@ import Control.Monad import Data.Maybe import Data.List +import Prelude hiding ((<>)) import Haddock.Doc (combineDocumentation) @@ -178,7 +180,7 @@ string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2 -exportListItem :: ExportItem DocName -> LaTeX +exportListItem :: ExportItem DocNameI -> LaTeX exportListItem ExportDecl { expItemDecl = decl, expItemSubDocs = subdocs } = sep (punctuate comma . map ppDocBinder $ declNames decl) <> case subdocs of @@ -196,7 +198,7 @@ -- Deal with a group of undocumented exports together, to avoid lots -- of blank vertical space between them. -processExports :: [ExportItem DocName] -> LaTeX +processExports :: [ExportItem DocNameI] -> LaTeX processExports [] = empty processExports (decl : es) | Just sig <- isSimpleSig decl @@ -212,19 +214,19 @@ processExport e $$ processExports es -isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName) +isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsType DocNameI) isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames t)) , expItemMbDoc = (Documentation Nothing Nothing, argDocs) } | Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t)) isSimpleSig _ = Nothing -isExportModule :: ExportItem DocName -> Maybe Module +isExportModule :: ExportItem DocNameI -> Maybe Module isExportModule (ExportModule m) = Just m isExportModule _ = Nothing -processExport :: ExportItem DocName -> LaTeX +processExport :: ExportItem DocNameI -> LaTeX processExport (ExportGroup lev _id0 doc) = ppDocGroup lev (docToLaTeX doc) processExport (ExportDecl decl pats doc subdocs insts fixities _splice) @@ -247,7 +249,7 @@ sec _ = text "\\paragraph" -declNames :: LHsDecl DocName -> [DocName] +declNames :: LHsDecl DocNameI -> [DocName] declNames (L _ decl) = case decl of TyClD d -> [tcdName d] SigD (TypeSig lnames _ ) -> map unLoc lnames @@ -257,7 +259,7 @@ _ -> error "declaration not supported by declNames" -forSummary :: (ExportItem DocName) -> Bool +forSummary :: (ExportItem DocNameI) -> Bool forSummary (ExportGroup _ _ _) = False forSummary (ExportDoc _) = False forSummary _ = True @@ -277,10 +279,10 @@ ------------------------------------------------------------------------------- -ppDecl :: LHsDecl DocName - -> [(HsDecl DocName,DocForDecl DocName)] +ppDecl :: LHsDecl DocNameI + -> [(HsDecl DocNameI, DocForDecl DocName)] -> DocForDecl DocName - -> [DocInstance DocName] + -> [DocInstance DocNameI] -> [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)] -> LaTeX @@ -308,12 +310,12 @@ ppTyFam :: Bool -> SrcSpan -> Documentation DocName -> - TyClDecl DocName -> Bool -> LaTeX + TyClDecl DocNameI -> Bool -> LaTeX ppTyFam _ _ _ _ _ = error "type family declarations are currently not supported by --latex" -ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> LaTeX +ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX ppFor loc doc (ForeignImport (L _ name) typ _ _) unicode = ppFunSig loc doc [name] (hsSigType typ) unicode ppFor _ _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" @@ -326,7 +328,7 @@ -- we skip type patterns for now -ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> LaTeX +ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocNameI -> Bool -> LaTeX ppTySyn loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars , tcdRhs = ltype }) unicode @@ -345,7 +347,7 @@ ------------------------------------------------------------------------------- -ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> LHsType DocName +ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> LHsType DocNameI -> Bool -> LaTeX ppFunSig loc doc docnames (L _ typ) unicode = ppTypeOrFunSig loc docnames typ doc @@ -357,7 +359,7 @@ names = map getName docnames ppLPatSig :: SrcSpan -> DocForDecl DocName -> [DocName] - -> LHsSigType DocName + -> LHsSigType DocNameI -> Bool -> LaTeX ppLPatSig _loc (doc, _argDocs) docnames ty unicode = declWithDoc pref1 (documentationToLaTeX doc) @@ -368,7 +370,7 @@ , ppLType unicode (hsSigType ty) ] -ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName +ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocNameI -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX) -> Bool -> LaTeX ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0) @@ -386,7 +388,7 @@ arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs - do_args :: Int -> LaTeX -> HsType DocName -> LaTeX + do_args :: Int -> LaTeX -> HsType DocNameI -> LaTeX do_args _n leader (HsForAllTy tvs ltype) = decltt leader <-> decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot])) @@ -402,18 +404,18 @@ = decltt leader <-> decltt (ppType unicode t) <-> arg_doc n <+> nl -ppTypeSig :: [Name] -> HsType DocName -> Bool -> LaTeX +ppTypeSig :: [Name] -> HsType DocNameI -> Bool -> LaTeX ppTypeSig nms ty unicode = hsep (punctuate comma $ map ppSymName nms) <+> dcolon unicode <+> ppType unicode ty -ppTyVars :: [LHsTyVarBndr DocName] -> [LaTeX] +ppTyVars :: [LHsTyVarBndr DocNameI] -> [LaTeX] ppTyVars = map (ppSymName . getName . hsLTyVarName) -tyvarNames :: LHsQTyVars DocName -> [Name] +tyvarNames :: LHsQTyVars DocNameI -> [Name] tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit @@ -462,8 +464,8 @@ ------------------------------------------------------------------------------- -ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName - -> LHsQTyVars DocName -> [Located ([Located DocName], [Located DocName])] +ppClassHdr :: Bool -> Located [LHsType DocNameI] -> DocName + -> LHsQTyVars DocNameI -> [Located ([Located DocName], [Located DocName])] -> Bool -> LaTeX ppClassHdr summ lctxt n tvs fds unicode = keyword "class" @@ -481,9 +483,9 @@ hsep (map (ppDocName . unLoc) vars2) -ppClassDecl :: [DocInstance DocName] -> SrcSpan +ppClassDecl :: [DocInstance DocNameI] -> SrcSpan -> Documentation DocName -> [(DocName, DocForDecl DocName)] - -> TyClDecl DocName -> Bool -> LaTeX + -> TyClDecl DocNameI -> Bool -> LaTeX ppClassDecl instances loc doc subdocs (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars, tcdFDs = lfds , tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs }) unicode @@ -506,19 +508,17 @@ methodTable = text "\\haddockpremethods{}\\textbf{Methods}" $$ - vcat [ ppFunSig loc doc names (hsSigWcType typ) unicode + vcat [ ppFunSig loc doc [name] (hsSigWcType typ) unicode | L _ (TypeSig lnames typ) <- lsigs - , let doc = lookupAnySubdoc (head names) subdocs - 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? + , name <- map unLoc lnames + , let doc = lookupAnySubdoc name subdocs + ] instancesBit = ppDocInstances unicode instances ppClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" -ppDocInstances :: Bool -> [DocInstance DocName] -> LaTeX +ppDocInstances :: Bool -> [DocInstance DocNameI] -> LaTeX ppDocInstances _unicode [] = empty ppDocInstances unicode (i : rest) | Just ihead <- isUndocdInstance i @@ -536,22 +536,22 @@ -- | Print a possibly commented instance. The instance header is printed inside -- an 'argBox'. The comment is printed to the right of the box in normal comment -- style. -ppDocInstance :: Bool -> DocInstance DocName -> LaTeX +ppDocInstance :: Bool -> DocInstance DocNameI -> LaTeX ppDocInstance unicode (instHead, doc, _) = declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX $ fmap _doc doc) -ppInstDecl :: Bool -> InstHead DocName -> LaTeX +ppInstDecl :: Bool -> InstHead DocNameI -> LaTeX ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead -ppInstHead :: Bool -> InstHead DocName -> LaTeX +ppInstHead :: Bool -> InstHead DocNameI -> LaTeX ppInstHead unicode (InstHead {..}) = case ihdInstType of ClassInst ctx _ _ _ -> ppContextNoLocs ctx unicode <+> typ TypeInst rhs -> keyword "type" <+> typ <+> tibody rhs DataInst _ -> error "data instances not supported by --latex yet" where - typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode + typ = ppAppNameTypes ihdClsName ihdTypes unicode tibody = maybe empty (\t -> equals <+> ppType unicode t) lookupAnySubdoc :: (Eq name1) => @@ -566,9 +566,9 @@ ------------------------------------------------------------------------------- -ppDataDecl :: [(HsDecl DocName,DocForDecl DocName)] -> [DocInstance DocName] -> +ppDataDecl :: [(HsDecl DocNameI, DocForDecl DocName)] -> [DocInstance DocNameI] -> [(DocName, DocForDecl DocName)] -> SrcSpan -> - Maybe (Documentation DocName) -> TyClDecl DocName -> Bool -> + Maybe (Documentation DocName) -> TyClDecl DocNameI -> Bool -> LaTeX ppDataDecl pats instances subdocs _loc doc dataDecl unicode @@ -614,7 +614,7 @@ -- ppConstrHdr is for (non-GADT) existentials constructors' syntax -ppConstrHdr :: Bool -> [Name] -> HsContext DocName -> Bool -> LaTeX +ppConstrHdr :: Bool -> [Name] -> HsContext DocNameI -> Bool -> LaTeX ppConstrHdr forall tvs ctxt unicode = (if null tvs then empty else ppForall) <+> @@ -626,7 +626,7 @@ ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX - -> LConDecl DocName -> LaTeX + -> LConDecl DocNameI -> LaTeX ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclH98 {})) = leader <-> case con_details con of @@ -755,7 +755,7 @@ mkFunTy a b = noLoc (HsFunTy a b) -} -ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> LaTeX +ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocNameI -> LaTeX ppSideBySideField subdocs unicode (ConDeclField names ltype _) = decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc @@ -813,7 +813,7 @@ -- | Print the LHS of a data\/newtype declaration. -- Currently doesn't handle 'data instance' decls or kind signatures -ppDataHeader :: TyClDecl DocName -> Bool -> LaTeX +ppDataHeader :: TyClDecl DocNameI -> Bool -> LaTeX ppDataHeader (DataDecl { tcdLName = L _ name, tcdTyVars = tyvars , tcdDataDefn = HsDataDefn { dd_ND = nd, dd_ctxt = ctxt } }) unicode = -- newtype or data @@ -829,27 +829,27 @@ -------------------------------------------------------------------------------- --- | Print an application of a DocName and two lists of HsTypes (kinds, types) -ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName] -> Bool -> LaTeX -ppAppNameTypes n ks ts unicode = ppTypeApp n ks ts ppDocName (ppParendType unicode) +-- | Print an application of a DocName to its list of HsTypes +ppAppNameTypes :: DocName -> [HsType DocNameI] -> Bool -> LaTeX +ppAppNameTypes n ts unicode = ppTypeApp n ts ppDocName (ppParendType unicode) -- | Print an application of a DocName and a list of Names ppAppDocNameNames :: Bool -> DocName -> [Name] -> LaTeX ppAppDocNameNames _summ n ns = - ppTypeApp n [] ns (ppBinder . nameOccName . getName) ppSymName + ppTypeApp n ns (ppBinder . nameOccName . getName) ppSymName -- | General printing of type applications -ppTypeApp :: DocName -> [a] -> [a] -> (DocName -> LaTeX) -> (a -> LaTeX) -> LaTeX -ppTypeApp n [] (t1:t2:rest) ppDN ppT +ppTypeApp :: DocName -> [a] -> (DocName -> LaTeX) -> (a -> LaTeX) -> LaTeX +ppTypeApp n (t1:t2:rest) ppDN ppT | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest) | operator = opApp where operator = isNameSym . getName $ n opApp = ppT t1 <+> ppDN n <+> ppT t2 -ppTypeApp n ks ts ppDN ppT = ppDN n <+> hsep (map ppT $ ks ++ ts) +ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts) ------------------------------------------------------------------------------- @@ -857,29 +857,29 @@ ------------------------------------------------------------------------------- -ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> LaTeX +ppLContext, ppLContextNoArrow :: Located (HsContext DocNameI) -> Bool -> LaTeX ppLContext = ppContext . unLoc ppLContextNoArrow = ppContextNoArrow . unLoc -ppContextNoLocsMaybe :: [HsType DocName] -> Bool -> Maybe LaTeX +ppContextNoLocsMaybe :: [HsType DocNameI] -> Bool -> Maybe LaTeX ppContextNoLocsMaybe [] _ = Nothing ppContextNoLocsMaybe cxt unicode = Just $ pp_hs_context cxt unicode -ppContextNoArrow :: HsContext DocName -> Bool -> LaTeX +ppContextNoArrow :: HsContext DocNameI -> Bool -> LaTeX ppContextNoArrow cxt unicode = fromMaybe empty $ ppContextNoLocsMaybe (map unLoc cxt) unicode -ppContextNoLocs :: [HsType DocName] -> Bool -> LaTeX +ppContextNoLocs :: [HsType DocNameI] -> Bool -> LaTeX ppContextNoLocs cxt unicode = maybe empty (<+> darrow unicode) $ ppContextNoLocsMaybe cxt unicode -ppContext :: HsContext DocName -> Bool -> LaTeX +ppContext :: HsContext DocNameI -> Bool -> LaTeX ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode -pp_hs_context :: [HsType DocName] -> Bool -> LaTeX +pp_hs_context :: [HsType DocNameI] -> Bool -> LaTeX pp_hs_context [] _ = empty pp_hs_context [p] unicode = ppType unicode p pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt) @@ -929,32 +929,32 @@ | otherwise = p -ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocName) -> LaTeX +ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocNameI) -> LaTeX ppLType unicode y = ppType unicode (unLoc y) ppLParendType unicode y = ppParendType unicode (unLoc y) ppLFunLhType unicode y = ppFunLhType unicode (unLoc y) -ppType, ppParendType, ppFunLhType :: Bool -> HsType DocName -> LaTeX +ppType, ppParendType, ppFunLhType :: Bool -> HsType DocNameI -> LaTeX ppType unicode ty = ppr_mono_ty pREC_TOP ty unicode ppParendType unicode ty = ppr_mono_ty pREC_CON ty unicode ppFunLhType unicode ty = ppr_mono_ty pREC_FUN ty unicode -ppLKind :: Bool -> LHsKind DocName -> LaTeX +ppLKind :: Bool -> LHsKind DocNameI -> LaTeX ppLKind unicode y = ppKind unicode (unLoc y) -ppKind :: Bool -> HsKind DocName -> LaTeX +ppKind :: Bool -> HsKind DocNameI -> LaTeX ppKind unicode ki = ppr_mono_ty pREC_TOP ki unicode -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell -ppr_mono_lty :: Int -> LHsType DocName -> Bool -> LaTeX +ppr_mono_lty :: Int -> LHsType DocNameI -> Bool -> LaTeX ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode -ppr_mono_ty :: Int -> HsType DocName -> Bool -> LaTeX +ppr_mono_ty :: Int -> HsType DocNameI -> Bool -> LaTeX ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode = maybeParen ctxt_prec pREC_FUN $ sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> dot @@ -1017,7 +1017,7 @@ -- XXX: Do something with Unicode parameter? -ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> LaTeX +ppr_fun_ty :: Int -> LHsType DocNameI -> LHsType DocNameI -> Bool -> LaTeX ppr_fun_ty ctxt_prec ty1 ty2 unicode = let p1 = ppr_mono_lty pREC_FUN ty1 unicode p2 = ppr_mono_lty pREC_TOP ty2 unicode @@ -1138,7 +1138,8 @@ markupAName = \_ _ -> empty, markupProperty = \p _ -> quote $ verb $ text p, markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e, - markupHeader = \(Header l h) p -> header l (h p) + markupHeader = \(Header l h) p -> header l (h p), + markupTable = \(Table h b) p -> table h b p } where header 1 d = text "\\section*" <> braces d @@ -1146,6 +1147,8 @@ header l d | l > 0 && l <= 6 = text "\\subsubsection*" <> braces d header l _ = error $ "impossible header level in LaTeX generation: " ++ show l + + table _ _ _ = text "{TODO: Table}" fixString Plain s = latexFilter s fixString Verb s = s diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -11,7 +11,7 @@ -- Stability : experimental -- Portability : portable ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, NamedFieldPuns #-} module Haddock.Backends.Xhtml ( ppHtml, copyHtmlBits, ppHtmlIndex, ppHtmlContents, @@ -31,15 +31,18 @@ import Haddock.Types import Haddock.Version import Haddock.Utils +import Haddock.Utils.Json import Text.XHtml hiding ( name, title, p, quote ) import Haddock.GhcUtils import Control.Monad ( when, unless ) +import qualified Data.ByteString.Builder as Builder import Data.Char ( toUpper, isSpace ) -import Data.List ( sortBy, intercalate, isPrefixOf, intersperse ) +import Data.List ( sortBy, isPrefixOf, intercalate, intersperse ) import Data.Maybe -import System.FilePath hiding ( () ) import System.Directory +import System.FilePath hiding ( () ) +import qualified System.IO as IO import Data.Map ( Map ) import qualified Data.Map as Map hiding ( Map ) import qualified Data.Set as Set hiding ( Set ) @@ -48,17 +51,16 @@ import DynFlags (Language(..)) import GHC hiding ( NoLink, moduleInfo,LexicalFixity(..) ) import Name -import Module -------------------------------------------------------------------------------- -- * Generating HTML documentation -------------------------------------------------------------------------------- - ppHtml :: DynFlags -> String -- ^ Title -> Maybe String -- ^ Package -> [Interface] + -> [InstalledInterface] -- ^ Reexported interfaces -> FilePath -- ^ Destination directory -> Maybe (MDoc GHC.RdrName) -- ^ Prologue text, maybe -> Themes -- ^ Themes @@ -70,12 +72,13 @@ -> Bool -- ^ Whether to use unicode in output (--use-unicode) -> QualOption -- ^ How to qualify names -> Bool -- ^ Output pretty html (newlines and indenting) + -> Bool -- ^ Also write Quickjump index -> IO () -ppHtml dflags doctitle maybe_package ifaces odir prologue +ppHtml dflags doctitle maybe_package ifaces reexported_ifaces odir prologue themes maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url unicode - qual debug = do + qual debug withQuickjump = do let visible_ifaces = filter visible ifaces visible i = OptHide `notElem` ifaceOptions i @@ -83,28 +86,34 @@ when (isNothing maybe_contents_url) $ ppHtmlContents dflags odir doctitle maybe_package themes maybe_mathjax_url maybe_index_url maybe_source_url maybe_wiki_url - (map toInstalledIface visible_ifaces) + (map toInstalledIface visible_ifaces ++ reexported_ifaces) False -- we don't want to display the packages in a single-package contents prologue debug (makeContentsQual qual) - when (isNothing maybe_index_url) $ + when (isNothing maybe_index_url) $ do ppHtmlIndex odir doctitle maybe_package themes maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url - (map toInstalledIface visible_ifaces) debug + (map toInstalledIface visible_ifaces ++ reexported_ifaces) debug + when withQuickjump $ + ppJsonIndex odir maybe_source_url maybe_wiki_url unicode qual + visible_ifaces + mapM_ (ppHtmlModule odir doctitle themes maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url unicode qual debug) visible_ifaces -copyHtmlBits :: FilePath -> FilePath -> Themes -> IO () -copyHtmlBits odir libdir themes = do +copyHtmlBits :: FilePath -> FilePath -> Themes -> Bool -> IO () +copyHtmlBits odir libdir themes withQuickjump = do let libhtmldir = joinPath [libdir, "html"] copyCssFile f = copyFile f (combine odir (takeFileName f)) copyLibFile f = copyFile (joinPath [libhtmldir, f]) (joinPath [odir, f]) mapM_ copyCssFile (cssFiles themes) - copyLibFile jsFile + copyLibFile haddockJsFile + copyCssFile (joinPath [libhtmldir, quickJumpCssFile]) + when withQuickjump (copyLibFile jsQuickJumpFile) return () @@ -114,13 +123,9 @@ meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"], thetitle << docTitle, styleSheet themes, - script ! [src jsFile, thetype "text/javascript"] << noHtml, - script ! [src mjUrl, thetype "text/javascript"] << noHtml, - script ! [thetype "text/javascript"] - -- NB: Within XHTML, the content of script tags needs to be - -- a \n" + thelink ! [ rel "stylesheet", thetype "text/css", href quickJumpCssFile] << noHtml, + script ! [src haddockJsFile, emptyAttr "async", thetype "text/javascript"] << noHtml, + script ! [src mjUrl, thetype "text/javascript"] << noHtml ] where mjUrl = maybe "https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" id mathjax_url @@ -187,7 +192,6 @@ ) ] - moduleInfo :: Interface -> Html moduleInfo iface = let @@ -306,33 +310,35 @@ mkNode :: Qualification -> [String] -> String -> ModuleTree -> Html -mkNode qual ss p (Node s leaf pkg srcPkg short ts) = +mkNode qual ss p (Node s leaf _pkg srcPkg short ts) = htmlModule <+> shortDescr +++ htmlPkg +++ subtree where modAttrs = case (ts, leaf) of - (_:_, False) -> collapseControl p True "module" + (_:_, Nothing) -> collapseControl p "module" (_, _ ) -> [theclass "module"] cBtn = case (ts, leaf) of - (_:_, True) -> thespan ! collapseControl p True "" << spaceHtml + (_:_, Just _) -> thespan ! collapseControl p "" << spaceHtml (_, _ ) -> noHtml -- We only need an explicit collapser button when the module name -- is also a leaf, and so is a link to a module page. Indeed, the -- spaceHtml is a minor hack and does upset the layout a fraction. htmlModule = thespan ! modAttrs << (cBtn +++ - if leaf - then ppModule (mkModule (stringToUnitId (fromMaybe "" pkg)) - (mkModuleName mdl)) - else toHtml s + case leaf of + Just m -> ppModule m + Nothing -> toHtml s ) - mdl = intercalate "." (reverse (s:ss)) - shortDescr = maybe noHtml (origDocToHtml qual) short htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) srcPkg - subtree = mkNodeList qual (s:ss) p ts ! collapseSection p True "" + subtree = + if null ts then noHtml else + collapseDetails p DetailsOpen ( + thesummary ! [ theclass "hide-when-js-enabled" ] << "Submodules" +++ + mkNodeList qual (s:ss) p ts + ) @@ -340,7 +346,60 @@ -- * Generate the index -------------------------------------------------------------------------------- +ppJsonIndex :: FilePath + -> SourceURLs -- ^ The source URL (--source) + -> WikiURLs -- ^ The wiki URL (--wiki) + -> Bool + -> QualOption + -> [Interface] + -> IO () +ppJsonIndex odir maybe_source_url maybe_wiki_url unicode qual_opt ifaces = do + createDirectoryIfMissing True odir + IO.withBinaryFile (joinPath [odir, indexJsonFile]) IO.WriteMode $ \h -> do + Builder.hPutBuilder h (encodeToBuilder modules) + where + modules :: Value + modules = Array (concatMap goInterface ifaces) + goInterface :: Interface -> [Value] + goInterface iface = + concatMap (goExport mdl qual) (ifaceRnExportItems iface) + where + aliases = ifaceModuleAliases iface + qual = makeModuleQual qual_opt aliases mdl + mdl = ifaceMod iface + + goExport :: Module -> Qualification -> ExportItem DocNameI -> [Value] + goExport mdl qual item + | Just item_html <- processExport True links_info unicode qual item + = [ Object + [ "display_html" .= String (showHtmlFragment item_html) + , "name" .= String (intercalate " " (map nameString names)) + , "module" .= String (moduleString mdl) + , "link" .= String (fromMaybe "" (listToMaybe (map (nameLink mdl) names))) + ] + ] + | otherwise = [] + where + names = exportName item ++ exportSubs item + + exportSubs :: ExportItem name -> [IdP name] + exportSubs ExportDecl { expItemSubDocs } = map fst expItemSubDocs + exportSubs _ = [] + + exportName :: ExportItem name -> [IdP name] + exportName ExportDecl { expItemDecl } = getMainDeclBinder (unLoc expItemDecl) + exportName ExportNoDecl { expItemName } = [expItemName] + exportName _ = [] + + nameString :: NamedThing name => name -> String + nameString = occNameString . nameOccName . getName + + nameLink :: NamedThing name => Module -> name -> String + nameLink mdl = moduleNameUrl' (moduleName mdl) . nameOccName . getName + + links_info = (maybe_source_url, maybe_wiki_url) + ppHtmlIndex :: FilePath -> String -> Maybe String @@ -505,6 +564,7 @@ signatureDocURL :: String signatureDocURL = "https://wiki.haskell.org/Module_signature" + ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Qualification -> Html ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual = ppModuleContents qual exports (not . null $ ifaceRnOrphanInstances iface) +++ @@ -532,10 +592,12 @@ | no_doc_at_all = noHtml | otherwise = divSynopsis $ - paragraph ! collapseControl "syn" False "caption" << "Synopsis" +++ - shortDeclList ( - mapMaybe (processExport True linksInfo unicode qual) exports - ) ! (collapseSection "syn" False "" ++ collapseToggle "syn") + collapseDetails "syn" DetailsClosed ( + thesummary << "Synopsis" +++ + shortDeclList ( + mapMaybe (processExport True linksInfo unicode qual) exports + ) ! collapseToggle "syn" "" + ) -- if the documentation doesn't begin with a section header, then -- add one ("Documentation"). @@ -556,7 +618,7 @@ ppModuleContents :: Qualification - -> [ExportItem DocName] + -> [ExportItem DocNameI] -> Bool -- ^ Orphans sections -> Html ppModuleContents qual exports orphan @@ -572,7 +634,7 @@ | orphan = [ linkedAnchor "section.orphans" << "Orphan instances" ] | otherwise = [] - process :: Int -> [ExportItem DocName] -> ([Html],[ExportItem DocName]) + process :: Int -> [ExportItem DocNameI] -> ([Html],[ExportItem DocNameI]) process _ [] = ([], []) process n items@(ExportGroup lev id0 doc : rest) | lev <= n = ( [], items ) @@ -589,9 +651,9 @@ -- we need to assign a unique id to each section heading so we can hyperlink -- them from the contents: -numberSectionHeadings :: [ExportItem DocName] -> [ExportItem DocName] +numberSectionHeadings :: [ExportItem DocNameI] -> [ExportItem DocNameI] numberSectionHeadings = go 1 - where go :: Int -> [ExportItem DocName] -> [ExportItem DocName] + where go :: Int -> [ExportItem DocNameI] -> [ExportItem DocNameI] go _ [] = [] go n (ExportGroup lev _ doc : es) = ExportGroup lev (show n) doc : go (n+1) es @@ -600,7 +662,7 @@ processExport :: Bool -> LinksInfo -> Bool -> Qualification - -> ExportItem DocName -> Maybe Html + -> ExportItem DocNameI -> Maybe Html processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances processExport summary _ _ qual (ExportGroup lev id0 doc) = nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) qual (mkMeta doc) @@ -636,7 +698,8 @@ processDeclOneLiner False = Just . divTopDecl . declElem groupHeading :: Int -> String -> Html -> Html -groupHeading lev id0 = groupTag lev ! [identifier (groupId id0)] +groupHeading lev id0 = linkedAnchor grpId . groupTag lev ! [identifier grpId] + where grpId = groupId id0 groupTag :: Int -> Html -> Html groupTag lev diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -40,9 +40,9 @@ import BooleanFormula import RdrName ( rdrNameOcc ) -ppDecl :: Bool -> LinksInfo -> LHsDecl DocName - -> [(HsDecl DocName, DocForDecl DocName)] - -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)] +ppDecl :: Bool -> LinksInfo -> LHsDecl DocNameI + -> [(HsDecl DocNameI, DocForDecl DocName)] + -> DocForDecl DocName -> [DocInstance DocNameI] -> [(DocName, Fixity)] -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual @@ -60,23 +60,23 @@ ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - [Located DocName] -> LHsType DocName -> [(DocName, Fixity)] -> + [Located DocName] -> LHsType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html ppLFunSig summary links loc doc lnames lty fixities splice unicode qual = ppFunSig summary links loc doc (map unLoc lnames) lty fixities splice unicode qual ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - [DocName] -> LHsType DocName -> [(DocName, Fixity)] -> + [DocName] -> LHsType DocNameI -> [(DocName, Fixity)] -> 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 -> + [Located DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html ppLPatSig summary links loc (doc, _argDocs) docnames typ fixities splice unicode qual @@ -87,20 +87,20 @@ 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 + [DocName] -> [(DocName, Fixity)] -> (HsType DocNameI, 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 @@ -108,10 +108,10 @@ | otherwise = html <+> ppFixities fixities qual -ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocName +ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocNameI -> 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 +++ @@ -122,7 +122,7 @@ do_largs n leader (L _ t) = do_args n leader t - do_args :: Int -> Html -> HsType DocName -> [SubDecl] + do_args :: Int -> Html -> HsType DocNameI -> [SubDecl] do_args n leader (HsForAllTy tvs ltype) = do_largs n leader' ltype where @@ -132,16 +132,16 @@ | 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 :: [LHsTyVarBndr DocNameI] -> Unicode -> Qualification -> Html ppForAll tvs unicode qual = case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- tvs] of [] -> noHtml @@ -172,15 +172,15 @@ -- | Pretty-print type variables. -ppTyVars :: Unicode -> Qualification -> [LHsTyVarBndr DocName] -> [Html] +ppTyVars :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> [Html] ppTyVars unicode qual tvs = map (ppHsTyVarBndr unicode qual . unLoc) tvs -tyvarNames :: LHsQTyVars DocName -> [Name] +tyvarNames :: LHsQTyVars DocNameI -> [Name] tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName - -> ForeignDecl DocName -> [(DocName, Fixity)] + -> ForeignDecl DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html ppFor summary links loc doc (ForeignImport (L _ name) typ _ _) fixities splice unicode qual @@ -190,18 +190,18 @@ -- we skip type patterns for now ppTySyn :: Bool -> LinksInfo -> [(DocName, Fixity)] -> SrcSpan - -> DocForDecl DocName -> TyClDecl DocName + -> DocForDecl DocName -> TyClDecl DocNameI -> Splice -> Unicode -> Qualification -> Html ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars , tcdRhs = ltype }) 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 = ppName Prefix -ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> SrcSpan - -> [DocName] -> HsType DocName +ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> SrcSpan + -> [DocName] -> HsType DocNameI -> 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 @@ -236,7 +236,7 @@ -------------------------------------------------------------------------------- -ppFamilyInfo :: Bool -> FamilyInfo DocName -> Html +ppFamilyInfo :: Bool -> FamilyInfo DocNameI -> Html ppFamilyInfo assoc OpenTypeFamily | assoc = keyword "type" | otherwise = keyword "type family" @@ -246,7 +246,7 @@ ppFamilyInfo _ (ClosedTypeFamily _) = keyword "type family" -ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName +ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocNameI -> Unicode -> Qualification -> Html ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info , fdResultSig = L _ result @@ -276,28 +276,28 @@ _ -> mempty ) -ppResultSig :: FamilyResultSig DocName -> Unicode -> Qualification -> Html +ppResultSig :: FamilyResultSig DocNameI -> Unicode -> Qualification -> Html ppResultSig result unicode qual = case result of NoSig -> noHtml KindSig kind -> dcolon unicode <+> ppLKind unicode qual kind TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr -ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocName +ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocNameI -> Html ppPseudoFamilyHeader unicode qual (PseudoFamilyDecl { .. }) = ppFamilyInfo True pfdInfo <+> - ppAppNameTypes (unLoc pfdLName) [] (map unLoc pfdTyVars) unicode qual <+> + ppAppNameTypes (unLoc pfdLName) (map unLoc pfdTyVars) unicode qual <+> ppResultSig (unLoc pfdKindSig) unicode qual -ppInjectivityAnn :: Bool -> Qualification -> InjectivityAnn DocName -> Html +ppInjectivityAnn :: Bool -> Qualification -> InjectivityAnn DocNameI -> Html ppInjectivityAnn unicode qual (InjectivityAnn lhs rhs) = char '|' <+> ppLDocName qual Raw lhs <+> arrow unicode <+> hsep (map (ppLDocName qual Raw) rhs) -ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] -> +ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)] -> SrcSpan -> Documentation DocName -> - FamilyDecl DocName -> Splice -> Unicode -> Qualification -> Html + FamilyDecl DocNameI -> Splice -> Unicode -> Qualification -> Html ppTyFam summary associated links instances fixities loc doc decl splice unicode qual | summary = ppTyFamHeader True associated decl unicode qual @@ -318,16 +318,17 @@ = ppInstances links (OriginFamily docname) instances splice unicode qual -- Individual equation of a closed type family - 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) + ppTyFamEqn :: TyFamInstEqn DocNameI -> SubDecl + ppTyFamEqn (HsIB { hsib_body = FamEqn { feqn_tycon = n, feqn_rhs = rhs + , feqn_pats = ts } }) + = ( ppAppNameTypes (unLoc n) (map unLoc ts) unicode qual + <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs) , Nothing, [] ) ppPseudoFamilyDecl :: LinksInfo -> Splice -> Unicode -> Qualification - -> PseudoFamilyDecl DocName + -> PseudoFamilyDecl DocNameI -> Html ppPseudoFamilyDecl links splice unicode qual decl@(PseudoFamilyDecl { pfdLName = L loc name, .. }) = @@ -341,7 +342,7 @@ -------------------------------------------------------------------------------- -ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocName +ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html ppAssocType summ links doc (L loc decl) fixities splice unicode qual = ppTyFam summ True links [] fixities loc (fst doc) decl splice unicode qual @@ -352,12 +353,12 @@ -------------------------------------------------------------------------------- -- | Print a type family and its variables -ppFamDeclBinderWithVars :: Bool -> Unicode -> Qualification -> FamilyDecl DocName -> Html +ppFamDeclBinderWithVars :: Bool -> Unicode -> Qualification -> FamilyDecl DocNameI -> Html ppFamDeclBinderWithVars summ unicode qual (FamilyDecl { fdLName = lname, fdTyVars = tvs }) = ppAppDocNameTyVarBndrs summ unicode qual (unLoc lname) (hsq_explicit tvs) -- | Print a newtype / data binder and its variables -ppDataBinderWithVars :: Bool -> Unicode -> Qualification -> TyClDecl DocName -> Html +ppDataBinderWithVars :: Bool -> Unicode -> Qualification -> TyClDecl DocNameI -> Html ppDataBinderWithVars summ unicode qual decl = ppAppDocNameTyVarBndrs summ unicode qual (tcdName decl) (hsQTvExplicit $ tcdTyVars decl) @@ -365,31 +366,30 @@ -- * Type applications -------------------------------------------------------------------------------- -ppAppDocNameTyVarBndrs :: Bool -> Unicode -> Qualification -> DocName -> [LHsTyVarBndr DocName] -> Html +ppAppDocNameTyVarBndrs :: Bool -> Unicode -> Qualification -> DocName -> [LHsTyVarBndr DocNameI] -> Html ppAppDocNameTyVarBndrs summ unicode qual n vs = - ppTypeApp n [] vs ppDN (ppHsTyVarBndr unicode qual . unLoc) + ppTypeApp n vs ppDN (ppHsTyVarBndr unicode qual . unLoc) where ppDN notation = ppBinderFixity notation summ . nameOccName . getName ppBinderFixity Infix = ppBinderInfix ppBinderFixity _ = ppBinder --- | Print an application of a 'DocName' and two lists of 'HsTypes' (kinds, types) -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) +-- | Print an application of a 'DocName' to its list of 'HsType's +ppAppNameTypes :: DocName -> [HsType DocNameI] -> Unicode -> Qualification -> Html +ppAppNameTypes n ts unicode qual = + ppTypeApp n ts (\p -> ppDocName qual p True) (ppParendType unicode qual HideEmptyContexts) -- | General printing of type applications -ppTypeApp :: DocName -> [a] -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html -ppTypeApp n [] (t1:t2:rest) ppDN ppT +ppTypeApp :: DocName -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html +ppTypeApp n (t1:t2:rest) ppDN ppT | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest) | operator = opApp where operator = isNameSym . getName $ n opApp = ppT t1 <+> ppDN Infix n <+> ppT t2 -ppTypeApp n ks ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT $ ks ++ ts) +ppTypeApp n ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT ts) ------------------------------------------------------------------------------- @@ -397,33 +397,36 @@ ------------------------------------------------------------------------------- -ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Unicode - -> Qualification -> Html +ppLContext, ppLContextNoArrow :: Located (HsContext DocNameI) -> Unicode + -> 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 DocNameI -> 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 DocNameI] -> 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 DocNameI] -> 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 DocNameI -> 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 DocNameI] -> 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) ------------------------------------------------------------------------------- @@ -431,12 +434,12 @@ ------------------------------------------------------------------------------- -ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName - -> LHsQTyVars DocName -> [Located ([Located DocName], [Located DocName])] +ppClassHdr :: Bool -> Located [LHsType DocNameI] -> DocName + -> LHsQTyVars DocNameI -> [Located ([Located DocName], [Located 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 @@ -449,7 +452,7 @@ fundep (vars1,vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2 ppVars = hsep . map ((ppDocName qual Prefix True) . unLoc) -ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan +ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocNameI -> SrcSpan -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs @@ -481,9 +484,9 @@ -ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] +ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)] -> SrcSpan -> Documentation DocName - -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName + -> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI -> Splice -> Unicode -> Qualification -> Html ppClassDecl summary links instances fixities loc d subdocs decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars @@ -513,14 +516,14 @@ doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs subfixs = [ f | f@(n',_) <- fixities, n == n' ] ] - methodBit = subMethods [ ppFunSig summary links loc doc names (hsSigType typ) + methodBit = subMethods [ ppFunSig summary links loc doc [name] (hsSigType typ) subfixs splice unicode qual | L _ (ClassOpSig _ lnames typ) <- lsigs - , let doc = lookupAnySubdoc (head names) subdocs - subfixs = [ f | n <- names - , f@(n',_) <- fixities - , n == n' ] - names = map unLoc lnames ] + , name <- map unLoc lnames + , let doc = lookupAnySubdoc name subdocs + subfixs = [ f | f@(n',_) <- fixities + , name == n' ] + ] -- N.B. taking just the first name is ok. Signatures with multiple names -- are expanded so that each name gets its own signature. @@ -554,7 +557,7 @@ ppInstances :: LinksInfo - -> InstOrigin DocName -> [DocInstance DocName] + -> InstOrigin DocName -> [DocInstance DocNameI] -> Splice -> Unicode -> Qualification -> Html ppInstances links origin instances splice unicode qual @@ -562,22 +565,22 @@ -- force Splice = True to use line URLs where instName = getOccString origin - instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName) + instDecl :: Int -> DocInstance DocNameI -> (SubDecl,Located DocName) instDecl no (inst, mdoc, loc) = ((ppInstHead links splice unicode qual mdoc origin False no inst), loc) ppOrphanInstances :: LinksInfo - -> [DocInstance DocName] + -> [DocInstance DocNameI] -> Splice -> Unicode -> Qualification -> Html ppOrphanInstances links instances splice unicode qual = subOrphanInstances qual links True (zipWith instDecl [1..] instances) where - instOrigin :: InstHead name -> InstOrigin name + instOrigin :: InstHead name -> InstOrigin (IdP name) instOrigin inst = OriginClass (ihdClsName inst) - instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName) + instDecl :: Int -> DocInstance DocNameI -> (SubDecl,Located DocName) instDecl no (inst, mdoc, loc) = ((ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst), loc) @@ -587,12 +590,12 @@ -> InstOrigin DocName -> Bool -- ^ Is instance orphan -> Int -- ^ Normal - -> InstHead DocName + -> InstHead DocNameI -> SubDecl 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 @@ 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 @@ -617,11 +620,11 @@ pdecl = pdata <+> ppShortDataDecl False True dd [] unicode qual where iid = instanceId origin no orphan ihd - typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode qual + typ = ppAppNameTypes ihdClsName ihdTypes unicode qual ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification - -> [PseudoFamilyDecl DocName] + -> [PseudoFamilyDecl DocNameI] -> [Html] ppInstanceAssocTys links splice unicode qual = map ppFamilyDecl' @@ -630,22 +633,22 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification - -> [Sig DocName] + -> [Sig DocNameI] -> [Html] 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 lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n -instanceId :: InstOrigin DocName -> Int -> Bool -> InstHead DocName -> String +instanceId :: InstOrigin DocName -> Int -> Bool -> InstHead DocNameI -> String instanceId origin no orphan ihd = concat $ [ "o:" | orphan ] ++ [ qual origin @@ -665,8 +668,8 @@ -- TODO: print contexts -ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName - -> [(HsDecl DocName,DocForDecl DocName)] +ppShortDataDecl :: Bool -> Bool -> TyClDecl DocNameI + -> [(HsDecl DocNameI, DocForDecl DocName)] -> Unicode -> Qualification -> Html ppShortDataDecl summary dataInst dataDecl pats unicode qual @@ -698,16 +701,16 @@ 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 ] -ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] -> +ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)] -> [(DocName, DocForDecl DocName)] -> - SrcSpan -> Documentation DocName -> TyClDecl DocName -> - [(HsDecl DocName,DocForDecl DocName)] -> + SrcSpan -> Documentation DocName -> TyClDecl DocNameI -> + [(HsDecl DocNameI, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats splice unicode qual @@ -744,7 +747,7 @@ [ (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 @@ -756,7 +759,7 @@ -ppShortConstr :: Bool -> ConDecl DocName -> Unicode -> Qualification -> Html +ppShortConstr :: Bool -> ConDecl DocNameI -> Unicode -> Qualification -> Html ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot where (cHead,cBody,cFoot) = ppShortConstrParts summary False con unicode qual @@ -764,22 +767,22 @@ -- returns three pieces: header, body, footer so that header & footer can be -- incorporated into the declaration -ppShortConstrParts :: Bool -> Bool -> ConDecl DocName -> Unicode -> Qualification -> (Html, Html, Html) +ppShortConstrParts :: Bool -> Bool -> ConDecl DocNameI -> Unicode -> Qualification -> (Html, Html, Html) 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) @@ -805,13 +808,13 @@ -- ppConstrHdr is for (non-GADT) existentials constructors' syntax -ppConstrHdr :: Bool -> [Name] -> HsContext DocName -> Unicode +ppConstrHdr :: Bool -> [Name] -> HsContext DocNameI -> Unicode -> Qualification -> Html 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) @@ -819,7 +822,7 @@ | otherwise = noHtml ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)] - -> Unicode -> Qualification -> LConDecl DocName -> SubDecl + -> Unicode -> Qualification -> LConDecl DocNameI -> SubDecl ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, fieldPart) where @@ -827,15 +830,15 @@ 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 @@ -849,10 +852,10 @@ doRecordFields fields = subFields qual (map (ppSideBySideField subdocs unicode qual) (map unLoc fields)) - doGADTCon :: Located (HsType DocName) -> Html + doGADTCon :: Located (HsType DocNameI) -> 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 @@ -877,26 +880,29 @@ ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification - -> ConDeclField DocName -> SubDecl + -> ConDeclField DocNameI -> 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 mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst -ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html +ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> 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. -- Currently doesn't handle 'data instance' decls or kind signatures -ppDataHeader :: Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html +ppDataHeader :: Bool -> TyClDecl DocNameI -> Unicode -> Qualification -> Html ppDataHeader summary decl@(DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd , dd_ctxt = ctxt @@ -906,7 +912,7 @@ (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,87 +964,109 @@ | 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 DocNameI) -> 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 DocNameI -> 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 DocNameI -> 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 :: Unicode -> Qualification -> HsTyVarBndr DocNameI -> Html ppHsTyVarBndr _ qual (UserTyVar (L _ name)) = ppDocName qual Raw False name ppHsTyVarBndr unicode qual (KindedTyVar name kind) = parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> ppLKind unicode qual kind) -ppLKind :: Unicode -> Qualification -> LHsKind DocName -> Html +ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> 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 -> Qualification -> HsKind DocNameI -> Html +ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual HideEmptyContexts -ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocName] -> Html +ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> 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 DocNameI] -> 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 DocNameI -> 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 DocNameI -> 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,24 @@ | 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 DocNameI -> LHsType DocNameI -> 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/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -20,6 +20,7 @@ ) where import Data.List +import Documentation.Haddock.Markup import Haddock.Backends.Xhtml.Names import Haddock.Backends.Xhtml.Utils import Haddock.Types @@ -72,7 +73,8 @@ markupMathDisplay = \mathjax -> toHtml ("\\[" ++ mathjax ++ "\\]"), markupProperty = pre . toHtml, markupExample = examplesToHtml, - markupHeader = \(Header l t) -> makeHeader l t + markupHeader = \(Header l t) -> makeHeader l t, + markupTable = \(Table h r) -> makeTable h r } where makeHeader :: Int -> Html -> Html @@ -84,7 +86,23 @@ makeHeader 6 mkup = h6 mkup makeHeader l _ = error $ "Somehow got a header level `" ++ show l ++ "' in DocMarkup!" + makeTable :: [TableRow Html] -> [TableRow Html] -> Html + makeTable hs bs = table (concatHtml (hs' ++ bs')) + where + hs' | null hs = [] + | otherwise = [thead (concatHtml (map (makeTableRow th) hs))] + bs' = [tbody (concatHtml (map (makeTableRow td) bs))] + + makeTableRow :: (Html -> Html) -> TableRow Html -> Html + makeTableRow thr (TableRow cs) = tr (concatHtml (map (makeTableCell thr) cs)) + + makeTableCell :: (Html -> Html) -> TableCell Html -> Html + makeTableCell thr (TableCell i j c) = thr c ! (i' ++ j') + where + i' = if i == 1 then [] else [ colspan i ] + j' = if j == 1 then [] else [ rowspan j ] + examplesToHtml l = pre (concatHtml $ map exampleToHtml l) ! [theclass "screen"] exampleToHtml (Example expression result) = htmlExample @@ -164,9 +182,9 @@ UntouchedDoc d -> (markup fmt $ _doc d, [_meta d]) CollapsingHeader (Header lvl titl) par n nm -> let id_ = makeAnchorId $ "ch:" ++ fromMaybe "noid:" nm ++ show n - expanded = False - col' = collapseControl id_ expanded "caption" - instTable = (thediv ! collapseSection id_ expanded [] <<) + col' = collapseControl id_ "caption" + summary = thesummary ! [ theclass "hide-when-js-enabled" ] << "Expand" + instTable contents = collapseDetails id_ DetailsClosed (summary +++ contents) lvs = zip [1 .. ] [h1, h2, h3, h4, h5, h6] getHeader = fromMaybe caption (lookup lvl lvs) subCaption = getHeader ! col' << markup fmt titl diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -199,10 +199,10 @@ -> [(SubDecl,Located DocName)] -> Html subInstances qual nm lnks splice = maybe noHtml wrap . instTable where - wrap = (subSection <<) . (subCaption +++) - instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTableSrc qual lnks splice + wrap contents = subSection (collapseDetails id_ DetailsOpen (summary +++ contents)) + instTable = subTableSrc qual lnks splice subSection = thediv ! [theclass "subs instances"] - subCaption = paragraph ! collapseControl id_ True "caption" << "Instances" + summary = thesummary << "Instances" id_ = makeAnchorId $ "i:" ++ nm @@ -212,7 +212,7 @@ subOrphanInstances qual lnks splice = maybe noHtml wrap . instTable where wrap = ((h1 << "Orphan instances") +++) - instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTableSrc qual lnks splice + instTable = fmap (thediv ! [ identifier ("section." ++ id_) ] <<) . subTableSrc qual lnks splice id_ = makeAnchorId $ "orphans" @@ -222,7 +222,7 @@ subInstHead iid hdr = expander noHtml <+> hdr where - expander = thespan ! collapseControl (instAnchorId iid) False "instance" + expander = thespan ! collapseControl (instAnchorId iid) "instance" subInstDetails :: String -- ^ Instance unique id (for anchor generation) @@ -241,7 +241,9 @@ subInstSection :: String -- ^ Instance unique id (for anchor generation) -> Html -> Html -subInstSection iid = thediv ! collapseSection (instAnchorId iid) False "inst-details" +subInstSection iid contents = collapseDetails (instAnchorId iid) DetailsClosed (summary +++ contents) + where + summary = thesummary ! [ theclass "hide-when-js-enabled" ] << "Instance details" instAnchorId :: String -> String instAnchorId iid = makeAnchorId $ "i:" ++ iid diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Meta.hs b/haddock-api/src/Haddock/Backends/Xhtml/Meta.hs new file mode 100644 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Xhtml/Meta.hs @@ -0,0 +1,28 @@ +module Haddock.Backends.Xhtml.Meta where + +import Haddock.Utils.Json +import Haddock.Version + +import Data.ByteString.Builder (hPutBuilder) +import System.FilePath (()) +import System.IO (withFile, IOMode (WriteMode)) + +-- | Everytime breaking changes to the Quckjump api +-- happen this needs to be modified. +quickjumpVersion :: Int +quickjumpVersion = 1 + +-- | Writes a json encoded file containing additional +-- information about the generated documentation. This +-- is useful for external tools (e.g. hackage). +writeHaddockMeta :: FilePath -> Bool -> IO () +writeHaddockMeta odir withQuickjump = do + let + meta_json :: Value + meta_json = object (concat [ + [ "haddock_version" .= String projectVersion ] + , [ "quickjump_version" .= quickjumpVersion | withQuickjump ] + ]) + + withFile (odir "meta.json") WriteMode $ \h -> + hPutBuilder h (encodeToBuilder meta_json) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs --- a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs @@ -22,7 +22,7 @@ import Haddock.Types import Haddock.Utils -import Text.XHtml hiding ( name, title, p, quote ) +import Text.XHtml hiding ( name, p, quote ) import qualified Data.Map as M import qualified Data.List as List @@ -147,17 +147,19 @@ linkIdOcc :: Module -> Maybe OccName -> Bool -> Html -> Html linkIdOcc mdl mbName insertAnchors = if insertAnchors - then anchor ! [href url] + then anchor ! [href url, title ttl] else id where + ttl = moduleNameString (moduleName mdl) url = case mbName of Nothing -> moduleUrl mdl Just name -> moduleNameUrl mdl name linkIdOcc' :: ModuleName -> Maybe OccName -> Html -> Html -linkIdOcc' mdl mbName = anchor ! [href url] +linkIdOcc' mdl mbName = anchor ! [href url, title ttl] where + ttl = moduleNameString mdl url = case mbName of Nothing -> moduleHtmlFile' mdl Just name -> moduleNameUrl' mdl name diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs --- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs @@ -25,7 +25,8 @@ hsep, vcat, - collapseSection, collapseToggle, collapseControl, + DetailsState(..), collapseDetails, thesummary, + collapseToggle, collapseControl, ) where @@ -213,26 +214,22 @@ -- A section of HTML which is collapsible. -- --- | Attributes for an area that can be collapsed -collapseSection :: String -> Bool -> String -> [HtmlAttr] -collapseSection id_ state classes = [ identifier sid, theclass cs ] - where cs = unwords (words classes ++ [pick state "show" "hide"]) - sid = "section." ++ id_ +data DetailsState = DetailsOpen | DetailsClosed +collapseDetails :: String -> DetailsState -> Html -> Html +collapseDetails id_ state = tag "details" ! (identifier id_ : openAttrs) + where openAttrs = case state of { DetailsOpen -> [emptyAttr "open"]; DetailsClosed -> [] } + +thesummary :: Html -> Html +thesummary = tag "summary" + -- | Attributes for an area that toggles a collapsed area -collapseToggle :: String -> [HtmlAttr] -collapseToggle id_ = [ strAttr "onclick" js ] - where js = "toggleSection('" ++ id_ ++ "')"; +collapseToggle :: String -> String -> [HtmlAttr] +collapseToggle id_ classes = [ theclass cs, strAttr "data-details-id" id_ ] + where cs = unwords (words classes ++ ["details-toggle"]) -- | Attributes for an area that toggles a collapsed area, -- and displays a control. -collapseControl :: String -> Bool -> String -> [HtmlAttr] -collapseControl id_ state classes = - [ identifier cid, theclass cs ] ++ collapseToggle id_ - where cs = unwords (words classes ++ [pick state "collapser" "expander"]) - cid = "control." ++ id_ - - -pick :: Bool -> a -> a -> a -pick True t _ = t -pick False _ f = f +collapseControl :: String -> String -> [HtmlAttr] +collapseControl id_ classes = collapseToggle id_ cs + where cs = unwords (words classes ++ ["details-toggle-control"]) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -24,6 +24,7 @@ import Data.Either (lefts, rights) import DataCon import FamInstEnv +import FV import HsSyn import Name import NameSet ( emptyNameSet ) @@ -39,8 +40,10 @@ import PrelNames ( hasKey, eqTyConKey, ipClassKey , tYPETyConKey, liftedRepDataConKey ) import Unique ( getUnique ) -import Util ( filterByList, filterOut ) +import Util ( chkAppend, compareLength, dropList, filterByList, filterOut + , splitAtList ) import Var +import VarSet import Haddock.Types import Haddock.Interface.Specialize @@ -48,7 +51,7 @@ -- the main function here! yay! -tyThingToLHsDecl :: TyThing -> Either ErrMsg ([ErrMsg], (HsDecl Name)) +tyThingToLHsDecl :: TyThing -> Either ErrMsg ([ErrMsg], (HsDecl GhcRn)) tyThingToLHsDecl t = case t of -- ids (functions and zero-argument a.k.a. CAFs) get a type signature. -- Including built-in functions like seq. @@ -76,7 +79,7 @@ in withErrs (tyClErrors ++ famDeclErrors) . TyClD $ ClassDecl { tcdCtxt = synifyCtx (classSCTheta cl) , tcdLName = synifyName cl - , tcdTyVars = synifyTyVars (classTyVars cl) + , tcdTyVars = synifyTyVars (tyConVisibleTyVars (classTyCon cl)) , tcdFixity = Prefix , tcdFDs = map (\ (l,r) -> noLoc (map (noLoc . getName) l, map (noLoc . getName) r) ) $ @@ -107,25 +110,30 @@ withErrs e x = return (e, x) allOK x = return (mempty, x) -synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn Name +synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn GhcRn synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) - = let name = synifyName tc - typats = map (synifyType WithinType) args - hs_rhs = synifyType WithinType rhs - in TyFamEqn { tfe_tycon = name - , tfe_pats = HsIB { hsib_body = typats - , hsib_vars = map tyVarName tkvs - , hsib_closed = True } - , tfe_fixity = Prefix - , tfe_rhs = hs_rhs } + = let name = synifyName tc + args_types_only = filterOutInvisibleTypes tc args + typats = map (synifyType WithinType) args_types_only + annot_typats = zipWith3 annotHsType (mkIsPolyTvs fam_tvs) + args_types_only typats + hs_rhs = synifyType WithinType rhs + in HsIB { hsib_vars = map tyVarName tkvs + , hsib_closed = True + , hsib_body = FamEqn { feqn_tycon = name + , feqn_pats = annot_typats + , feqn_fixity = Prefix + , feqn_rhs = hs_rhs } } + where + fam_tvs = tyConVisibleTyVars tc -synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl Name) +synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl GhcRn) synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) | isOpenTypeFamilyTyCon tc , Just branch <- coAxiomSingleBranch_maybe ax - = return $ InstD (TyFamInstD - (TyFamInstDecl { tfid_eqn = noLoc $ synifyAxBranch tc branch - , tfid_fvs = placeHolderNamesTc })) + = return $ InstD + $ TyFamInstD + $ TyFamInstDecl { tfid_eqn = synifyAxBranch tc branch } | Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc , getUnique ax' == getUnique ax -- without the getUniques, type error @@ -135,7 +143,7 @@ = Left "synifyAxiom: closed/open family confusion" -- | Turn type constructors into type class declarations -synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> Either ErrMsg (TyClDecl Name) +synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> Either ErrMsg (TyClDecl GhcRn) synifyTyCon _coax tc | isFunTyCon tc || isPrimTyCon tc = return $ @@ -155,7 +163,7 @@ -- algebraic data nor newtype: , dd_ctxt = noLoc [] , dd_cType = Nothing - , dd_kindSig = Just (synifyKindSig (tyConKind tc)) + , dd_kindSig = synifyDataTyConReturnKind tc -- we have their kind accurately: , dd_cons = [] -- No constructors , dd_derivs = noLoc [] } @@ -184,19 +192,19 @@ mkFamDecl i = return $ FamDecl $ FamilyDecl { fdInfo = i , fdLName = synifyName tc - , fdTyVars = synifyTyVars (tyConTyVars tc) + , fdTyVars = synifyTyVars (tyConVisibleTyVars tc) , fdFixity = Prefix , fdResultSig = synifyFamilyResultSig resultVar (tyConResKind tc) , fdInjectivityAnn = synifyInjectivityAnn resultVar (tyConTyVars tc) - (familyTyConInjectivityInfo tc) + (tyConInjectivityInfo tc) } synifyTyCon coax tc | Just ty <- synTyConRhs_maybe tc = return $ SynDecl { tcdLName = synifyName tc - , tcdTyVars = synifyTyVars (tyConTyVars tc) + , tcdTyVars = synifyTyVars (tyConVisibleTyVars tc) , tcdFixity = Prefix , tcdRhs = synifyType WithinType ty , tcdFVs = placeHolderNamesTc } @@ -209,8 +217,8 @@ Just a -> synifyName a -- Data families are named according to their -- CoAxioms, not their TyCons _ -> synifyName tc - tyvars = synifyTyVars (tyConTyVars tc) - kindSig = Just (tyConKind tc) + tyvars = synifyTyVars (tyConVisibleTyVars tc) + kindSig = synifyDataTyConReturnKind tc -- The data constructors. -- -- Any data-constructors not exported from the module that *defines* the @@ -235,7 +243,7 @@ defn = HsDataDefn { dd_ND = alg_nd , dd_ctxt = alg_ctx , dd_cType = Nothing - , dd_kindSig = fmap synifyKindSig kindSig + , dd_kindSig = kindSig , dd_cons = cons , dd_derivs = alg_deriv } in case lefts consRaw of @@ -245,15 +253,36 @@ , tcdDataCusk = False, tcdFVs = placeHolderNamesTc } dataConErrs -> Left $ unlines dataConErrs +-- In this module, every TyCon being considered has come from an interface +-- file. This means that when considering a data type constructor such as: +-- +-- data Foo (w :: *) (m :: * -> *) (a :: *) +-- +-- Then its tyConKind will be (* -> (* -> *) -> * -> *). But beware! We are +-- also rendering the type variables of Foo, so if we synify the tyConKind of +-- Foo in full, we will end up displaying this in Haddock: +-- +-- data Foo (w :: *) (m :: * -> *) (a :: *) +-- :: * -> (* -> *) -> * -> * +-- +-- Which is entirely wrong (#548). We only want to display the *return* kind, +-- which this function obtains. +synifyDataTyConReturnKind :: TyCon -> Maybe (LHsKind GhcRn) +synifyDataTyConReturnKind tc + = case splitFunTys (tyConKind tc) of + (_, ret_kind) + | isLiftedTypeKind ret_kind -> Nothing -- Don't bother displaying :: * + | otherwise -> Just (synifyKindSig ret_kind) + synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity - -> Maybe (LInjectivityAnn Name) + -> Maybe (LInjectivityAnn GhcRn) synifyInjectivityAnn Nothing _ _ = Nothing synifyInjectivityAnn _ _ NotInjective = Nothing synifyInjectivityAnn (Just lhs) tvs (Injective inj) = let rhs = map (noLoc . tyVarName) (filterByList inj tvs) in Just $ noLoc $ InjectivityAnn (noLoc lhs) rhs -synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig Name +synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn synifyFamilyResultSig Nothing kind = noLoc $ KindSig (synifyKindSig kind) synifyFamilyResultSig (Just name) kind = @@ -264,7 +293,7 @@ -- result-type. -- But you might want pass False in simple enough cases, -- if you think it looks better. -synifyDataCon :: Bool -> DataCon -> Either ErrMsg (LConDecl Name) +synifyDataCon :: Bool -> DataCon -> Either ErrMsg (LConDecl GhcRn) synifyDataCon use_gadt_syntax dc = let -- dataConIsInfix allegedly tells us whether it was declared with @@ -321,22 +350,22 @@ synifyName n = L (srcLocSpan (getSrcLoc n)) (getName n) -synifyIdSig :: SynifyTypeState -> Id -> Sig Name +synifyIdSig :: SynifyTypeState -> Id -> Sig GhcRn synifyIdSig s i = TypeSig [synifyName i] (synifySigWcType s (varType i)) -synifyTcIdSig :: SynifyTypeState -> Id -> Sig Name +synifyTcIdSig :: SynifyTypeState -> Id -> Sig GhcRn synifyTcIdSig s i = ClassOpSig False [synifyName i] (synifySigType s (varType i)) -synifyCtx :: [PredType] -> LHsContext Name +synifyCtx :: [PredType] -> LHsContext GhcRn synifyCtx = noLoc . map (synifyType WithinType) -synifyTyVars :: [TyVar] -> LHsQTyVars Name +synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn synifyTyVars ktvs = HsQTvs { hsq_implicit = [] , hsq_explicit = map synifyTyVar ktvs , hsq_dependent = emptyNameSet } -synifyTyVar :: TyVar -> LHsTyVarBndr Name +synifyTyVar :: TyVar -> LHsTyVarBndr GhcRn synifyTyVar tv | isLiftedTypeKind kind = noLoc (UserTyVar (noLoc name)) | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind)) @@ -344,6 +373,33 @@ kind = tyVarKind tv name = getName tv +-- | Annotate (with HsKingSig) a type if the first parameter is True +-- and if the type contains a free variable. +-- This is used to synify type patterns for poly-kinded tyvars in +-- synifying class and type instances. +annotHsType :: Bool -- True <=> annotate + -> Type -> LHsType GhcRn -> LHsType GhcRn + -- tiny optimization: if the type is annotated, don't annotate again. +annotHsType _ _ hs_ty@(L _ (HsKindSig {})) = hs_ty +annotHsType True ty hs_ty + | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty + = let ki = typeKind ty + hs_ki = synifyType WithinType ki + in noLoc (HsKindSig hs_ty hs_ki) +annotHsType _ _ hs_ty = hs_ty + +-- | For every type variable in the input, +-- report whether or not the tv is poly-kinded. This is used to eventually +-- feed into 'annotHsType'. +mkIsPolyTvs :: [TyVar] -> [Bool] +mkIsPolyTvs = map is_poly_tv + where + is_poly_tv tv = not $ + isEmptyVarSet $ + filterVarSet isTyVar $ + tyCoVarsOfType $ + tyVarKind tv + --states of what to do with foralls: data SynifyTypeState = WithinType @@ -360,53 +416,95 @@ -- the defining class gets to quantify all its functions for free! -synifySigType :: SynifyTypeState -> Type -> LHsSigType Name +synifySigType :: SynifyTypeState -> Type -> LHsSigType GhcRn -- The empty binders is a bit suspicious; -- what if the type has free variables? synifySigType s ty = mkEmptyImplicitBndrs (synifyType s ty) -synifySigWcType :: SynifyTypeState -> Type -> LHsSigWcType Name +synifySigWcType :: SynifyTypeState -> Type -> LHsSigWcType GhcRn -- Ditto (see synifySigType) synifySigWcType s ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs (synifyType s ty)) -synifyPatSynSigType :: PatSyn -> LHsSigType Name +synifyPatSynSigType :: PatSyn -> LHsSigType GhcRn -- Ditto (see synifySigType) synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps) -synifyType :: SynifyTypeState -> Type -> LHsType Name +synifyType :: SynifyTypeState -> Type -> LHsType GhcRn synifyType _ (TyVarTy tv) = noLoc $ HsTyVar NotPromoted $ noLoc (getName tv) synifyType _ (TyConApp tc tys) - -- Use */# instead of TYPE 'Lifted/TYPE 'Unlifted (#473) - | tc `hasKey` tYPETyConKey - , [TyConApp lev []] <- tys - , lev `hasKey` liftedRepDataConKey - = noLoc (HsTyVar NotPromoted (noLoc starKindTyConName)) - -- Use non-prefix tuple syntax where possible, because it looks nicer. - | Just sort <- tyConTuple_maybe tc - , tyConArity tc == length tys - = noLoc $ HsTupleTy (case sort of - BoxedTuple -> HsBoxedTuple - ConstraintTuple -> HsConstraintTuple - UnboxedTuple -> HsUnboxedTuple) - (map (synifyType WithinType) tys) - -- ditto for lists - | getName tc == listTyConName, [ty] <- tys = - noLoc $ HsListTy (synifyType WithinType ty) - -- ditto for implicit parameter tycons - | tc `hasKey` ipClassKey - , [name, ty] <- tys - , Just x <- isStrLitTy name - = noLoc $ HsIParamTy (noLoc $ HsIPName x) (synifyType WithinType ty) - -- and equalities - | tc `hasKey` eqTyConKey - , [ty1, ty2] <- tys - = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2) - -- Most TyCons: - | otherwise = - foldl (\t1 t2 -> noLoc (HsAppTy t1 t2)) - (noLoc $ HsTyVar NotPromoted $ noLoc (getName tc)) - (map (synifyType WithinType) $ - filterOut isCoercionTy tys) + = maybe_sig res_ty + where + res_ty :: LHsType GhcRn + res_ty + -- Use */# instead of TYPE 'Lifted/TYPE 'Unlifted (#473) + | tc `hasKey` tYPETyConKey + , [TyConApp lev []] <- tys + , lev `hasKey` liftedRepDataConKey + = noLoc (HsTyVar NotPromoted (noLoc starKindTyConName)) + -- Use non-prefix tuple syntax where possible, because it looks nicer. + | Just sort <- tyConTuple_maybe tc + , tyConArity tc == length tys + = noLoc $ HsTupleTy (case sort of + BoxedTuple -> HsBoxedTuple + ConstraintTuple -> HsConstraintTuple + UnboxedTuple -> HsUnboxedTuple) + (map (synifyType WithinType) vis_tys) + -- ditto for lists + | getName tc == listTyConName, [ty] <- tys = + noLoc $ HsListTy (synifyType WithinType ty) + -- ditto for implicit parameter tycons + | tc `hasKey` ipClassKey + , [name, ty] <- tys + , Just x <- isStrLitTy name + = noLoc $ HsIParamTy (noLoc $ HsIPName x) (synifyType WithinType ty) + -- and equalities + | tc `hasKey` eqTyConKey + , [ty1, ty2] <- tys + = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2) + -- and infix type operators + | isSymOcc (nameOccName (getName tc)) + , ty1:ty2:tys_rest <- vis_tys + = mk_app_tys (HsOpTy (synifyType WithinType ty1) + (noLoc $ getName tc) + (synifyType WithinType ty2)) + tys_rest + -- Most TyCons: + | otherwise + = mk_app_tys (HsTyVar NotPromoted $ noLoc (getName tc)) + vis_tys + where + mk_app_tys ty_app ty_args = + foldl (\t1 t2 -> noLoc $ HsAppTy t1 t2) + (noLoc ty_app) + (map (synifyType WithinType) $ + filterOut isCoercionTy ty_args) + + vis_tys = filterOutInvisibleTypes tc tys + binders = tyConBinders tc + res_kind = tyConResKind tc + + maybe_sig :: LHsType GhcRn -> LHsType GhcRn + maybe_sig ty' + | needs_kind_sig + = let full_kind = typeKind (mkTyConApp tc tys) + full_kind' = synifyType WithinType full_kind + in noLoc $ HsKindSig ty' full_kind' + | otherwise = ty' + + needs_kind_sig :: Bool + needs_kind_sig + | GT <- compareLength tys binders + = False + | otherwise + = let (dropped_binders, remaining_binders) + = splitAtList tys binders + result_kind = mkTyConKind remaining_binders res_kind + result_vars = tyCoVarsOfType result_kind + dropped_vars = fvVarSet $ + mapUnionFV injectiveVarsOfBinder dropped_binders + + in not (subVarSet result_vars dropped_vars) + synifyType s (AppTy t1 (CoercionTy {})) = synifyType s t1 synifyType _ (AppTy t1 t2) = let s1 = synifyType WithinType t1 @@ -430,7 +528,7 @@ synifyType s (CastTy t _) = synifyType s t synifyType _ (CoercionTy {}) = error "synifyType:Coercion" -synifyPatSynType :: PatSyn -> LHsType Name +synifyPatSynType :: PatSyn -> LHsType GhcRn synifyPatSynType ps = let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSig ps req_theta' | null req_theta && not (null prov_theta && null ex_tvs) = [unitTy] @@ -450,17 +548,16 @@ synifyTyLit (NumTyLit n) = HsNumTy NoSourceText n synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s -synifyKindSig :: Kind -> LHsKind Name +synifyKindSig :: Kind -> LHsKind GhcRn synifyKindSig k = synifyType WithinType k -synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name +synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead GhcRn synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead { ihdClsName = getName cls - , ihdKinds = map (unLoc . synifyType WithinType) ks - , ihdTypes = map (unLoc . synifyType WithinType) ts + , ihdTypes = map unLoc annot_ts , ihdInstType = ClassInst { clsiCtx = map (unLoc . synifyType WithinType) preds - , clsiTyVars = synifyTyVars $ classTyVars cls + , clsiTyVars = synifyTyVars (tyConVisibleTyVars cls_tycon) , clsiSigs = map synifyClsIdSig $ classMethods cls , clsiAssocTys = do (Right (FamDecl fam)) <- map (synifyTyCon Nothing) $ classATs cls @@ -468,24 +565,48 @@ } } where - (ks,ts) = partitionInvisibles (classTyCon cls) id types + cls_tycon = classTyCon cls + ts = filterOutInvisibleTypes cls_tycon types + ts' = map (synifyType WithinType) ts + annot_ts = zipWith3 annotHsType is_poly_tvs ts ts' + is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars cls_tycon) synifyClsIdSig = synifyIdSig DeleteTopLevelQuantification -- Convert a family instance, this could be a type family or data family -synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead Name) +synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead GhcRn) synifyFamInst fi opaque = do - ityp' <- ityp $ fi_flavor fi + ityp' <- ityp fam_flavor return InstHead { ihdClsName = fi_fam fi - , ihdKinds = synifyTypes ks - , ihdTypes = synifyTypes ts + , ihdTypes = map unLoc annot_ts , ihdInstType = ityp' } where ityp SynFamilyInst | opaque = return $ TypeInst Nothing ityp SynFamilyInst = - return . TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi + return . TypeInst . Just . unLoc $ synifyType WithinType fam_rhs ityp (DataFamilyInst c) = DataInst <$> synifyTyCon (Just $ famInstAxiom fi) c - (ks,ts) = partitionInvisibles (famInstTyCon fi) id $ fi_tys fi - synifyTypes = map (unLoc. synifyType WithinType) + fam_tc = famInstTyCon fi + fam_flavor = fi_flavor fi + fam_lhs = fi_tys fi + fam_rhs = fi_rhs fi + + eta_expanded_lhs + -- eta-expand lhs types, because sometimes data/newtype + -- instances are eta-reduced; See Trac #9692 + -- See Note [Eta reduction for data family axioms] in TcInstDcls in GHC + | DataFamilyInst rep_tc <- fam_flavor + = let (_, rep_tc_args) = splitTyConApp fam_rhs + etad_tyvars = dropList rep_tc_args $ tyConTyVars rep_tc + etad_tys = mkTyVarTys etad_tyvars + eta_exp_lhs = fam_lhs `chkAppend` etad_tys + in eta_exp_lhs + | otherwise + = fam_lhs + + ts = filterOutInvisibleTypes fam_tc eta_expanded_lhs + synifyTypes = map (synifyType WithinType) + ts' = synifyTypes ts + annot_ts = zipWith3 annotHsType is_poly_tvs ts ts' + is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars fam_tc) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -43,7 +43,7 @@ isConSym = isLexConSym . occNameFS -getMainDeclBinder :: HsDecl name -> [name] +getMainDeclBinder :: HsDecl name -> [IdP name] getMainDeclBinder (TyClD d) = [tcdName d] getMainDeclBinder (ValD d) = case collectHsBindBinders d of @@ -59,21 +59,22 @@ -- instanceMap. getInstLoc :: InstDecl name -> SrcSpan getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty) -getInstLoc (DataFamInstD (DataFamInstDecl { dfid_tycon = L l _ })) = l +getInstLoc (DataFamInstD (DataFamInstDecl + { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}})) = l getInstLoc (TyFamInstD (TyFamInstDecl -- Since CoAxioms' Names refer to the whole line for type family instances -- in particular, we need to dig a bit deeper to pull out the entire -- equation. This does not happen for data family instances, for some reason. - { tfid_eqn = L _ (TyFamEqn { tfe_rhs = L l _ })})) = l + { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}})) = l -- Useful when there is a signature with multiple names, e.g. -- foo, bar :: Types.. -- but only one of the names is exported and we have to change the -- type signature to only include the exported names. -filterLSigNames :: (name -> Bool) -> LSig name -> Maybe (LSig name) +filterLSigNames :: (IdP name -> Bool) -> LSig name -> Maybe (LSig name) filterLSigNames p (L loc sig) = L loc <$> (filterSigNames p sig) -filterSigNames :: (name -> Bool) -> Sig name -> Maybe (Sig name) +filterSigNames :: (IdP name -> Bool) -> Sig name -> Maybe (Sig name) filterSigNames p orig@(SpecSig n _ _) = ifTrueJust (p $ unLoc n) orig filterSigNames p orig@(InlineSig n _) = ifTrueJust (p $ unLoc n) orig filterSigNames p (FixSig (FixitySig ns ty)) = @@ -99,10 +100,10 @@ ifTrueJust True = Just ifTrueJust False = const Nothing -sigName :: LSig name -> [name] +sigName :: LSig name -> [IdP name] sigName (L _ sig) = sigNameNoLoc sig -sigNameNoLoc :: Sig name -> [name] +sigNameNoLoc :: Sig name -> [IdP name] sigNameNoLoc (TypeSig ns _) = map unLoc ns sigNameNoLoc (ClassOpSig _ ns _) = map unLoc ns sigNameNoLoc (PatSynSig ns _) = map unLoc ns @@ -128,7 +129,7 @@ isValD _ = False -declATs :: HsDecl a -> [a] +declATs :: HsDecl a -> [IdP a] declATs (TyClD d) | isClassDecl d = map (unL . fdLName . unL) $ tcdATs d declATs _ = [] @@ -164,7 +165,7 @@ ------------------------------------------------------------------------------- -instance NamedThing (TyClDecl Name) where +instance NamedThing (TyClDecl GhcRn) where getName = tcdName ------------------------------------------------------------------------------- @@ -176,14 +177,14 @@ children :: a -> [Name] -instance Parent (ConDecl Name) where +instance Parent (ConDecl GhcRn) where children con = case getConDetails con of RecCon fields -> map (selectorFieldOcc . unL) $ concatMap (cd_fld_names . unL) (unL fields) _ -> [] -instance Parent (TyClDecl Name) where +instance Parent (TyClDecl GhcRn) where children d | isDataDecl d = map unL $ concatMap (getConNames . unL) $ (dd_cons . tcdDataDefn) $ d @@ -198,12 +199,12 @@ family = getName &&& children -familyConDecl :: ConDecl Name -> [(Name, [Name])] +familyConDecl :: ConDecl GHC.GhcRn -> [(Name, [Name])] familyConDecl d = zip (map unL (getConNames d)) (repeat $ children d) -- | A mapping from the parent (main-binder) to its children and from each -- child to its grand-children, recursively. -families :: TyClDecl Name -> [(Name, [Name])] +families :: TyClDecl GhcRn -> [(Name, [Name])] families d | isDataDecl d = family d : concatMap (familyConDecl . unL) (dd_cons (tcdDataDefn d)) | isClassDecl d = [family d] @@ -211,12 +212,12 @@ -- | A mapping from child to parent -parentMap :: TyClDecl Name -> [(Name, Name)] +parentMap :: TyClDecl GhcRn -> [(Name, Name)] parentMap d = [ (c, p) | (p, cs) <- families d, c <- cs ] -- | The parents of a subordinate in a declaration -parents :: Name -> HsDecl Name -> [Name] +parents :: Name -> HsDecl GhcRn -> [Name] parents n (TyClD d) = [ p | (c, p) <- parentMap d, c == n ] parents _ _ = [] diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -58,6 +58,8 @@ import HscTypes import FastString (unpackFS) import MonadUtils (liftIO) +import TcRnTypes (tcg_rdr_env) +import RdrName (plusGlobalRdrEnv) #if defined(mingw32_HOST_OS) import System.IO @@ -122,11 +124,7 @@ -- resulting ModSummaries. (if useTempDir then withTempOutputDir else id) $ do modGraph <- depAnalysis - if needsTemplateHaskell modGraph then do - modGraph' <- enableCompilation modGraph - createIfaces verbosity flags instIfaceMap modGraph' - else - createIfaces verbosity flags instIfaceMap modGraph + createIfaces verbosity flags instIfaceMap modGraph where useTempDir :: Bool @@ -149,17 +147,6 @@ depanal [] False - enableCompilation :: ModuleGraph -> Ghc ModuleGraph - enableCompilation modGraph = do - let enableComp d = let platform = targetPlatform d - in d { hscTarget = defaultObjectTarget platform } - modifySessionDynFlags enableComp - -- We need to update the DynFlags of the ModSummaries as well. - let upd m = m { ms_hspp_opts = enableComp (ms_hspp_opts m) } - let modGraph' = map upd modGraph - return modGraph' - - createIfaces :: Verbosity -> [Flag] -> InstIfaceMap -> ModuleGraph -> Ghc [Interface] createIfaces verbosity flags instIfaceMap mods = do let sortedMods = flattenSCCs $ topSortModuleGraph False mods Nothing @@ -178,6 +165,18 @@ processModule verbosity modsum flags modMap instIfaceMap = do out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..." tm <- loadModule =<< typecheckModule =<< parseModule modsum + + -- We need to modify the interactive context's environment so that when + -- Haddock later looks for instances, it also looks in the modules it + -- encountered while typechecking. + -- + -- See https://github.com/haskell/haddock/issues/469. + hsc_env@HscEnv{ hsc_IC = old_IC } <- getSession + let new_rdr_env = tcg_rdr_env . fst . GHC.tm_internals_ $ tm + setSession hsc_env{ hsc_IC = old_IC { + ic_rn_gbl_env = ic_rn_gbl_env old_IC `plusGlobalRdrEnv` new_rdr_env + } } + if not $ isBootSummary modsum then do out verbosity verbose "Creating interface..." (interface, msg) <- runWriterGhc $ createInterface tm flags modMap instIfaceMap @@ -194,7 +193,7 @@ , expItemMbDoc = (Documentation Nothing _, _) } <- ifaceExportItems interface ] where - formatName :: SrcSpan -> HsDecl Name -> String + formatName :: SrcSpan -> HsDecl GhcRn -> String formatName loc n = p (getMainDeclBinder n) ++ case loc of RealSrcSpan rss -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++ show (srcSpanStartLine rss) ++ ")" _ -> "" @@ -206,12 +205,13 @@ then drop (length ms) n else n - out verbosity normal coverageMsg - when (Flag_NoPrintMissingDocs `notElem` flags - && not (null undocumentedExports && header)) $ do - out verbosity normal " Missing documentation for:" - unless header $ out verbosity normal " Module header" - mapM_ (out verbosity normal . (" " ++)) undocumentedExports + when (OptHide `notElem` ifaceOptions interface) $ do + out verbosity normal coverageMsg + when (Flag_NoPrintMissingDocs `notElem` flags + && not (null undocumentedExports && header)) $ do + out verbosity normal " Missing documentation for:" + unless header $ out verbosity normal " Module header" + mapM_ (out verbosity normal . (" " ++)) undocumentedExports interface' <- liftIO $ evaluate interface return (Just interface') else diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP, MagicHash #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.AttachInstances @@ -18,7 +19,6 @@ import Haddock.Convert import Haddock.GhcUtils -import Control.Applicative import Control.Arrow hiding ((<+>)) import Data.List import Data.Ord (comparing) @@ -53,7 +53,7 @@ -- Also attaches fixities attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> Ghc [Interface] attachInstances expInfo ifaces instIfaceMap = do - (_msgs, mb_index) <- getNameToInstancesIndex + (_msgs, mb_index) <- getNameToInstancesIndex (map ifaceMod ifaces) mapM (attach $ fromMaybe emptyNameEnv mb_index) ifaces where -- TODO: take an IfaceMap as input @@ -67,7 +67,7 @@ , ifaceOrphanInstances = orphanInstances } -attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance Name] +attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance GhcRn] attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, (L (getSrcSpan n) n)) | let is = [ (instanceSig i, getName i) | i <- cls_instances, isOrphan (is_orphan i) ] @@ -82,8 +82,8 @@ -> Interface -> IfaceMap -> InstIfaceMap - -> ExportItem Name - -> Ghc (ExportItem Name) + -> ExportItem GhcRn + -> Ghc (ExportItem GhcRn) attachToExportItem index expInfo iface ifaceMap instIfaceMap export = case attachFixities export of e@ExportDecl { expItemDecl = L eSpan (TyClD d) } -> do @@ -117,12 +117,12 @@ where attachFixities e@ExportDecl{ expItemDecl = L _ d , expItemPats = patsyns + , expItemSubDocs = subDocs } = e { expItemFixities = nubByName fst $ expItemFixities e ++ [ (n',f) | n <- getMainDeclBinder d - , Just subs <- [instLookup instSubMap n iface ifaceMap instIfaceMap <|> Just []] - , n' <- n : (subs ++ patsyn_names) - , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap] + , n' <- n : (map fst subDocs ++ patsyn_names) + , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap] ] } where patsyn_names = concatMap (getMainDeclBinder . fst) patsyns diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP, TupleSections, BangPatterns, LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wwarn #-} ----------------------------------------------------------------------------- -- | @@ -30,27 +31,30 @@ import Haddock.Backends.Hyperlinker.Ast as Hyperlinker import Haddock.Backends.Hyperlinker.Parser as Hyperlinker +import Data.Bifunctor +import Data.Bitraversable import qualified Data.ByteString as BS import qualified Data.Map as M import Data.Map (Map) import Data.List 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 +import Avail hiding (avail) +import qualified Avail import qualified Packages import qualified Module import qualified SrcLoc +import ConLike (ConLike(..)) import GHC import HscTypes import Name import NameSet +import NameEnv import Bag import RdrName import TcRnTypes @@ -59,6 +63,7 @@ import qualified Outputable as O 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'. @@ -83,48 +88,36 @@ (TcGblEnv { tcg_rdr_env = gre , tcg_warns = warnings - , tcg_patsyns = patsyns + , tcg_exports = all_exports }, md) = tm_internals_ tm -- The renamed source should always be available to us, but it's best -- to be on the safe side. - (group_, mayExports, mayDocHeader) <- + (group_, imports, mayExports, mayDocHeader) <- case renamedSource tm of Nothing -> do liftErrMsg $ tell [ "Warning: Renamed source is not available." ] - return (emptyRnGroup, Nothing, Nothing) - Just (x, _, y, z) -> return (x, y, z) + return (emptyRnGroup, [], Nothing, Nothing) + Just x -> return x - opts0 <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl - let opts - | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0 - | otherwise = opts0 + opts <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl -- Process the top-level module header documentation. (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader let declsWithDocs = topDecls group_ - exports0 = fmap (reverse . map unLoc) mayExports + exports0 = fmap (reverse . map (first unLoc)) mayExports exports | OptIgnoreExports `elem` opts = Nothing | otherwise = exports0 - warningMap = mkWarningMap dflags warnings gre exportedNames - localBundledPatSyns :: Map Name [Name] - localBundledPatSyns = - case exports of - Nothing -> M.empty - Just ies -> - M.map (nubByName id) $ - M.fromListWith (++) [ (ieWrappedName ty_name, bundled_patsyns) - | IEThingWith (L _ ty_name) _ exported _ <- ies - , let bundled_patsyns = - filter is_patsyn (map (ieWrappedName . unLoc) exported) - , not (null bundled_patsyns) - ] - where - is_patsyn name = elemNameSet name (mkNameSet (map getName patsyns)) + unrestrictedImportedMods + -- module re-exports are only possible with + -- explicit export list + | Just{} <- exports + = unrestrictedModuleImports (map unLoc imports) + | otherwise = M.empty fixMap = mkFixMap group_ (decls, _) = unzip declsWithDocs @@ -134,15 +127,18 @@ -- 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, !declMap, _) <- + liftErrMsg (mkMaps dflags gre localInsts declsWithDocs) + 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 is_sig modMap mdl sem_mdl allWarnings gre exportedNames decls - maps localBundledPatSyns fixMap splices exports instIfaceMap dflags + exportItems <- mkExportItems is_sig modMap mdl sem_mdl allWarnings gre + exportedNames decls maps fixMap unrestrictedImportedMods + splices exports all_exports instIfaceMap dflags let !visibleNames = mkVisibleNames maps exportItems opts @@ -161,10 +157,11 @@ let !aliases = mkAliasMap dflags $ tm_renamed_source tm - modWarn = moduleWarning dflags gre warnings - tokenizedSrc <- mkMaybeTokenizedSrc flags tm + modWarn <- liftErrMsg (moduleWarning dflags gre warnings) + tokenizedSrc <- mkMaybeTokenizedSrc dflags flags tm + return $! Interface { ifaceMod = mdl , ifaceIsSig = is_sig @@ -182,8 +179,6 @@ , ifaceExports = exportedNames , ifaceVisibleExports = visibleNames , ifaceDeclMap = declMap - , ifaceBundledPatSynMap = localBundledPatSyns - , ifaceSubMap = subMap , ifaceFixMap = fixMap , ifaceModuleAliases = aliases , ifaceInstances = instances @@ -229,6 +224,41 @@ alias)) impDecls +-- We want to know which modules are imported without any qualification. This +-- way we can display module reexports more compactly. This mapping also looks +-- through aliases: +-- +-- module M (module X) where +-- import M1 as X +-- import M2 as X +-- +-- With our mapping we know that we can display exported modules M1 and M2. +-- +unrestrictedModuleImports :: [ImportDecl name] -> M.Map ModuleName [ModuleName] +unrestrictedModuleImports idecls = + M.map (map (unLoc . ideclName)) + $ M.filter (all isInteresting) impModMap + where + impModMap = + M.fromListWith (++) (concatMap moduleMapping idecls) + + moduleMapping idecl = + concat [ [ (unLoc (ideclName idecl), [idecl]) ] + , [ (unLoc mod_name, [idecl]) + | Just mod_name <- [ideclAs idecl] + ] + ] + + isInteresting idecl = + case ideclHiding idecl of + -- i) no subset selected + Nothing -> True + -- ii) an import with a hiding clause + -- without any names + Just (True, L _ []) -> True + -- iii) any other case of qualification + _ -> False + -- Similar to GHC.lookupModule -- ezyang: Not really... lookupModuleDyn :: @@ -245,27 +275,29 @@ -- 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) ------------------------------------------------------------------------------- @@ -282,13 +314,17 @@ [] -> tell ["No option supplied to DOC_OPTION/doc_option"] >> return [] xs -> liftM catMaybes (mapM parseOption xs) Nothing -> return [] - hm <- if Flag_HideModule (moduleString mdl) `elem` flags - then return $ OptHide : opts - else return opts - if Flag_ShowExtensions (moduleString mdl) `elem` flags - then return $ OptShowExtensions : hm - else return hm + pure (foldl go opts flags) + where + mdlStr = moduleString mdl + -- Later flags override earlier ones + go os m | m == Flag_HideModule mdlStr = OptHide : os + | m == Flag_ShowModule mdlStr = filter (/= OptHide) os + | m == Flag_ShowAllModules = filter (/= OptHide) os + | m == Flag_IgnoreAllExports = OptIgnoreExports : os + | m == Flag_ShowExtensions mdlStr = OptIgnoreExports : os + | otherwise = os parseOption :: String -> ErrMsgM (Maybe DocOption) parseOption "hide" = return (Just OptHide) @@ -304,7 +340,7 @@ -------------------------------------------------------------------------------- -type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap, InstMap) +type Maps = (DocMap Name, ArgMap Name, DeclMap, InstMap) -- | Create 'Maps' by looping through the declarations. For each declaration, -- find its names, its subordinates, and its doc strings. Process doc strings @@ -312,17 +348,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 - ) + -> [(LHsDecl GhcRn, [HsDocString])] + -> ErrMsgM Maps +mkMaps dflags gre instances decls = do + (a, b, c) <- unzip3 <$> traverse mappings decls + pure ( f' (map (nubByName fst) a) + , f (filterMapping (not . M.null) b) + , f (filterMapping (not . null) c) + , instanceMap + ) where f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b f = M.fromListWith (<>) . concat @@ -333,41 +367,46 @@ filterMapping :: (b -> Bool) -> [[(a, b)]] -> [[(a, b)]] 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) = + mappings :: (LHsDecl GhcRn, [HsDocString]) + -> ErrMsgM ( [(Name, MDoc Name)] + , [(Name, Map Int (MDoc Name))] + , [(Name, [LHsDecl GhcRn])] + ) + 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, cm) + instanceMap :: Map SrcSpan Name instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ] - names :: SrcSpan -> HsDecl Name -> [Name] + names :: SrcSpan -> HsDecl GhcRn -> [Name] names l (InstD d) = maybeToList (M.lookup loc instanceMap) -- See note [2]. where loc = case d of TyFamInstD _ -> l -- The CoAx's loc is the whole line, but only for TFs @@ -392,15 +431,17 @@ -- A subordinate declaration is something like the associate type or data -- family of a type class. subordinates :: InstMap - -> HsDecl Name + -> HsDecl GhcRn -> [(Name, [HsDocString], Map Int HsDocString)] subordinates instMap decl = case decl of InstD (ClsInstD d) -> do - DataFamInstDecl { dfid_tycon = L l _ - , dfid_defn = def } <- unLoc <$> cid_datafam_insts d - [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs def + DataFamInstDecl { dfid_eqn = HsIB { hsib_body = + FamEqn { feqn_tycon = L l _ + , feqn_rhs = defn }}} <- unLoc <$> cid_datafam_insts d + [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn - InstD (DataFamInstD d) -> dataSubs (dfid_defn d) + InstD (DataFamInstD (DataFamInstDecl (HsIB { hsib_body = d }))) + -> dataSubs (feqn_rhs d) TyClD d | isClassDecl d -> classSubs d | isDataDecl d -> dataSubs (tcdDataDefn d) _ -> [] @@ -408,7 +449,7 @@ classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd , name <- getMainDeclBinder d, not (isValD d) ] - dataSubs :: HsDataDefn Name -> [(Name, [HsDocString], Map Int HsDocString)] + dataSubs :: HsDataDefn GhcRn -> [(Name, [HsDocString], Map Int HsDocString)] dataSubs dd = constrs ++ fields ++ derivs where cons = map unL $ (dd_cons dd) @@ -425,7 +466,7 @@ , Just instName <- [M.lookup l instMap] ] -- | Extract function argument docs from inside types. -typeDocs :: HsDecl Name -> Map Int HsDocString +typeDocs :: HsDecl GhcRn -> Map Int HsDocString typeDocs d = let docs = go 0 in case d of @@ -446,7 +487,7 @@ -- | All the sub declarations of a class (that we handle), ordered by -- source location, with documentation attached if it exists. -classDecls :: TyClDecl Name -> [(LHsDecl Name, [HsDocString])] +classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])] classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls where decls = docs ++ defs ++ sigs ++ ats @@ -458,18 +499,19 @@ -- | The top-level declarations of a module that we care about, -- ordered by source location, with documentation attached if it exists. -topDecls :: HsGroup Name -> [(LHsDecl Name, [HsDocString])] -topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup +topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])] +topDecls = + filterClasses . filterDecls . collectDocs . sortByLoc . ungroup -- | Extract a map of fixity declarations only -mkFixMap :: HsGroup Name -> FixMap +mkFixMap :: HsGroup GhcRn -> FixMap mkFixMap group_ = M.fromList [ (n,f) | L _ (FixitySig ns f) <- hs_fixds group_, L _ n <- ns ] -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. -ungroup :: HsGroup Name -> [LHsDecl Name] +ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn] ungroup group_ = mkDecls (tyClGroupTyClDecls . hs_tyclds) TyClD group_ ++ mkDecls hs_derivds DerivD group_ ++ @@ -519,7 +561,6 @@ isHandled (DocD _) = True isHandled _ = False - -- | Go through all class declarations and filter their sub-declarations filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x @@ -569,53 +610,78 @@ -> WarningMap -> GlobalRdrEnv -> [Name] -- exported names (orig) - -> [LHsDecl Name] -- renamed source declarations + -> [LHsDecl GhcRn] -- renamed source declarations -> Maps - -> Map Name [Name] -> FixMap + -> M.Map ModuleName [ModuleName] -> [SrcSpan] -- splice locations - -> Maybe [IE Name] + -> Maybe [(IE GhcRn, Avails)] + -> Avails -- exported stuff from this module -> InstIfaceMap -> DynFlags - -> ErrMsgGhc [ExportItem Name] + -> ErrMsgGhc [ExportItem GhcRn] mkExportItems is_sig modMap thisMod semMod warnings gre exportedNames decls - maps@(docMap, argMap, subMap, declMap, instMap) patSynMap fixMap splices optExports instIfaceMap dflags = - case optExports of - Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls + maps fixMap unrestricted_imp_mods splices exportList allExports + instIfaceMap dflags = + case exportList of + Nothing -> + fullModuleContents is_sig modMap thisMod semMod warnings gre + exportedNames decls maps fixMap splices instIfaceMap dflags + allExports Just exports -> liftM concat $ mapM lookupExport exports where - lookupExport (IEVar (L _ x)) = declWith [] $ ieWrappedName x - lookupExport (IEThingAbs (L _ t)) = declWith [] $ ieWrappedName t - lookupExport (IEThingAll (L _ t)) = do - let name = ieWrappedName t - pats <- findBundledPatterns name - declWith pats name - lookupExport (IEThingWith (L _ t) _ _ _) = do - let name = ieWrappedName t - pats <- findBundledPatterns name - declWith pats name - lookupExport (IEModuleContents (L _ m)) = - -- 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 + 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 + lookupExport (IEDocNamed str, _) = liftErrMsg $ + 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 - r <- findDecl t + lookupExport (IEModuleContents (L _ mod_name), _) + -- only consider exporting a module if we are sure we + -- are really exporting the whole module and not some + -- subset. We also look through module aliases here. + | Just mods <- M.lookup mod_name unrestricted_imp_mods + , not (null mods) + = concat <$> traverse (moduleExport thisMod dflags modMap instIfaceMap) mods + + lookupExport (_, avails) = + concat <$> traverse availExport (nubAvails avails) + + availExport avail = + availExportItem is_sig modMap thisMod semMod warnings exportedNames + maps fixMap splices instIfaceMap dflags avail + +availExportItem :: Bool -- is it a signature + -> IfaceMap + -> Module -- this module + -> Module -- semantic module + -> WarningMap + -> [Name] -- exported names (orig) + -> Maps + -> FixMap + -> [SrcSpan] -- splice locations + -> InstIfaceMap + -> DynFlags + -> AvailInfo + -> ErrMsgGhc [ExportItem GhcRn] +availExportItem is_sig modMap thisMod semMod warnings exportedNames + (docMap, argMap, declMap, _) fixMap splices instIfaceMap + dflags availInfo = declWith availInfo + where + declWith :: AvailInfo -> ErrMsgGhc [ ExportItem GhcRn ] + declWith avail = do + let t = availName avail + r <- findDecl avail case r of ([L l (ValD _)], (doc, _)) -> do -- Top-level binding without type signature @@ -625,11 +691,6 @@ let declNames = getMainDeclBinder (unL decl) in case () of _ - -- TODO: temp hack: we filter out separately exported ATs, since we haven't decided how - -- to handle them yet. We should really give an warning message also, and filter the - -- name out in mkVisibleNames... - | t `elem` declATs (unL decl) -> return [] - -- We should not show a subordinate by itself if any of its -- parents is also exported. See note [1]. | t `notElem` declNames, @@ -651,15 +712,15 @@ -- fromJust is safe since we already checked in guards -- that 't' is a name declared in this declaration. let newDecl = L loc . SigD . fromJust $ filterSigNames (== t) sig - in return [ mkExportDecl t newDecl pats docs_ ] + in availExportDecl avail newDecl docs_ L loc (TyClD cl@ClassDecl{}) -> do mdef <- liftGhcToErrMsgGhc $ minimalDef t let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef - return [ mkExportDecl t - (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) pats docs_ ] + availExportDecl avail + (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ - _ -> return [ mkExportDecl t decl pats docs_ ] + _ -> availExportDecl avail decl docs_ -- Declaration from another package ([], _) -> do @@ -675,34 +736,65 @@ Nothing -> do liftErrMsg $ tell ["Warning: Couldn't find .haddock for export " ++ pretty dflags t] - let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates instMap (unLoc decl) ] - return [ mkExportDecl t decl pats (noDocForDecl, subs_) ] + let subs_ = availNoDocs avail + availExportDecl avail decl (noDocForDecl, subs_) Just iface -> - return [ mkExportDecl t decl pats (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] + availExportDecl avail decl (lookupDocs avail warnings (instDocMap iface) (instArgMap iface)) _ -> return [] + availExportDecl :: AvailInfo -> LHsDecl GhcRn + -> (DocForDecl Name, [(Name, DocForDecl Name)]) + -> ErrMsgGhc [ ExportItem GhcRn ] + availExportDecl avail decl (doc, subs) + | availExportsDecl avail = do + -- bundled pattern synonyms only make sense if the declaration is + -- exported (otherwise there would be nothing to bundle to) + bundledPatSyns <- findBundledPatterns avail - mkExportDecl :: Name -> LHsDecl Name -> [(HsDecl Name, DocForDecl Name)] - -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name - mkExportDecl name decl pats (doc, subs) = decl' - where - decl' = ExportDecl (restrictTo sub_names (extractDecl name decl)) pats' doc subs' [] fixities False - subs' = filter (isExported . fst) subs - pats' = [ d | d@(patsyn_decl, _) <- pats - , all isExported (getMainDeclBinder patsyn_decl) ] - sub_names = map fst subs' - pat_names = [ n | (patsyn_decl, _) <- pats', n <- getMainDeclBinder patsyn_decl] - fixities = [ (n, f) | n <- name:sub_names++pat_names, Just f <- [M.lookup n fixMap] ] + let + patSynNames = + concatMap (getMainDeclBinder . fst) bundledPatSyns + fixities = + [ (n, f) + | n <- availName avail : fmap fst subs ++ patSynNames + , Just f <- [M.lookup n fixMap] + ] + + return [ ExportDecl { + expItemDecl = restrictTo (fmap fst subs) + (extractDecl declMap (availName avail) decl) + , expItemPats = bundledPatSyns + , expItemMbDoc = doc + , expItemSubDocs = subs + , expItemInstances = [] + , expItemFixities = fixities + , expItemSpliced = False + } + ] + + | otherwise = + return [ ExportDecl { + expItemDecl = extractDecl declMap sub decl + , expItemPats = [] + , expItemMbDoc = sub_doc + , expItemSubDocs = [] + , expItemInstances = [] + , expItemFixities = [ (sub, f) | Just f <- [M.lookup sub fixMap] ] + , expItemSpliced = False + } + | (sub, sub_doc) <- subs + ] + exportedNameSet = mkNameSet exportedNames isExported n = elemNameSet n exportedNameSet - findDecl :: Name -> ErrMsgGhc ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)])) - findDecl n + findDecl :: AvailInfo -> ErrMsgGhc ([LHsDecl GhcRn], (DocForDecl Name, [(Name, DocForDecl Name)])) + findDecl avail | m == semMod = case M.lookup n declMap of - Just ds -> return (ds, lookupDocs n warnings docMap argMap subMap) + Just ds -> return (ds, lookupDocs avail warnings docMap argMap) Nothing | is_sig -> do -- OK, so it wasn't in the local declaration map. It could @@ -710,57 +802,57 @@ -- from the type. mb_r <- hiDecl dflags n case mb_r of - Nothing -> return ([], (noDocForDecl, [])) + Nothing -> return ([], (noDocForDecl, availNoDocs avail)) -- 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, [])) + Just decl -> return ([decl], (noDocForDecl, availNoDocs avail)) | otherwise -> - return ([], (noDocForDecl, [])) + return ([], (noDocForDecl, availNoDocs avail)) | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap , Just ds <- M.lookup n (ifaceDeclMap iface) = - return (ds, lookupDocs n warnings + return (ds, lookupDocs avail warnings (ifaceDocMap iface) - (ifaceArgMap iface) - (ifaceSubMap iface)) - | otherwise = return ([], (noDocForDecl, [])) + (ifaceArgMap iface)) + | otherwise = return ([], (noDocForDecl, availNoDocs avail)) where + n = availName avail m = nameModule n - findBundledPatterns :: Name -> ErrMsgGhc [(HsDecl Name, DocForDecl Name)] - findBundledPatterns t = - let - m = nameModule t - - local_bundled_patsyns = - M.findWithDefault [] t patSynMap - - iface_bundled_patsyns - | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap - , Just patsyns <- M.lookup t (ifaceBundledPatSynMap iface) - = patsyns - - | Just iface <- M.lookup m instIfaceMap - , Just patsyns <- M.lookup t (instBundledPatSynMap iface) - = patsyns - - | otherwise - = [] - - patsyn_decls = do - for (local_bundled_patsyns ++ iface_bundled_patsyns) $ \patsyn_name -> do - -- call declWith here so we don't have to prepare the pattern synonym for - -- showing ourselves. - export_items <- declWith [] patsyn_name + findBundledPatterns :: AvailInfo -> ErrMsgGhc [(HsDecl GhcRn, DocForDecl Name)] + findBundledPatterns avail = do + patsyns <- for constructor_names $ \name -> do + mtyThing <- liftGhcToErrMsgGhc (lookupName name) + case mtyThing of + Just (AConLike PatSynCon{}) -> do + export_items <- declWith (Avail.avail name) pure [ (unLoc patsyn_decl, patsyn_doc) | ExportDecl { expItemDecl = patsyn_decl , expItemMbDoc = patsyn_doc } <- export_items ] + _ -> pure [] + pure (concat patsyns) + where + constructor_names = + filter isDataConName (availSubordinates avail) - in concat <$> patsyn_decls +-- this heavily depends on the invariants stated in Avail +availExportsDecl :: AvailInfo -> Bool +availExportsDecl (AvailTC ty_name names _) + | n : _ <- names = ty_name == n + | otherwise = False +availExportsDecl _ = True +availSubordinates :: AvailInfo -> [Name] +availSubordinates avail = + filter (/= availName avail) (availNamesWithSelectors avail) + +availNoDocs :: AvailInfo -> [(Name, DocForDecl Name)] +availNoDocs avail = + zip (availSubordinates avail) (repeat noDocForDecl) + -- | Given a 'Module' from a 'Name', convert it into a 'Module' that -- we can actually find in the 'IfaceMap'. semToIdMod :: UnitId -> Module -> Module @@ -768,7 +860,7 @@ | Module.isHoleModule m = mkModule this_uid (moduleName m) | otherwise = m -hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl Name)) +hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl GhcRn)) hiDecl dflags t = do mayTyThing <- liftGhcToErrMsgGhc $ lookupName t case mayTyThing of @@ -790,7 +882,7 @@ -- have a meaningful 'SrcSpan'. So we pass down 'SrcSpan' for the -- declaration and use it instead - 'nLoc' here. hiValExportItem :: DynFlags -> Name -> SrcSpan -> DocForDecl Name -> Bool - -> Maybe Fixity -> ErrMsgGhc (ExportItem Name) + -> Maybe Fixity -> ErrMsgGhc (ExportItem GhcRn) hiValExportItem dflags name nLoc doc splice fixity = do mayDecl <- hiDecl dflags name case mayDecl of @@ -804,48 +896,29 @@ -- | Lookup docs for a declaration from maps. -lookupDocs :: Name -> WarningMap -> DocMap Name -> ArgMap Name -> SubMap +lookupDocs :: AvailInfo -> WarningMap -> DocMap Name -> ArgMap Name -> (DocForDecl Name, [(Name, DocForDecl Name)]) -lookupDocs n warnings docMap argMap subMap = +lookupDocs avail warnings docMap argMap = + let n = availName avail in let lookupArgDoc x = M.findWithDefault M.empty x argMap in let doc = (lookupDoc n, lookupArgDoc n) in - let subs = M.findWithDefault [] n subMap in - let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) | s <- subs ] in + let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) + | s <- availSubordinates avail + ] in (doc, subDocs) where lookupDoc name = Documentation (M.lookup name docMap) (M.lookup name warnings) --- | Return all export items produced by an exported module. That is, we're --- interested in the exports produced by \"module B\" in such a scenario: --- --- > module A (module B) where --- > import B (...) hiding (...) --- --- There are three different cases to consider: --- --- 1) B is hidden, in which case we return all its exports that are in scope in A. --- 2) B is visible, but not all its exports are in scope in A, in which case we --- 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 (identity, NOT semantic) - -> ModuleName -- ^ The real name of B, the exported module - -> DynFlags -- ^ The flags used when typechecking A - -> WarningMap - -> GlobalRdrEnv -- ^ The renaming environment used for A - -> [Name] -- ^ All the exports of A - -> [LHsDecl Name] -- ^ All the renamed declarations in A - -> IfaceMap -- ^ Already created interfaces - -> InstIfaceMap -- ^ Interfaces in other packages - -> Maps - -> FixMap - -> [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 - | expMod == moduleName thisMod - = fullModuleContents dflags warnings gre maps fixMap splices decls - | otherwise = +-- | Export the given module as `ExportModule`. We are not concerned with the +-- single export items of the given module. +moduleExport :: Module -- ^ Module A (identity, NOT semantic) + -> DynFlags -- ^ The flags used when typechecking A + -> IfaceMap -- ^ Already created interfaces + -> InstIfaceMap -- ^ Interfaces in other packages + -> ModuleName -- ^ The exported module + -> ErrMsgGhc [ExportItem GhcRn] -- ^ Resulting export items +moduleExport thisMod dflags ifaceMap instIfaceMap expMod = -- NB: we constructed the identity module when looking up in -- the IfaceMap. case M.lookup m ifaceMap of @@ -866,7 +939,6 @@ m = mkModule unitId expMod -- Identity module! unitId = moduleUnitId thisMod - -- Note [1]: ------------ -- It is unnecessary to document a subordinate by itself at the top level if @@ -887,124 +959,149 @@ -- | 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 + +fullModuleContents :: Bool -- is it a signature + -> IfaceMap + -> Module -- this module + -> Module -- semantic module -> WarningMap -> GlobalRdrEnv -- ^ The renaming environment + -> [Name] -- exported names (orig) + -> [LHsDecl GhcRn] -- renamed source declarations -> 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 (expandSigDecls decls) + -> [SrcSpan] -- splice locations + -> InstIfaceMap + -> DynFlags + -> Avails + -> ErrMsgGhc [ExportItem GhcRn] +fullModuleContents is_sig modMap thisMod semMod warnings gre exportedNames + decls maps@(_, _, declMap, _) fixMap splices instIfaceMap dflags avails = do + let availEnv = availsToNameEnv (nubAvails avails) + (concat . concat) `fmap` (for decls $ \decl -> do + case decl of + (L _ (DocD (DocGroup lev docStr))) -> do + doc <- liftErrMsg (processDocString dflags gre docStr) + return [[ExportGroup lev "" doc]] + (L _ (DocD (DocCommentNamed _ docStr))) -> do + doc <- liftErrMsg (processDocStringParas dflags gre docStr) + return [[ExportDoc doc]] + (L _ (ValD valDecl)) + | name:_ <- collectHsBindBinders valDecl + , Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap + -> return [] + _ -> + for (getMainDeclBinder (unLoc decl)) $ \nm -> do + case lookupNameEnv availEnv nm of + Just avail -> + availExportItem is_sig modMap thisMod + semMod warnings exportedNames maps fixMap + splices instIfaceMap dflags avail + Nothing -> pure []) 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! - expandSigDecls :: [LHsDecl name] -> [LHsDecl name] - expandSigDecls = concatMap f - where - 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 (PatSynSig names t) = [ PatSynSig [n] t | n <- names ] - expandSig x = [x] - - mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name)) - mkExportItem (L _ (DocD (DocGroup lev docStr))) = do - return . Just . ExportGroup lev "" $ processDocString dflags gre docStr - mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do - return . Just . ExportDoc $ processDocStringParas dflags gre docStr - mkExportItem (L l (ValD d)) - | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap = - -- Top-level binding without type signature. - let (doc, _) = lookupDocs name warnings docMap argMap subMap in - fmap Just (hiValExportItem dflags name l doc (l `elem` splices) $ M.lookup name fixMap) - | otherwise = return Nothing - mkExportItem decl@(L l (InstD d)) - | Just name <- M.lookup (getInstLoc d) instMap = - expInst decl l name - mkExportItem decl@(L l (DerivD {})) - | Just name <- M.lookup l instMap = - expInst decl l name - mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do - mdef <- liftGhcToErrMsgGhc $ minimalDef name - let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef - expDecl (L l (TyClD cl { tcdSigs = sig ++ sigs })) l name - mkExportItem decl@(L l d) - | name:_ <- getMainDeclBinder d = expDecl decl l name - | otherwise = return Nothing - - fixities name subs = [ (n,f) | n <- name : map fst subs - , Just f <- [M.lookup n fixMap] ] - - expDecl decl l name = return $ Just (ExportDecl decl [] doc subs [] (fixities name subs) (l `elem` splices)) - where (doc, subs) = lookupDocs name warnings docMap argMap subMap - - expInst decl l name = - let (doc, subs) = lookupDocs name warnings docMap argMap subMap in - return $ Just (ExportDecl decl [] doc subs [] (fixities name subs) (l `elem` splices)) - + isSigD (L _ SigD{}) = True + isSigD _ = False -- | Sometimes the declaration we want to export is not the "main" declaration: -- it might be an individual record selector or a class method. In these -- cases we have to extract the required declaration (and somehow cobble -- together a type signature for it...). -extractDecl :: Name -> LHsDecl Name -> LHsDecl Name -extractDecl name decl +extractDecl :: DeclMap -> Name -> LHsDecl GhcRn -> LHsDecl GhcRn +extractDecl declMap name decl | name `elem` getMainDeclBinder (unLoc decl) = decl | otherwise = case unLoc decl of TyClD d@ClassDecl {} -> - let matches = [ lsig - | lsig <- tcdSigs d - , ClassOpSig False _ _ <- pure $ unLoc lsig - -- Note: exclude `default` declarations (see #505) - , name `elem` sigName lsig - ] + let + matchesMethod = + [ lsig + | lsig <- tcdSigs d + , ClassOpSig False _ _ <- pure $ unLoc lsig + -- Note: exclude `default` declarations (see #505) + , name `elem` sigName lsig + ] + + matchesAssociatedType = + [ lfam_decl + | lfam_decl <- tcdATs d + , name == unLoc (fdLName (unLoc lfam_decl)) + ] + -- TODO: document fixity - in case matches of - [s0] -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d) - L pos sig = addClassContext n tyvar_names s0 - in L pos (SigD sig) + in case (matchesMethod, matchesAssociatedType) of + ([s0], _) -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d) + L pos sig = addClassContext n tyvar_names s0 + in L pos (SigD sig) + (_, [L pos fam_decl]) -> L pos (TyClD (FamDecl fam_decl)) + + ([], []) + | Just (famInstDecl:_) <- M.lookup name declMap + -> extractDecl declMap name famInstDecl _ -> O.pprPanic "extractDecl" (O.text "Ambiguous decl for" O.<+> O.ppr name O.<+> O.text "in class:" O.$$ O.nest 4 (O.ppr d) O.$$ O.text "Matches:" - O.$$ O.nest 4 (O.ppr matches)) + O.$$ O.nest 4 (O.ppr matchesMethod O.<+> O.ppr matchesAssociatedType)) TyClD d@DataDecl {} -> let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars 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 }) -> + 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)) + TyClD FamDecl {} + | isValName name + , Just (famInst:_) <- M.lookup name declMap + -> extractDecl declMap name famInst + InstD (DataFamInstD (DataFamInstDecl (HsIB { hsib_body = + FamEqn { feqn_tycon = L _ n + , feqn_pats = tys + , feqn_rhs = 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) - , RecCon rec <- map (getConDetails . unLoc) (dd_cons (dfid_defn d)) - , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) - , L _ n <- ns - , selectorFieldOcc n == name + let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d })) + <- insts + -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d) + , RecCon rec <- map (getConDetails . unLoc) (dd_cons (feqn_rhs d)) + , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) + , L _ n <- ns + , selectorFieldOcc n == name ] in case matches of - [d0] -> extractDecl name (noLoc . InstD $ DataFamInstD d0) + [d0] -> extractDecl declMap name (noLoc . InstD $ DataFamInstD d0) _ -> error "internal: extractDecl (ClsInstD)" _ -> error "internal: extractDecl" -extractRecSel :: Name -> Name -> [LHsType Name] -> [LConDecl Name] - -> LSig Name + +extractPatternSyn :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn +extractPatternSyn nm t tvs cons = + case filter matches cons of + [] -> error "extractPatternSyn: constructor pattern not found" + con:_ -> extract <$> con + where + matches :: LConDecl GhcRn -> Bool + matches (L _ con) = nm `elem` (unLoc <$> getConNames con) + extract :: ConDecl GhcRn -> Sig GhcRn + 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 GhcRn] -> [LConDecl GhcRn] + -> LSig GhcRn extractRecSel _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm t tvs (L _ con : rest) = @@ -1013,7 +1110,7 @@ L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty))))) _ -> extractRecSel nm t tvs rest where - matching_fields :: [LConDeclField Name] -> [(SrcSpan, LConDeclField Name)] + matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)] matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds , L l n <- ns, selectorFieldOcc n == nm ] data_ty @@ -1022,15 +1119,15 @@ | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs -- | Keep export items with docs. -pruneExportItems :: [ExportItem Name] -> [ExportItem Name] +pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn] pruneExportItems = filter hasDoc where hasDoc (ExportDecl{expItemMbDoc = (Documentation d _, _)}) = isJust d hasDoc _ = True -mkVisibleNames :: Maps -> [ExportItem Name] -> [DocOption] -> [Name] -mkVisibleNames (_, _, _, _, instMap) exports opts +mkVisibleNames :: Maps -> [ExportItem GhcRn] -> [DocOption] -> [Name] +mkVisibleNames (_, _, _, instMap) exports opts | OptHide `elem` opts = [] | otherwise = let ns = concatMap exportName exports in seqList ns `seq` ns @@ -1049,12 +1146,12 @@ seqList [] = () seqList (x : xs) = x `seq` seqList xs -mkMaybeTokenizedSrc :: [Flag] -> TypecheckedModule +mkMaybeTokenizedSrc :: DynFlags -> [Flag] -> TypecheckedModule -> ErrMsgGhc (Maybe [RichToken]) -mkMaybeTokenizedSrc flags tm +mkMaybeTokenizedSrc dflags flags tm | Flag_HyperlinkedSource `elem` flags = case renamedSource tm of Just src -> do - tokens <- liftGhcToErrMsgGhc . liftIO $ mkTokenizedSrc summary src + tokens <- liftGhcToErrMsgGhc (liftIO (mkTokenizedSrc dflags summary src)) return $ Just tokens Nothing -> do liftErrMsg . tell . pure $ concat @@ -1067,15 +1164,18 @@ where summary = pm_mod_summary . tm_parsed_module $ tm -mkTokenizedSrc :: ModSummary -> RenamedSource -> IO [RichToken] -mkTokenizedSrc ms src = do +mkTokenizedSrc :: DynFlags -> ModSummary -> RenamedSource -> IO [RichToken] +mkTokenizedSrc dflags 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)) + let tokens = Hyperlinker.parse dflags filepath (Utf8.decodeUtf8 rawSrc) + return $ Hyperlinker.enrich src tokens + where + filepath = msHsFilePath ms -- | Find a stand-alone documentation comment by its name. -findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString) +findNamedDoc :: String -> [HsDecl GhcRn] -> ErrMsgM (Maybe HsDocString) findNamedDoc name = search where search [] = do diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs new file mode 100644 --- /dev/null +++ b/haddock-api/src/Haddock/Interface/Json.hs @@ -0,0 +1,106 @@ +{-# 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)) + , ("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/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -18,7 +18,6 @@ , processModuleHeader ) where -import Data.IntSet (toList) import Data.List import Documentation.Haddock.Doc (metaDocConcat) import DynFlags (languageExtensions) @@ -31,23 +30,25 @@ import Name import Outputable ( showPpr ) import RdrName +import EnumSet 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,14 +61,16 @@ 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] -- We remove the flags implied by the language setting and we display the language instead - flags = map toEnum (toList $ extensionFlags dflags) \\ languageExtensions (language dflags) + flags = EnumSet.toList (extensionFlags dflags) \\ languageExtensions (language dflags) return (hmi { hmi_safety = Just $ showPpr dflags safety , hmi_language = language dflags , hmi_extensions = flags @@ -82,12 +85,12 @@ -- 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 @@ -- 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,38 @@ -- 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 + DocTable t -> DocTable <$> traverse 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-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs --- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs +++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs @@ -37,21 +37,22 @@ (copyrightOpt,str3) = getKey "Copyright" str2 (licenseOpt,str4) = getKey "License" str3 (licenceOpt,str5) = getKey "Licence" str4 - (maintainerOpt,str6) = getKey "Maintainer" str5 - (stabilityOpt,str7) = getKey "Stability" str6 - (portabilityOpt,str8) = getKey "Portability" str7 + (spdxLicenceOpt,str6) = getKey "SPDX-License-Identifier" str5 + (maintainerOpt,str7) = getKey "Maintainer" str6 + (stabilityOpt,str8) = getKey "Stability" str7 + (portabilityOpt,str9) = getKey "Portability" str8 in (HaddockModInfo { hmi_description = parseString dflags <$> descriptionOpt, hmi_copyright = copyrightOpt, - hmi_license = licenseOpt `mplus` licenceOpt, + hmi_license = spdxLicenceOpt `mplus` licenseOpt `mplus` licenceOpt, hmi_maintainer = maintainerOpt, hmi_stability = stabilityOpt, hmi_portability = portabilityOpt, hmi_safety = Nothing, hmi_language = Nothing, -- set in LexParseRn hmi_extensions = [] -- also set in LexParseRn - }, parseParas dflags str8) + }, parseParas dflags str9) -- | This function is how we read keys. -- diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -21,6 +21,8 @@ import Bag (emptyBag) import GHC hiding (NoLink) import Name +import RdrName (RdrName(Exact)) +import PrelNames (eqTyCon_RDR) import Control.Applicative import Control.Monad hiding (mapM) @@ -59,11 +61,18 @@ (missingNames1 ++ missingNames2 ++ missingNames3 ++ missingNames4 ++ missingNames5) - -- filter out certain built in type constructors using their string - -- representation. TODO: use the Name constants from the GHC API. --- strings = filter (`notElem` ["()", "[]", "(->)"]) --- (map pretty missingNames) - strings = map (pretty dflags) . filter (\n -> not (isSystemName n || isBuiltInSyntax n)) $ missingNames + -- Filter out certain built in type constructors using their string + -- representation. + -- + -- Note that since the renamed AST represents equality constraints as + -- @HasOpTy t1 eqTyCon_RDR t2@ (and _not_ as @HsEqTy t1 t2@), we need to + -- manually filter out 'eqTyCon_RDR' (aka @~@). + strings = [ pretty dflags n + | n <- missingNames + , not (isSystemName n) + , not (isBuiltInSyntax n) + , Exact n /= eqTyCon_RDR + ] in do -- report things that we couldn't link to. Only do this for non-hidden @@ -147,7 +156,7 @@ renameL = mapM rename -renameExportItems :: [ExportItem Name] -> RnM [ExportItem DocName] +renameExportItems :: [ExportItem GhcRn] -> RnM [ExportItem DocNameI] renameExportItems = mapM renameExportItem @@ -172,22 +181,22 @@ renameFnArgsDoc = mapM renameDoc -renameLType :: LHsType Name -> RnM (LHsType DocName) +renameLType :: LHsType GhcRn -> RnM (LHsType DocNameI) renameLType = mapM renameType -renameLSigType :: LHsSigType Name -> RnM (LHsSigType DocName) +renameLSigType :: LHsSigType GhcRn -> RnM (LHsSigType DocNameI) renameLSigType = renameImplicit renameLType -renameLSigWcType :: LHsSigWcType Name -> RnM (LHsSigWcType DocName) +renameLSigWcType :: LHsSigWcType GhcRn -> RnM (LHsSigWcType DocNameI) renameLSigWcType = renameWc (renameImplicit renameLType) -renameLKind :: LHsKind Name -> RnM (LHsKind DocName) +renameLKind :: LHsKind GhcRn -> RnM (LHsKind DocNameI) renameLKind = renameLType -renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName)) +renameMaybeLKind :: Maybe (LHsKind GhcRn) -> RnM (Maybe (LHsKind DocNameI)) renameMaybeLKind = traverse renameLKind -renameFamilyResultSig :: LFamilyResultSig Name -> RnM (LFamilyResultSig DocName) +renameFamilyResultSig :: LFamilyResultSig GhcRn -> RnM (LFamilyResultSig DocNameI) renameFamilyResultSig (L loc NoSig) = return (L loc NoSig) renameFamilyResultSig (L loc (KindSig ki)) @@ -197,17 +206,17 @@ = do { bndr' <- renameLTyVarBndr bndr ; return (L loc (TyVarSig bndr')) } -renameInjectivityAnn :: LInjectivityAnn Name -> RnM (LInjectivityAnn DocName) +renameInjectivityAnn :: LInjectivityAnn GhcRn -> RnM (LInjectivityAnn DocNameI) renameInjectivityAnn (L loc (InjectivityAnn lhs rhs)) = do { lhs' <- renameL lhs ; rhs' <- mapM renameL rhs ; return (L loc (InjectivityAnn lhs' rhs')) } -renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn Name) - -> RnM (Maybe (LInjectivityAnn DocName)) +renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn GhcRn) + -> RnM (Maybe (LInjectivityAnn DocNameI)) renameMaybeInjectivityAnn = traverse renameInjectivityAnn -renameType :: HsType Name -> RnM (HsType DocName) +renameType :: HsType GhcRn -> RnM (HsType DocNameI) renameType t = case t of HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do tyvars' <- mapM renameLTyVarBndr tyvars @@ -264,17 +273,28 @@ HsCoreTy a -> pure (HsCoreTy a) HsExplicitListTy i a b -> HsExplicitListTy i a <$> mapM renameLType b HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b - HsSpliceTy _ _ -> error "renameType: HsSpliceTy" + HsSpliceTy s _ -> renameHsSpliceTy s HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a HsAppsTy _ -> error "renameType: HsAppsTy" -renameLHsQTyVars :: LHsQTyVars Name -> RnM (LHsQTyVars DocName) +-- | Rename splices, but _only_ those that turn out to be for types. +-- I think this is actually safe for our possible inputs: +-- +-- * the input is from after GHC's renamer, so should have an 'HsSpliced' +-- * the input is typechecked, and only 'HsSplicedTy' should get through that +-- +renameHsSpliceTy :: HsSplice GhcRn -> RnM (HsType DocNameI) +renameHsSpliceTy (HsSpliced _ (HsSplicedTy t)) = renameType t +renameHsSpliceTy (HsSpliced _ _) = error "renameHsSpliceTy: not an HsSplicedTy" +renameHsSpliceTy _ = error "renameHsSpliceTy: not an HsSpliced" + +renameLHsQTyVars :: LHsQTyVars GhcRn -> RnM (LHsQTyVars DocNameI) renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs }) = do { tvs' <- mapM renameLTyVarBndr tvs ; return (HsQTvs { hsq_implicit = error "haddock:renameLHsQTyVars", hsq_explicit = tvs', hsq_dependent = error "haddock:renameLHsQTyVars" }) } -- This is rather bogus, but I'm not sure what else to do -renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName) +renameLTyVarBndr :: LHsTyVarBndr GhcRn -> RnM (LHsTyVarBndr DocNameI) renameLTyVarBndr (L loc (UserTyVar (L l n))) = do { n' <- rename n ; return (L loc (UserTyVar (L l n'))) } @@ -283,18 +303,17 @@ ; kind' <- renameLKind kind ; return (L loc (KindedTyVar (L lv n') kind')) } -renameLContext :: Located [LHsType Name] -> RnM (Located [LHsType DocName]) +renameLContext :: Located [LHsType GhcRn] -> RnM (Located [LHsType DocNameI]) renameLContext (L loc context) = do context' <- mapM renameLType context return (L loc context') -renameWildCardInfo :: HsWildCardInfo Name -> RnM (HsWildCardInfo DocName) +renameWildCardInfo :: HsWildCardInfo GhcRn -> RnM (HsWildCardInfo DocNameI) renameWildCardInfo (AnonWildCard (L l name)) = AnonWildCard . L l <$> rename name -renameInstHead :: InstHead Name -> RnM (InstHead DocName) +renameInstHead :: InstHead GhcRn -> RnM (InstHead DocNameI) renameInstHead InstHead {..} = do cname <- rename ihdClsName - kinds <- mapM renameType ihdKinds types <- mapM renameType ihdTypes itype <- case ihdInstType of ClassInst { .. } -> ClassInst @@ -306,21 +325,20 @@ DataInst dd -> DataInst <$> renameTyClD dd return InstHead { ihdClsName = cname - , ihdKinds = kinds , ihdTypes = types , ihdInstType = itype } -renameLDecl :: LHsDecl Name -> RnM (LHsDecl DocName) +renameLDecl :: LHsDecl GhcRn -> RnM (LHsDecl DocNameI) renameLDecl (L loc d) = return . L loc =<< renameDecl d -renamePats :: [(HsDecl Name,DocForDecl Name)] -> RnM [(HsDecl DocName,DocForDecl DocName)] +renamePats :: [(HsDecl GhcRn, DocForDecl Name)] -> RnM [(HsDecl DocNameI, DocForDecl DocName)] renamePats = mapM (\(d,doc) -> do { d' <- renameDecl d ; doc' <- renameDocForDecl doc ; return (d',doc')}) -renameDecl :: HsDecl Name -> RnM (HsDecl DocName) +renameDecl :: HsDecl GhcRn -> RnM (HsDecl DocNameI) renameDecl decl = case decl of TyClD d -> do d' <- renameTyClD d @@ -339,10 +357,10 @@ return (DerivD d') _ -> error "renameDecl" -renameLThing :: (a Name -> RnM (a DocName)) -> Located (a Name) -> RnM (Located (a DocName)) +renameLThing :: (a GhcRn -> RnM (a DocNameI)) -> Located (a GhcRn) -> RnM (Located (a DocNameI)) renameLThing fn (L loc x) = return . L loc =<< fn x -renameTyClD :: TyClDecl Name -> RnM (TyClDecl DocName) +renameTyClD :: TyClDecl GhcRn -> RnM (TyClDecl DocNameI) renameTyClD d = case d of -- TyFamily flav lname ltyvars kind tckind -> do FamDecl { tcdFam = decl } -> do @@ -384,7 +402,7 @@ renameLSig (L loc sig) = return . L loc =<< renameSig sig -renameFamilyDecl :: FamilyDecl Name -> RnM (FamilyDecl DocName) +renameFamilyDecl :: FamilyDecl GhcRn -> RnM (FamilyDecl DocNameI) renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname , fdTyVars = ltyvars , fdFixity = fixity @@ -402,8 +420,8 @@ , fdInjectivityAnn = injectivity' }) -renamePseudoFamilyDecl :: PseudoFamilyDecl Name - -> RnM (PseudoFamilyDecl DocName) +renamePseudoFamilyDecl :: PseudoFamilyDecl GhcRn + -> RnM (PseudoFamilyDecl DocNameI) renamePseudoFamilyDecl (PseudoFamilyDecl { .. }) = PseudoFamilyDecl <$> renameFamilyInfo pfdInfo <*> renameL pfdLName @@ -411,14 +429,14 @@ <*> renameFamilyResultSig pfdKindSig -renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName) +renameFamilyInfo :: FamilyInfo GhcRn -> RnM (FamilyInfo DocNameI) renameFamilyInfo DataFamily = return DataFamily renameFamilyInfo OpenTypeFamily = return OpenTypeFamily renameFamilyInfo (ClosedTypeFamily eqns) - = do { eqns' <- mapM (mapM renameLTyFamInstEqn) eqns + = do { eqns' <- mapM (mapM (mapM renameTyFamInstEqn)) eqns ; return $ ClosedTypeFamily eqns' } -renameDataDefn :: HsDataDefn Name -> RnM (HsDataDefn DocName) +renameDataDefn :: HsDataDefn GhcRn -> RnM (HsDataDefn DocNameI) renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType , dd_kindSig = k, dd_cons = cons }) = do lcontext' <- renameLContext lcontext @@ -429,7 +447,7 @@ , dd_kindSig = k', dd_cons = cons' , dd_derivs = noLoc [] }) -renameCon :: ConDecl Name -> RnM (ConDecl DocName) +renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI) renameCon decl@(ConDeclH98 { con_name = lname, con_qvars = ltyvars , con_cxt = lcontext, con_details = details , con_doc = mbldoc }) = do @@ -460,19 +478,19 @@ return (decl { con_names = lnames' , con_type = lty', con_doc = mbldoc' }) -renameConDeclFieldField :: LConDeclField Name -> RnM (LConDeclField DocName) +renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI) renameConDeclFieldField (L l (ConDeclField names t doc)) = do names' <- mapM renameLFieldOcc names t' <- renameLType t doc' <- mapM renameLDocHsSyn doc return $ L l (ConDeclField names' t' doc') -renameLFieldOcc :: LFieldOcc Name -> RnM (LFieldOcc DocName) +renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI) renameLFieldOcc (L l (FieldOcc lbl sel)) = do sel' <- rename sel return $ L l (FieldOcc lbl sel') -renameSig :: Sig Name -> RnM (Sig DocName) +renameSig :: Sig GhcRn -> RnM (Sig DocNameI) renameSig sig = case sig of TypeSig lnames ltype -> do lnames' <- mapM renameL lnames @@ -496,7 +514,7 @@ _ -> error "expected TypeSig" -renameForD :: ForeignDecl Name -> RnM (ForeignDecl DocName) +renameForD :: ForeignDecl GhcRn -> RnM (ForeignDecl DocNameI) renameForD (ForeignImport lname ltype co x) = do lname' <- renameL lname ltype' <- renameLSigType ltype @@ -507,7 +525,7 @@ return (ForeignExport lname' ltype' co x) -renameInstD :: InstDecl Name -> RnM (InstDecl DocName) +renameInstD :: InstDecl GhcRn -> RnM (InstDecl DocNameI) renameInstD (ClsInstD { cid_inst = d }) = do d' <- renameClsInstD d return (ClsInstD { cid_inst = d' }) @@ -518,7 +536,7 @@ d' <- renameDataFamInstD d return (DataFamInstD { dfid_inst = d' }) -renameDerivD :: DerivDecl Name -> RnM (DerivDecl DocName) +renameDerivD :: DerivDecl GhcRn -> RnM (DerivDecl DocNameI) renameDerivD (DerivDecl { deriv_type = ty , deriv_strategy = strat , deriv_overlap_mode = omode }) = do @@ -527,7 +545,7 @@ , deriv_strategy = strat , deriv_overlap_mode = omode }) -renameClsInstD :: ClsInstDecl Name -> RnM (ClsInstDecl DocName) +renameClsInstD :: ClsInstDecl GhcRn -> RnM (ClsInstDecl DocNameI) renameClsInstD (ClsInstDecl { cid_overlap_mode = omode , cid_poly_ty =ltype, cid_tyfam_insts = lATs , cid_datafam_insts = lADTs }) = do @@ -540,45 +558,60 @@ , cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' }) -renameTyFamInstD :: TyFamInstDecl Name -> RnM (TyFamInstDecl DocName) +renameTyFamInstD :: TyFamInstDecl GhcRn -> RnM (TyFamInstDecl DocNameI) renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn }) - = do { eqn' <- renameLTyFamInstEqn eqn - ; return (TyFamInstDecl { tfid_eqn = eqn' - , tfid_fvs = placeHolderNames }) } + = do { eqn' <- renameTyFamInstEqn eqn + ; return (TyFamInstDecl { tfid_eqn = eqn' }) } -renameLTyFamInstEqn :: LTyFamInstEqn Name -> RnM (LTyFamInstEqn DocName) -renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_fixity = fixity, tfe_rhs = rhs })) - = do { tc' <- renameL tc - ; pats' <- renameImplicit (mapM renameLType) pats - ; rhs' <- renameLType rhs - ; return (L loc (TyFamEqn { tfe_tycon = tc' - , tfe_pats = pats' - , tfe_fixity = fixity - , tfe_rhs = rhs' })) } +renameTyFamInstEqn :: TyFamInstEqn GhcRn -> RnM (TyFamInstEqn DocNameI) +renameTyFamInstEqn eqn + = renameImplicit rename_ty_fam_eqn eqn + where + rename_ty_fam_eqn + :: FamEqn GhcRn (HsTyPats GhcRn) (LHsType GhcRn) + -> RnM (FamEqn DocNameI (HsTyPats DocNameI) (LHsType DocNameI)) + rename_ty_fam_eqn (FamEqn { feqn_tycon = tc, feqn_pats = pats + , feqn_fixity = fixity, feqn_rhs = rhs }) + = do { tc' <- renameL tc + ; pats' <- mapM renameLType pats + ; rhs' <- renameLType rhs + ; return (FamEqn { feqn_tycon = tc' + , feqn_pats = pats' + , feqn_fixity = fixity + , feqn_rhs = rhs' }) } -renameLTyFamDefltEqn :: LTyFamDefltEqn Name -> RnM (LTyFamDefltEqn DocName) -renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_fixity = fixity, tfe_rhs = rhs })) +renameLTyFamDefltEqn :: LTyFamDefltEqn GhcRn -> RnM (LTyFamDefltEqn DocNameI) +renameLTyFamDefltEqn (L loc (FamEqn { feqn_tycon = tc, feqn_pats = tvs + , feqn_fixity = fixity, feqn_rhs = rhs })) = do { tc' <- renameL tc ; tvs' <- renameLHsQTyVars tvs ; rhs' <- renameLType rhs - ; return (L loc (TyFamEqn { tfe_tycon = tc' - , tfe_pats = tvs' - , tfe_fixity = fixity - , tfe_rhs = rhs' })) } + ; return (L loc (FamEqn { feqn_tycon = tc' + , feqn_pats = tvs' + , feqn_fixity = fixity + , feqn_rhs = rhs' })) } -renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName) -renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats, dfid_fixity = fixity, dfid_defn = defn }) - = do { tc' <- renameL tc - ; pats' <- renameImplicit (mapM renameLType) pats - ; defn' <- renameDataDefn defn - ; return (DataFamInstDecl { dfid_tycon = tc' - , dfid_pats = pats' - , dfid_fixity = fixity - , dfid_defn = defn', dfid_fvs = placeHolderNames }) } +renameDataFamInstD :: DataFamInstDecl GhcRn -> RnM (DataFamInstDecl DocNameI) +renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn }) + = do { eqn' <- renameImplicit rename_data_fam_eqn eqn + ; return (DataFamInstDecl { dfid_eqn = eqn' }) } + where + rename_data_fam_eqn + :: FamEqn GhcRn (HsTyPats GhcRn) (HsDataDefn GhcRn) + -> RnM (FamEqn DocNameI (HsTyPats DocNameI) (HsDataDefn DocNameI)) + rename_data_fam_eqn (FamEqn { feqn_tycon = tc, feqn_pats = pats + , feqn_fixity = fixity, feqn_rhs = defn }) + = do { tc' <- renameL tc + ; pats' <- mapM renameLType pats + ; defn' <- renameDataDefn defn + ; return (FamEqn { feqn_tycon = tc' + , feqn_pats = pats' + , feqn_fixity = fixity + , feqn_rhs = defn' }) } renameImplicit :: (in_thing -> RnM out_thing) - -> HsImplicitBndrs Name in_thing - -> RnM (HsImplicitBndrs DocName out_thing) + -> HsImplicitBndrs GhcRn in_thing + -> RnM (HsImplicitBndrs DocNameI out_thing) renameImplicit rn_thing (HsIB { hsib_body = thing }) = do { thing' <- rn_thing thing ; return (HsIB { hsib_body = thing' @@ -586,21 +619,21 @@ , hsib_closed = PlaceHolder }) } renameWc :: (in_thing -> RnM out_thing) - -> HsWildCardBndrs Name in_thing - -> RnM (HsWildCardBndrs DocName out_thing) + -> HsWildCardBndrs GhcRn in_thing + -> RnM (HsWildCardBndrs DocNameI out_thing) renameWc rn_thing (HsWC { hswc_body = thing }) = do { thing' <- rn_thing thing ; return (HsWC { hswc_body = thing' , hswc_wcs = PlaceHolder }) } -renameDocInstance :: DocInstance Name -> RnM (DocInstance DocName) +renameDocInstance :: DocInstance GhcRn -> RnM (DocInstance DocNameI) renameDocInstance (inst, idoc, L l n) = do inst' <- renameInstHead inst n' <- rename n idoc' <- mapM renameDoc idoc return (inst', idoc',L l n') -renameExportItem :: ExportItem Name -> RnM (ExportItem DocName) +renameExportItem :: ExportItem GhcRn -> RnM (ExportItem DocNameI) renameExportItem item = case item of ExportModule mdl -> return (ExportModule mdl) ExportGroup lev id_ doc -> do diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -17,7 +17,6 @@ import FastString import Control.Monad -import Control.Monad.Trans.Reader import Control.Monad.Trans.State import Data.Data @@ -29,27 +28,33 @@ import qualified Data.Set as Set -- | Instantiate all occurrences of given names with corresponding types. -specialize :: forall name a. (Ord name, DataId name, NamedThing name) +specialize :: forall name a. (Ord (IdP name), DataId name, NamedThing (IdP name)) => Data a - => [(name, HsType name)] -> a -> a -specialize specs = go + => [(IdP name, HsType name)] -> a -> a +specialize specs = go spec_map0 where - go :: forall x. Data x => x -> x - go = everywhereButType @name $ mkT $ sugar . specialize_ty_var - specialize_ty_var (HsTyVar _ (L _ name')) + go :: forall x. Data x => Map (IdP name) (HsType name) -> x -> x + go spec_map = everywhereButType @name $ mkT $ sugar . strip_kind_sig . specialize_ty_var spec_map + + strip_kind_sig :: HsType name -> HsType name + strip_kind_sig (HsKindSig (L _ t) _) = t + strip_kind_sig typ = typ + + specialize_ty_var :: Map (IdP name) (HsType name) -> HsType name -> HsType name + specialize_ty_var spec_map (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] + specialize_ty_var _ typ = typ + -- This is a tricky recursive definition. By adding in the specializations + -- one by one, we should avoid infinite loops. + spec_map0 = foldr (\(n,t) acc -> Map.insert n (go acc t) acc) mempty 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 :: (Ord name, DataId name, NamedThing name) +specializeTyVarBndrs :: (Ord (IdP name), DataId name, NamedThing (IdP name)) => Data a => LHsQTyVars name -> [HsType name] -> a -> a @@ -61,14 +66,14 @@ bname (KindedTyVar (L _ name) _) = name -specializePseudoFamilyDecl :: (Ord name, DataId name, NamedThing name) +specializePseudoFamilyDecl :: (Ord (IdP name), DataId name, NamedThing (IdP name)) => LHsQTyVars name -> [HsType name] -> PseudoFamilyDecl name -> PseudoFamilyDecl name specializePseudoFamilyDecl bndrs typs decl = decl {pfdTyVars = map (specializeTyVarBndrs bndrs typs) (pfdTyVars decl)} -specializeSig :: forall name . (Ord name, DataId name, SetName name, NamedThing name) +specializeSig :: forall name . (Ord (IdP name), DataId name, SetName (IdP name), NamedThing (IdP name)) => LHsQTyVars name -> [HsType name] -> Sig name -> Sig name @@ -85,7 +90,7 @@ -- | Make all details of instance head (signatures, associated types) -- specialized to that particular instance type. -specializeInstHead :: (Ord name, DataId name, SetName name, NamedThing name) +specializeInstHead :: (Ord (IdP name), DataId name, SetName (IdP name), NamedThing (IdP name)) => InstHead name -> InstHead name specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } = ihd { ihdInstType = instType' } @@ -105,11 +110,11 @@ -- and tuple literals resulting in types like @[] a@ or @(,,) a b c@. This -- can be fixed using 'sugar' function, that will turn such types into @[a]@ -- and @(a, b, c)@. -sugar :: forall name. (NamedThing name, DataId name) +sugar :: forall name. (NamedThing (IdP name), DataId name) => HsType name -> HsType name sugar = sugarOperators . sugarTuples . sugarLists -sugarLists :: NamedThing name => HsType name -> HsType name +sugarLists :: NamedThing (IdP name) => HsType name -> HsType name sugarLists (HsAppTy (L _ (HsTyVar _ (L _ name))) ltyp) | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp where @@ -118,7 +123,7 @@ sugarLists typ = typ -sugarTuples :: NamedThing name => HsType name -> HsType name +sugarTuples :: NamedThing (IdP name) => HsType name -> HsType name sugarTuples typ = aux [] typ where @@ -135,7 +140,7 @@ aux _ _ = typ -sugarOperators :: NamedThing name => HsType name -> HsType name +sugarOperators :: NamedThing (IdP name) => HsType name -> HsType name sugarOperators (HsAppTy (L _ (HsAppTy (L _ (HsTyVar _ (L l name))) la)) lb) | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy la lb @@ -203,8 +208,8 @@ -- | Compute set of free variables of given type. -freeVariables :: forall name. (NamedThing name, DataId name) - => HsType name -> Set NameRep +freeVariables :: forall name. (NamedThing (IdP name), DataId name) + => HsType name -> Set Name freeVariables = everythingWithState Set.empty Set.union query where @@ -213,7 +218,7 @@ (Set.empty, Set.union ctx (bndrsNames bndrs)) Just (HsTyVar _ (L _ name)) | getName name `Set.member` ctx -> (Set.empty, ctx) - | otherwise -> (Set.singleton $ getNameRep name, ctx) + | otherwise -> (Set.singleton $ getName name, ctx) _ -> (Set.empty, ctx) bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) @@ -225,33 +230,36 @@ -- @(a -> b)@ we get @(a -> b) -> b@ where first occurrence of @b@ refers to -- different type variable than latter one. Applying 'rename' function -- will fix that type to be visually unambiguous again (making it something --- like @(a -> c) -> b@). -rename :: SetName name => Set NameRep -> HsType name -> HsType name -rename fv typ = runReader (renameType typ) $ RenameEnv - { rneFV = fv - , rneCtx = Map.empty - } - +-- like @(a -> b0) -> b@). +rename :: (Eq (IdP name), DataId name, SetName (IdP name)) + => Set Name-> HsType name -> HsType name +rename fv typ = evalState (renameType typ) env + where + env = RenameEnv + { rneHeadFVs = Map.fromList . map mkPair . Set.toList $ fv + , rneSigFVs = Set.map getNameRep $ freeVariables typ + , rneCtx = Map.empty + } + mkPair name = (getNameRep name, name) -- | Renaming monad. -type Rename name = Reader (RenameEnv name) - --- | Binding generation monad. -type Rebind name = State (RenameEnv name) +type Rename name = State (RenameEnv name) data RenameEnv name = RenameEnv - { rneFV :: Set NameRep - , rneCtx :: Map Name name - } + { rneHeadFVs :: Map NameRep Name + , rneSigFVs :: Set NameRep + , rneCtx :: Map Name name + } -renameType :: SetName name => HsType name -> Rename name (HsType name) -renameType (HsForAllTy bndrs lt) = rebind bndrs $ \bndrs' -> +renameType :: (Eq (IdP name), SetName (IdP name)) + => HsType name -> Rename (IdP name) (HsType name) +renameType (HsForAllTy bndrs lt) = HsForAllTy - <$> pure bndrs' + <$> mapM (located renameBinder) bndrs <*> renameLType lt renameType (HsQualTy lctxt lt) = - HsQualTy + HsQualTy <$> located renameContext lctxt <*> renameLType lt renameType (HsTyVar ip name) = HsTyVar ip <$> located renameName name @@ -281,85 +289,58 @@ renameType (HsAppsTy _) = error "HsAppsTy: Only used before renaming" -renameLType :: SetName name => LHsType name -> Rename name (LHsType name) +renameLType :: (Eq (IdP name), SetName (IdP name)) + => LHsType name -> Rename (IdP name) (LHsType name) renameLType = located renameType -renameLTypes :: SetName name => [LHsType name] -> Rename name [LHsType name] +renameLTypes :: (Eq (IdP name), SetName (IdP name)) + => [LHsType name] -> Rename (IdP name) [LHsType name] renameLTypes = mapM renameLType -renameContext :: SetName name => HsContext name -> Rename name (HsContext name) +renameContext :: (Eq (IdP name), SetName (IdP name)) + => HsContext name -> Rename (IdP name) (HsContext name) renameContext = renameLTypes -{- -renameLTyOp :: SetName name => LHsTyOp name -> Rename name (LHsTyOp name) -renameLTyOp (wrap, lname) = (,) wrap <$> located renameName lname --} +renameBinder :: (Eq (IdP name), SetName (IdP name)) + => HsTyVarBndr name -> Rename (IdP name) (HsTyVarBndr name) +renameBinder (UserTyVar lname) = UserTyVar <$> located renameName lname +renameBinder (KindedTyVar lname lkind) = + KindedTyVar <$> located renameName lname <*> located renameType lkind -renameName :: SetName name => name -> Rename name name +-- | Core renaming logic. +renameName :: (Eq name, SetName name) => name -> Rename name name renameName name = do - RenameEnv { rneCtx = ctx } <- ask - pure $ fromMaybe name (Map.lookup (getName name) ctx) - - -rebind :: SetName name - => [LHsTyVarBndr name] -> ([LHsTyVarBndr name] -> Rename name a) - -> Rename name a -rebind lbndrs action = do - (lbndrs', env') <- runState (rebindLTyVarBndrs lbndrs) <$> ask - local (const env') (action lbndrs') - - -rebindLTyVarBndrs :: SetName name - => [LHsTyVarBndr name] -> Rebind name [LHsTyVarBndr name] -rebindLTyVarBndrs lbndrs = mapM (located rebindTyVarBndr) lbndrs - - -rebindTyVarBndr :: SetName name - => HsTyVarBndr name -> Rebind name (HsTyVarBndr name) -rebindTyVarBndr (UserTyVar (L l name)) = - UserTyVar . L l <$> rebindName name -rebindTyVarBndr (KindedTyVar name kinds) = - KindedTyVar <$> located rebindName name <*> pure kinds - - -rebindName :: SetName name => name -> Rebind name name -rebindName name = do RenameEnv { .. } <- get - taken <- takenNames case Map.lookup (getName name) rneCtx of - Just name' -> pure name' - Nothing | getNameRep name `Set.member` taken -> freshName name - Nothing -> reuseName name + Nothing + | Just headTv <- Map.lookup (getNameRep name) rneHeadFVs + , headTv /= getName name -> freshName name + Just name' -> return name' + _ -> return name -- | Generate fresh occurrence name, put it into context and return. -freshName :: SetName name => name -> Rebind name name +freshName :: SetName name => name -> Rename name name freshName name = do - env@RenameEnv { .. } <- get taken <- takenNames let name' = setInternalNameRep (findFreshName taken rep) name - put $ env { rneCtx = Map.insert nname name' rneCtx } + modify $ \rne -> rne + { rneCtx = Map.insert (getName name) name' (rneCtx rne) } return name' where nname = getName name rep = getNameRep nname -reuseName :: SetName name => name -> Rebind name name -reuseName name = do - env@RenameEnv { .. } <- get - put $ env { rneCtx = Map.insert (getName name) name rneCtx } - return name - - -takenNames :: NamedThing name => Rebind name (Set NameRep) +takenNames :: NamedThing name => Rename name (Set NameRep) takenNames = do RenameEnv { .. } <- get - return $ Set.union rneFV (ctxElems rneCtx) + return $ Set.unions [headReps rneHeadFVs, rneSigFVs, ctxElems rneCtx] where + headReps = Set.fromList . Map.keys ctxElems = Set.fromList . map getNameRep . Map.elems @@ -371,15 +352,7 @@ alternativeNames :: NameRep -> [NameRep] -alternativeNames name - | [_] <- nameRepString name = letterNames ++ alternativeNames' name - where - letterNames = map (stringNameRep . pure) ['a'..'z'] -alternativeNames name = alternativeNames' name - - -alternativeNames' :: NameRep -> [NameRep] -alternativeNames' name = +alternativeNames name = [ stringNameRep $ str ++ show i | i :: Int <- [0..] ] where str = nameRepString name @@ -389,6 +362,6 @@ located f (L loc e) = L loc <$> f e -tyVarName :: HsTyVarBndr name -> name +tyVarName :: HsTyVarBndr name -> IdP name tyVarName (UserTyVar name) = unLoc name tyVarName (KindedTyVar (L _ name) _) = name diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -82,8 +82,8 @@ -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] -- binaryInterfaceVersion :: Word16 -#if (__GLASGOW_HASKELL__ >= 802) && (__GLASGOW_HASKELL__ < 804) -binaryInterfaceVersion = 31 +#if (__GLASGOW_HASKELL__ >= 803) && (__GLASGOW_HASKELL__ < 805) +binaryInterfaceVersion = 32 binaryInterfaceVersionCompatibility :: [Word16] binaryInterfaceVersionCompatibility = [binaryInterfaceVersion] @@ -158,7 +158,7 @@ type NameCacheAccessor m = (m NameCache, NameCache -> m ()) -nameCacheFromGhc :: NameCacheAccessor Ghc +nameCacheFromGhc :: forall m. (GhcMonad m, MonadIO m) => NameCacheAccessor m nameCacheFromGhc = ( read_from_session , write_to_session ) where read_from_session = do @@ -373,7 +373,7 @@ instance Binary InstalledInterface where put_ bh (InstalledInterface modu is_sig info docMap argMap - exps visExps opts subMap patSynMap fixMap) = do + exps visExps opts fixMap) = do put_ bh modu put_ bh is_sig put_ bh info @@ -381,8 +381,6 @@ put_ bh exps put_ bh visExps put_ bh opts - put_ bh subMap - put_ bh patSynMap put_ bh fixMap get bh = do @@ -393,12 +391,9 @@ exps <- get bh visExps <- get bh opts <- get bh - subMap <- get bh - patSynMap <- get bh fixMap <- get bh - return (InstalledInterface modu is_sig info docMap argMap - exps visExps opts subMap patSynMap fixMap) + exps visExps opts fixMap) instance Binary DocOption where @@ -464,6 +459,32 @@ t <- get bh return (Header l t) +instance Binary a => Binary (Table a) where + put_ bh (Table h b) = do + put_ bh h + put_ bh b + get bh = do + h <- get bh + b <- get bh + return (Table h b) + +instance Binary a => Binary (TableRow a) where + put_ bh (TableRow cs) = put_ bh cs + get bh = do + cs <- get bh + return (TableRow cs) + +instance Binary a => Binary (TableCell a) where + put_ bh (TableCell i j c) = do + put_ bh i + put_ bh j + put_ bh c + get bh = do + i <- get bh + j <- get bh + c <- get bh + return (TableCell i j c) + instance Binary Meta where put_ bh Meta { _version = v } = put_ bh v get bh = (\v -> Meta { _version = v }) <$> get bh @@ -547,6 +568,9 @@ put_ bh (DocMathDisplay x) = do putByte bh 22 put_ bh x + put_ bh (DocTable x) = do + putByte bh 23 + put_ bh x get bh = do h <- getByte bh @@ -620,6 +644,9 @@ 22 -> do x <- get bh return (DocMathDisplay x) + 23 -> do + x <- get bh + return (DocTable x) _ -> error "invalid binary data found in the interface file" diff --git a/haddock-api/src/Haddock/ModuleTree.hs b/haddock-api/src/Haddock/ModuleTree.hs --- a/haddock-api/src/Haddock/ModuleTree.hs +++ b/haddock-api/src/Haddock/ModuleTree.hs @@ -20,39 +20,41 @@ import Packages ( lookupPackage ) import PackageConfig ( sourcePackageIdString ) +import qualified Control.Applicative as A -data ModuleTree = Node String Bool (Maybe String) (Maybe String) (Maybe (MDoc Name)) [ModuleTree] +data ModuleTree = Node String (Maybe Module) (Maybe String) (Maybe String) (Maybe (MDoc Name)) [ModuleTree] + mkModuleTree :: DynFlags -> Bool -> [(Module, Maybe (MDoc Name))] -> [ModuleTree] mkModuleTree dflags showPkgs mods = - foldr fn [] [ (splitModule mdl, modPkg mdl, modSrcPkg mdl, short) | (mdl, short) <- mods ] + foldr fn [] [ (mdl, splitModule mdl, modPkg mdl, modSrcPkg mdl, short) | (mdl, short) <- mods ] where modPkg mod_ | showPkgs = Just (unitIdString (moduleUnitId mod_)) | otherwise = Nothing modSrcPkg mod_ | showPkgs = fmap sourcePackageIdString (lookupPackage dflags (moduleUnitId mod_)) | otherwise = Nothing - fn (mod_,pkg,srcPkg,short) = addToTrees mod_ pkg srcPkg short + fn (m,mod_,pkg,srcPkg,short) = addToTrees mod_ m pkg srcPkg short -addToTrees :: [String] -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -> [ModuleTree] -addToTrees [] _ _ _ ts = ts -addToTrees ss pkg srcPkg short [] = mkSubTree ss pkg srcPkg short -addToTrees (s1:ss) pkg srcPkg short (t@(Node s2 leaf node_pkg node_srcPkg node_short subs) : ts) - | s1 > s2 = t : addToTrees (s1:ss) pkg srcPkg short ts - | s1 == s2 = Node s2 (leaf || null ss) this_pkg this_srcPkg this_short (addToTrees ss pkg srcPkg short subs) : ts - | otherwise = mkSubTree (s1:ss) pkg srcPkg short ++ t : ts +addToTrees :: [String] -> Module -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -> [ModuleTree] +addToTrees [] _ _ _ _ ts = ts +addToTrees ss m pkg srcPkg short [] = mkSubTree ss m pkg srcPkg short +addToTrees (s1:ss) m pkg srcPkg short (t@(Node s2 leaf node_pkg node_srcPkg node_short subs) : ts) + | s1 > s2 = t : addToTrees (s1:ss) m pkg srcPkg short ts + | s1 == s2 = Node s2 (leaf A.<|> (if null ss then Just m else Nothing)) this_pkg this_srcPkg this_short (addToTrees ss m pkg srcPkg short subs) : ts + | otherwise = mkSubTree (s1:ss) m pkg srcPkg short ++ t : ts where this_pkg = if null ss then pkg else node_pkg this_srcPkg = if null ss then srcPkg else node_srcPkg this_short = if null ss then short else node_short -mkSubTree :: [String] -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -mkSubTree [] _ _ _ = [] -mkSubTree [s] pkg srcPkg short = [Node s True pkg srcPkg short []] -mkSubTree (s:ss) pkg srcPkg short = [Node s (null ss) Nothing Nothing Nothing (mkSubTree ss pkg srcPkg short)] +mkSubTree :: [String] -> Module -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] +mkSubTree [] _ _ _ _ = [] +mkSubTree [s] m pkg srcPkg short = [Node s (Just m) pkg srcPkg short []] +mkSubTree (s:s':ss) m pkg srcPkg short = [Node s Nothing Nothing Nothing Nothing (mkSubTree (s':ss) m pkg srcPkg short)] splitModule :: Module -> [String] diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -25,11 +25,13 @@ sourceUrls, wikiUrls, optDumpInterfaceFile, + optShowInterfaceFile, optLaTeXStyle, optMathjax, qualification, verbosity, ghcFlags, + reexportFlags, readIfaceArgs, optPackageName, optPackageVersion @@ -53,6 +55,7 @@ -- | Flag_DocBook | Flag_ReadInterface String | Flag_DumpInterface String + | Flag_ShowInterface String | Flag_Heading String | Flag_Html | Flag_Hoogle @@ -68,6 +71,7 @@ | Flag_WikiEntityURL String | Flag_LaTeX | Flag_LaTeXStyle String + | Flag_QuickJumpIndex | Flag_HyperlinkedSource | Flag_SourceCss String | Flag_Mathjax String @@ -82,6 +86,8 @@ | Flag_GenIndex | Flag_IgnoreAllExports | Flag_HideModule String + | Flag_ShowModule String + | Flag_ShowAllModules | Flag_ShowExtensions String | Flag_OptGhc String | Flag_GhcLibDir String @@ -96,6 +102,7 @@ | Flag_NoPrintMissingDocs | Flag_PackageName String | Flag_PackageVersion String + | Flag_Reexport String deriving (Eq, Show) @@ -112,6 +119,8 @@ "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) @@ -122,6 +131,8 @@ Option ['U'] ["use-unicode"] (NoArg Flag_UseUnicode) "use Unicode in HTML output", Option [] ["hoogle"] (NoArg Flag_Hoogle) "output for Hoogle; you may want --package-name and --package-version too", + Option [] ["quickjump"] (NoArg Flag_QuickJumpIndex) + "generate an index for interactive documentation navigation", Option [] ["hyperlinked-source"] (NoArg Flag_HyperlinkedSource) "generate highlighted and hyperlinked source code (for use with --html)", Option [] ["source-css"] (ReqArg Flag_SourceCss "FILE") @@ -173,6 +184,10 @@ "behave as if all modules have the\nignore-exports atribute", Option [] ["hide"] (ReqArg Flag_HideModule "MODULE") "behave as if MODULE has the hide attribute", + Option [] ["show"] (ReqArg Flag_ShowModule "MODULE") + "behave as if MODULE does not have the hide attribute", + Option [] ["show-all"] (NoArg Flag_ShowAllModules) + "behave as if not modules have the hide attribute", Option [] ["show-extensions"] (ReqArg Flag_ShowExtensions "MODULE") "behave as if MODULE has the show-extensions attribute", Option [] ["optghc"] (ReqArg Flag_OptGhc "OPTION") @@ -190,6 +205,8 @@ "generate html with newlines and indenting (for use with --html)", Option [] ["no-print-missing-docs"] (NoArg Flag_NoPrintMissingDocs) "don't print information about any undocumented entities", + Option [] ["reexport"] (ReqArg Flag_Reexport "MOD") + "reexport the module MOD, adding it to the index", Option [] ["package-name"] (ReqArg Flag_PackageName "NAME") "name of the package being documented", Option [] ["package-version"] (ReqArg Flag_PackageVersion "VERSION") @@ -270,6 +287,8 @@ 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 ] @@ -303,6 +322,9 @@ ghcFlags :: [Flag] -> [String] ghcFlags flags = [ option | Flag_OptGhc option <- flags ] + +reexportFlags :: [Flag] -> [String] +reexportFlags flags = [ option | Flag_Reexport option <- flags ] readIfaceArgs :: [Flag] -> [(DocPaths, FilePath)] diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -1,8 +1,6 @@ {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module GHC.PlaceHolder - {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- @@ -59,7 +57,7 @@ type DocMap a = Map Name (MDoc a) type ArgMap a = Map Name (Map Int (MDoc a)) type SubMap = Map Name [Name] -type DeclMap = Map Name [LHsDecl Name] +type DeclMap = Map Name [LHsDecl GhcRn] type InstMap = Map SrcSpan Name type FixMap = Map Name Fixity type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources @@ -101,10 +99,7 @@ -- | Declarations originating from the module. Excludes declarations without -- names (instances and stand-alone documentation comments). Includes -- names of subordinate declarations mapped to their parent declarations. - , ifaceDeclMap :: !(Map Name [LHsDecl Name]) - - -- | Bundled pattern synonym declarations for specific types. - , ifaceBundledPatSynMap :: !(Map Name [Name]) + , ifaceDeclMap :: !(Map Name [LHsDecl GhcRn]) -- | Documentation of declarations originating from the module (including -- subordinates). @@ -116,11 +111,10 @@ , ifaceRnDocMap :: !(DocMap DocName) , ifaceRnArgMap :: !(ArgMap DocName) - , ifaceSubMap :: !(Map Name [Name]) , ifaceFixMap :: !(Map Name Fixity) - , ifaceExportItems :: ![ExportItem Name] - , ifaceRnExportItems :: ![ExportItem DocName] + , ifaceExportItems :: ![ExportItem GhcRn] + , ifaceRnExportItems :: ![ExportItem DocNameI] -- | All names exported by the module. , ifaceExports :: ![Name] @@ -138,8 +132,8 @@ , ifaceFamInstances :: ![FamInst] -- | Orphan instances - , ifaceOrphanInstances :: ![DocInstance Name] - , ifaceRnOrphanInstances :: ![DocInstance DocName] + , ifaceOrphanInstances :: ![DocInstance GhcRn] + , ifaceRnOrphanInstances :: ![DocInstance DocNameI] -- | The number of haddockable and haddocked items in the module, as a -- tuple. Haddockable items are the exports and the module itself. @@ -186,10 +180,6 @@ -- | Haddock options for this module (prune, ignore-exports, etc). , instOptions :: [DocOption] - , instSubMap :: Map Name [Name] - - , instBundledPatSynMap :: Map Name [Name] - , instFixMap :: Map Name Fixity } @@ -205,8 +195,6 @@ , instExports = ifaceExports interface , instVisibleExports = ifaceVisibleExports interface , instOptions = ifaceOptions interface - , instSubMap = ifaceSubMap interface - , instBundledPatSynMap = ifaceBundledPatSynMap interface , instFixMap = ifaceFixMap interface } @@ -225,21 +213,21 @@ expItemDecl :: !(LHsDecl name) -- | Bundled patterns for a data type declaration - , expItemPats :: ![(HsDecl name, DocForDecl name)] + , expItemPats :: ![(HsDecl name, DocForDecl (IdP name))] -- | Maybe a doc comment, and possibly docs for arguments (if this -- decl is a function or type-synonym). - , expItemMbDoc :: !(DocForDecl name) + , expItemMbDoc :: !(DocForDecl (IdP name)) -- | Subordinate names, possibly with documentation. - , expItemSubDocs :: ![(name, DocForDecl name)] + , expItemSubDocs :: ![(IdP name, DocForDecl (IdP name))] -- | Instances relevant to this declaration, possibly with -- documentation. , expItemInstances :: ![DocInstance name] -- | Fixity decls relevant to this declaration (including subordinates). - , expItemFixities :: ![(name, Fixity)] + , expItemFixities :: ![(IdP name, Fixity)] -- | Whether the ExportItem is from a TH splice or not, for generating -- the appropriate type of Source link. @@ -249,10 +237,10 @@ -- | An exported entity for which we have no documentation (perhaps because it -- resides in another package). | ExportNoDecl - { expItemName :: !name + { expItemName :: !(IdP name) -- | Subordinate names. - , expItemSubs :: ![name] + , expItemSubs :: ![IdP name] } -- | A section heading. @@ -265,11 +253,11 @@ , expItemSectionId :: !String -- | Section heading text. - , expItemSectionText :: !(Doc name) + , expItemSectionText :: !(Doc (IdP name)) } -- | Some documentation. - | ExportDoc !(MDoc name) + | ExportDoc !(MDoc (IdP name)) -- | A cross-reference to another module. | ExportModule !Module @@ -309,15 +297,11 @@ -- documentation, as far as Haddock knows. deriving (Eq, Data) -type instance PostRn DocName NameSet = PlaceHolder -type instance PostRn DocName Fixity = PlaceHolder -type instance PostRn DocName Bool = PlaceHolder -type instance PostRn DocName [Name] = PlaceHolder +data DocNameI -type instance PostTc DocName Kind = PlaceHolder -type instance PostTc DocName Type = PlaceHolder -type instance PostTc DocName Coercion = PlaceHolder +type instance IdP DocNameI = DocName + instance NamedThing DocName where getName (Documented name _) = name getName (Undocumented name) = name @@ -363,7 +347,7 @@ | TypeInst (Maybe (HsType name)) -- ^ Body (right-hand side) | DataInst (TyClDecl name) -- ^ Data constructors -instance (OutputableBndrId a) +instance (SourceTextX a, OutputableBndrId a) => Outputable (InstType a) where ppr (ClassInst { .. }) = text "ClassInst" <+> ppr clsiCtx @@ -382,7 +366,7 @@ -- 'PseudoFamilyDecl' type is introduced. data PseudoFamilyDecl name = PseudoFamilyDecl { pfdInfo :: FamilyInfo name - , pfdLName :: Located name + , pfdLName :: Located (IdP name) , pfdTyVars :: [LHsType name] , pfdKindSig :: LFamilyResultSig name } @@ -404,13 +388,12 @@ -- | An instance head that may have documentation and a source location. -type DocInstance name = (InstHead name, Maybe (MDoc name), Located name) +type DocInstance name = (InstHead name, Maybe (MDoc (IdP name)), Located (IdP name)) --- | The head of an instance. Consists of a class name, a list of kind --- parameters, a list of type parameters and an instance type +-- | The head of an instance. Consists of a class name, a list of type +-- parameters (which may be annotated with kinds), and an instance type data InstHead name = InstHead - { ihdClsName :: name - , ihdKinds :: [HsType name] + { ihdClsName :: IdP name , ihdTypes :: [HsType name] , ihdInstType :: InstType name } @@ -443,6 +426,8 @@ type Doc id = DocH (ModuleName, OccName) id type MDoc id = MetaDoc (ModuleName, OccName) id +type DocMarkup id a = DocMarkupH (ModuleName, OccName) id a + instance (NFData a, NFData mod) => NFData (DocH mod a) where rnf doc = case doc of @@ -469,6 +454,7 @@ DocProperty a -> a `deepseq` () DocExamples a -> a `deepseq` () DocHeader a -> a `deepseq` () + DocTable a -> a `deepseq` () #if !MIN_VERSION_ghc(8,0,2) -- These were added to GHC itself in 8.0.2 @@ -489,39 +475,19 @@ instance NFData Example where rnf (Example a b) = a `deepseq` b `deepseq` () +instance NFData id => NFData (Table id) where + rnf (Table h b) = h `deepseq` b `deepseq` () +instance NFData id => NFData (TableRow id) where + rnf (TableRow cs) = cs `deepseq` () + +instance NFData id => NFData (TableCell id) where + rnf (TableCell i j c) = i `deepseq` j `deepseq` c `deepseq` () + exampleToString :: Example -> String exampleToString (Example expression result) = ">>> " ++ expression ++ "\n" ++ unlines result - -data DocMarkup id a = Markup - { markupEmpty :: a - , markupString :: String -> a - , markupParagraph :: a -> a - , markupAppend :: a -> a -> a - , markupIdentifier :: id -> a - , markupIdentifierUnchecked :: (ModuleName, OccName) -> a - , markupModule :: String -> a - , markupWarning :: a -> a - , markupEmphasis :: a -> a - , markupBold :: a -> a - , markupMonospaced :: a -> a - , markupUnorderedList :: [a] -> a - , markupOrderedList :: [a] -> a - , markupDefList :: [(a,a)] -> a - , markupCodeBlock :: a -> a - , markupHyperlink :: Hyperlink -> a - , markupAName :: String -> a - , markupPic :: Picture -> a - , markupMathInline :: String -> a - , markupMathDisplay :: String -> a - , markupProperty :: String -> a - , markupExample :: [Example] -> a - , markupHeader :: Header a -> a - } - - data HaddockModInfo name = HaddockModInfo { hmi_description :: Maybe (Doc name) , hmi_copyright :: Maybe String @@ -605,6 +571,12 @@ 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 @@ -688,14 +660,14 @@ -- * Pass sensitive types ----------------------------------------------------------------------------- -type instance PostRn DocName NameSet = PlaceHolder -type instance PostRn DocName Fixity = PlaceHolder -type instance PostRn DocName Bool = PlaceHolder -type instance PostRn DocName Name = DocName -type instance PostRn DocName (Located Name) = Located DocName -type instance PostRn DocName [Name] = PlaceHolder -type instance PostRn DocName DocName = DocName +type instance PostRn DocNameI NameSet = PlaceHolder +type instance PostRn DocNameI Fixity = PlaceHolder +type instance PostRn DocNameI Bool = PlaceHolder +type instance PostRn DocNameI Name = DocName +type instance PostRn DocNameI (Located Name) = Located DocName +type instance PostRn DocNameI [Name] = PlaceHolder +type instance PostRn DocNameI DocName = DocName -type instance PostTc DocName Kind = PlaceHolder -type instance PostTc DocName Type = PlaceHolder -type instance PostTc DocName Coercion = PlaceHolder +type instance PostTc DocNameI Kind = PlaceHolder +type instance PostTc DocNameI Type = PlaceHolder +type instance PostTc DocNameI Coercion = PlaceHolder diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -20,10 +20,11 @@ -- * Filename utilities moduleHtmlFile, moduleHtmlFile', - contentsHtmlFile, indexHtmlFile, + contentsHtmlFile, indexHtmlFile, indexJsonFile, moduleIndexFrameName, mainFrameName, synopsisFrameName, subIndexHtmlFile, - jsFile, + haddockJsFile, jsQuickJumpFile, + quickJumpCssFile, -- * Anchor and URL utilities moduleNameUrl, moduleNameUrl', moduleUrl, @@ -37,8 +38,6 @@ html_xrefs_ref, html_xrefs_ref', -- * Doc markup - markup, - idMarkup, mkMeta, -- * List utilities @@ -125,12 +124,12 @@ mkMeta :: Doc a -> MDoc a mkMeta x = emptyMetaDoc { _doc = x } -mkEmptySigWcType :: LHsType Name -> LHsSigWcType Name +mkEmptySigWcType :: LHsType GhcRn -> LHsSigWcType GhcRn -- Dubious, because the implicit binders are empty even -- though the type might have free varaiables mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs ty) -addClassContext :: Name -> LHsQTyVars Name -> LSig Name -> LSig Name +addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn -- Add the class context to a class-op signature addClassContext cls tvs0 (L pos (ClassOpSig _ lname ltype)) = L pos (TypeSig lname (mkEmptySigWcType (go (hsSigType ltype)))) @@ -148,7 +147,7 @@ addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine -lHsQTyVarsToTypes :: LHsQTyVars Name -> [LHsType Name] +lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn] lHsQTyVarsToTypes tvs = [ noLoc (HsTyVar NotPromoted (noLoc (hsLTyVarName tv))) | tv <- hsQTvExplicit tvs ] @@ -158,7 +157,7 @@ -------------------------------------------------------------------------------- -restrictTo :: [Name] -> LHsDecl Name -> LHsDecl Name +restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn restrictTo names (L loc decl) = L loc $ case decl of TyClD d | isDataDecl d -> TyClD (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) }) @@ -167,7 +166,7 @@ tcdATs = restrictATs names (tcdATs d) }) _ -> decl -restrictDataDefn :: [Name] -> HsDataDefn Name -> HsDataDefn Name +restrictDataDefn :: [Name] -> HsDataDefn GhcRn -> HsDataDefn GhcRn restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons }) | DataType <- new_or_data = defn { dd_cons = restrictCons names cons } @@ -177,7 +176,7 @@ [con] -> defn { dd_cons = [con] } _ -> error "Should not happen" -restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name] +restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn] restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] where keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) = @@ -197,7 +196,7 @@ h98ConDecl c@ConDeclGADT{} = c' where (details,_res_ty,cxt,tvs) = gadtDeclDetails (con_type c) - c' :: ConDecl Name + c' :: ConDecl GhcRn c' = ConDeclH98 { con_name = head (con_names c) , con_qvars = Just $ HsQTvs { hsq_implicit = mempty @@ -208,18 +207,18 @@ , con_doc = con_doc c } - field_avail :: LConDeclField Name -> Bool + field_avail :: LConDeclField GhcRn -> Bool field_avail (L _ (ConDeclField fs _ _)) = all (\f -> selectorFieldOcc (unLoc f) `elem` names) fs field_types flds = [ t | ConDeclField _ t _ <- flds ] keep _ = Nothing -restrictDecls :: [Name] -> [LSig Name] -> [LSig Name] +restrictDecls :: [Name] -> [LSig GhcRn] -> [LSig GhcRn] restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) -restrictATs :: [Name] -> [LFamilyDecl Name] -> [LFamilyDecl Name] +restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn] restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ] emptyHsQTvs :: LHsQTyVars Name @@ -256,9 +255,10 @@ Just fp0 -> HtmlPath.joinPath [fp0, baseName mdl ++ ".html"] -contentsHtmlFile, indexHtmlFile :: String +contentsHtmlFile, indexHtmlFile, indexJsonFile :: String contentsHtmlFile = "index.html" indexHtmlFile = "doc-index.html" +indexJsonFile = "doc-index.json" @@ -326,10 +326,15 @@ ------------------------------------------------------------------------------- -jsFile :: String -jsFile = "haddock-util.js" +haddockJsFile :: String +haddockJsFile = "haddock-bundle.min.js" +jsQuickJumpFile :: String +jsQuickJumpFile = "quick-jump.min.js" +quickJumpCssFile :: String +quickJumpCssFile = "quick-jump.css" + ------------------------------------------------------------------------------- -- * Misc. ------------------------------------------------------------------------------- @@ -447,71 +452,6 @@ spanWith p xs@(a:as) | Just b <- p a = let (bs,cs) = spanWith p as in (b:bs,cs) | otherwise = ([],xs) - - ------------------------------------------------------------------------------ --- * Put here temporarily ------------------------------------------------------------------------------ - - -markup :: DocMarkup id a -> Doc id -> a -markup m DocEmpty = markupEmpty m -markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2) -markup m (DocString s) = markupString m s -markup m (DocParagraph d) = markupParagraph m (markup m d) -markup m (DocIdentifier x) = markupIdentifier m x -markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x -markup m (DocModule mod0) = markupModule m mod0 -markup m (DocWarning d) = markupWarning m (markup m d) -markup m (DocEmphasis d) = markupEmphasis m (markup m d) -markup m (DocBold d) = markupBold m (markup m d) -markup m (DocMonospaced d) = markupMonospaced m (markup m d) -markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds) -markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds) -markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds) -markup m (DocCodeBlock d) = markupCodeBlock m (markup m d) -markup m (DocHyperlink l) = markupHyperlink m l -markup m (DocAName ref) = markupAName m ref -markup m (DocPic img) = markupPic m img -markup m (DocMathInline mathjax) = markupMathInline m mathjax -markup m (DocMathDisplay mathjax) = markupMathDisplay m mathjax -markup m (DocProperty p) = markupProperty m p -markup m (DocExamples e) = markupExample m e -markup m (DocHeader (Header l t)) = markupHeader m (Header l (markup m t)) - - -markupPair :: DocMarkup id a -> (Doc id, Doc id) -> (a, a) -markupPair m (a,b) = (markup m a, markup m b) - - --- | The identity markup -idMarkup :: DocMarkup a (Doc a) -idMarkup = Markup { - markupEmpty = DocEmpty, - markupString = DocString, - markupParagraph = DocParagraph, - markupAppend = DocAppend, - markupIdentifier = DocIdentifier, - markupIdentifierUnchecked = DocIdentifierUnchecked, - markupModule = DocModule, - markupWarning = DocWarning, - markupEmphasis = DocEmphasis, - markupBold = DocBold, - markupMonospaced = DocMonospaced, - markupUnorderedList = DocUnorderedList, - markupOrderedList = DocOrderedList, - markupDefList = DocDefList, - markupCodeBlock = DocCodeBlock, - markupHyperlink = DocHyperlink, - markupAName = DocAName, - markupPic = DocPic, - markupMathInline = DocMathInline, - markupMathDisplay = DocMathDisplay, - markupProperty = DocProperty, - markupExample = DocExamples, - markupHeader = DocHeader - } - ----------------------------------------------------------------------------- -- * System tools diff --git a/haddock-api/src/Haddock/Utils/Json.hs b/haddock-api/src/Haddock/Utils/Json.hs new file mode 100644 --- /dev/null +++ b/haddock-api/src/Haddock/Utils/Json.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Minimal JSON / RFC 7159 support +-- +-- The API is heavily inspired by @aeson@'s API but puts emphasis on +-- simplicity rather than performance. The 'ToJSON' instances are +-- intended to have an encoding compatible with @aeson@'s encoding. +-- +module Haddock.Utils.Json + ( Value(..) + , Object, object, Pair, (.=) + , encodeToString + , encodeToBuilder + , ToJSON(toJSON) + ) + where + +import Data.Char +import Data.Int +import Data.String +import Data.Word +import Data.List +import Data.Monoid + +import Data.ByteString.Builder (Builder) +import qualified Data.ByteString.Builder as BB + +-- TODO: We may want to replace 'String' with 'Text' or 'ByteString' + +-- | A JSON value represented as a Haskell value. +data Value = Object !Object + | Array [Value] + | String String + | Number !Double + | Bool !Bool + | Null + deriving (Eq, Read, Show) + +-- | A key\/value pair for an 'Object' +type Pair = (String, Value) + +-- | A JSON \"object\" (key/value map). +type Object = [Pair] + +infixr 8 .= + +-- | A key-value pair for encoding a JSON object. +(.=) :: ToJSON v => String -> v -> Pair +k .= v = (k, toJSON v) + +-- | Create a 'Value' from a list of name\/value 'Pair's. +object :: [Pair] -> Value +object = Object + +instance IsString Value where + fromString = String + + +-- | A type that can be converted to JSON. +class ToJSON a where + -- | Convert a Haskell value to a JSON-friendly intermediate type. + toJSON :: a -> Value + +instance ToJSON () where + toJSON () = Array [] + +instance ToJSON Value where + toJSON = id + +instance ToJSON Bool where + toJSON = Bool + +instance ToJSON a => ToJSON [a] where + toJSON = Array . map toJSON + +instance ToJSON a => ToJSON (Maybe a) where + toJSON Nothing = Null + toJSON (Just a) = toJSON a + +instance (ToJSON a,ToJSON b) => ToJSON (a,b) where + toJSON (a,b) = Array [toJSON a, toJSON b] + +instance (ToJSON a,ToJSON b,ToJSON c) => ToJSON (a,b,c) where + toJSON (a,b,c) = Array [toJSON a, toJSON b, toJSON c] + +instance (ToJSON a,ToJSON b,ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where + toJSON (a,b,c,d) = Array [toJSON a, toJSON b, toJSON c, toJSON d] + +instance ToJSON Float where + toJSON = Number . realToFrac + +instance ToJSON Double where + toJSON = Number + +instance ToJSON Int where toJSON = Number . realToFrac +instance ToJSON Int8 where toJSON = Number . realToFrac +instance ToJSON Int16 where toJSON = Number . realToFrac +instance ToJSON Int32 where toJSON = Number . realToFrac + +instance ToJSON Word where toJSON = Number . realToFrac +instance ToJSON Word8 where toJSON = Number . realToFrac +instance ToJSON Word16 where toJSON = Number . realToFrac +instance ToJSON Word32 where toJSON = Number . realToFrac + +-- | Possibly lossy due to conversion to 'Double' +instance ToJSON Int64 where toJSON = Number . realToFrac + +-- | Possibly lossy due to conversion to 'Double' +instance ToJSON Word64 where toJSON = Number . realToFrac + +-- | Possibly lossy due to conversion to 'Double' +instance ToJSON Integer where toJSON = Number . fromInteger + +------------------------------------------------------------------------------ +-- 'BB.Builder'-based encoding + +-- | Serialise value as JSON/UTF8-encoded 'Builder' +encodeToBuilder :: ToJSON a => a -> Builder +encodeToBuilder = encodeValueBB . toJSON + +encodeValueBB :: Value -> Builder +encodeValueBB jv = case jv of + Bool True -> "true" + Bool False -> "false" + Null -> "null" + Number n + | isNaN n || isInfinite n -> encodeValueBB Null + | Just i <- doubleToInt64 n -> BB.int64Dec i + | otherwise -> BB.doubleDec n + Array a -> encodeArrayBB a + String s -> encodeStringBB s + Object o -> encodeObjectBB o + +encodeArrayBB :: [Value] -> Builder +encodeArrayBB [] = "[]" +encodeArrayBB jvs = BB.char8 '[' <> go jvs <> BB.char8 ']' + where + go = Data.Monoid.mconcat . intersperse (BB.char8 ',') . map encodeValueBB + +encodeObjectBB :: Object -> Builder +encodeObjectBB [] = "{}" +encodeObjectBB jvs = BB.char8 '{' <> go jvs <> BB.char8 '}' + where + go = Data.Monoid.mconcat . intersperse (BB.char8 ',') . map encPair + encPair (l,x) = encodeStringBB l <> BB.char8 ':' <> encodeValueBB x + +encodeStringBB :: String -> Builder +encodeStringBB str = BB.char8 '"' <> go str <> BB.char8 '"' + where + go = BB.stringUtf8 . escapeString + +------------------------------------------------------------------------------ +-- 'String'-based encoding + +-- | Serialise value as JSON-encoded Unicode 'String' +encodeToString :: ToJSON a => a -> String +encodeToString jv = encodeValue (toJSON jv) [] + +encodeValue :: Value -> ShowS +encodeValue jv = case jv of + Bool b -> showString (if b then "true" else "false") + Null -> showString "null" + Number n + | isNaN n || isInfinite n -> encodeValue Null + | Just i <- doubleToInt64 n -> shows i + | otherwise -> shows n + Array a -> encodeArray a + String s -> encodeString s + Object o -> encodeObject o + +encodeArray :: [Value] -> ShowS +encodeArray [] = showString "[]" +encodeArray jvs = ('[':) . go jvs . (']':) + where + go [] = id + go [x] = encodeValue x + go (x:xs) = encodeValue x . (',':) . go xs + +encodeObject :: Object -> ShowS +encodeObject [] = showString "{}" +encodeObject jvs = ('{':) . go jvs . ('}':) + where + go [] = id + go [(l,x)] = encodeString l . (':':) . encodeValue x + go ((l,x):lxs) = encodeString l . (':':) . encodeValue x . (',':) . go lxs + +encodeString :: String -> ShowS +encodeString str = ('"':) . showString (escapeString str) . ('"':) + +------------------------------------------------------------------------------ +-- helpers + +-- | Try to convert 'Double' into 'Int64', return 'Nothing' if not +-- representable loss-free as integral 'Int64' value. +doubleToInt64 :: Double -> Maybe Int64 +doubleToInt64 x + | fromInteger x' == x + , x' <= toInteger (maxBound :: Int64) + , x' >= toInteger (minBound :: Int64) + = Just (fromIntegral x') + | otherwise = Nothing + where + x' = round x + +-- | Minimally escape a 'String' in accordance with RFC 7159, "7. Strings" +escapeString :: String -> String +escapeString s + | not (any needsEscape s) = s + | otherwise = escape s + where + escape [] = [] + escape (x:xs) = case x of + '\\' -> '\\':'\\':escape xs + '"' -> '\\':'"':escape xs + '\b' -> '\\':'b':escape xs + '\f' -> '\\':'f':escape xs + '\n' -> '\\':'n':escape xs + '\r' -> '\\':'r':escape xs + '\t' -> '\\':'t':escape xs + c | ord c < 0x10 -> '\\':'u':'0':'0':'0':intToDigit (ord c):escape xs + | ord c < 0x20 -> '\\':'u':'0':'0':'1':intToDigit (ord c - 0x10):escape xs + | otherwise -> c : escape xs + + -- unescaped = %x20-21 / %x23-5B / %x5D-10FFFF + needsEscape c = ord c < 0x20 || c `elem` ['\\','"'] diff --git a/haddock-library/src/Documentation/Haddock/Markup.hs b/haddock-library/src/Documentation/Haddock/Markup.hs new file mode 100644 --- /dev/null +++ b/haddock-library/src/Documentation/Haddock/Markup.hs @@ -0,0 +1,65 @@ +-- | @since 1.4.5 +module Documentation.Haddock.Markup ( + markup + , idMarkup + ) where + +import Documentation.Haddock.Types + +markup :: DocMarkupH mod id a -> DocH mod id -> a +markup m DocEmpty = markupEmpty m +markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2) +markup m (DocString s) = markupString m s +markup m (DocParagraph d) = markupParagraph m (markup m d) +markup m (DocIdentifier x) = markupIdentifier m x +markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x +markup m (DocModule mod0) = markupModule m mod0 +markup m (DocWarning d) = markupWarning m (markup m d) +markup m (DocEmphasis d) = markupEmphasis m (markup m d) +markup m (DocBold d) = markupBold m (markup m d) +markup m (DocMonospaced d) = markupMonospaced m (markup m d) +markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds) +markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds) +markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds) +markup m (DocCodeBlock d) = markupCodeBlock m (markup m d) +markup m (DocHyperlink l) = markupHyperlink m l +markup m (DocAName ref) = markupAName m ref +markup m (DocPic img) = markupPic m img +markup m (DocMathInline mathjax) = markupMathInline m mathjax +markup m (DocMathDisplay mathjax) = markupMathDisplay m mathjax +markup m (DocProperty p) = markupProperty m p +markup m (DocExamples e) = markupExample m e +markup m (DocHeader (Header l t)) = markupHeader m (Header l (markup m t)) +markup m (DocTable (Table h b)) = markupTable m (Table (map (fmap (markup m)) h) (map (fmap (markup m)) b)) + +markupPair :: DocMarkupH mod id a -> (DocH mod id, DocH mod id) -> (a, a) +markupPair m (a,b) = (markup m a, markup m b) + +-- | The identity markup +idMarkup :: DocMarkupH mod id (DocH mod id) +idMarkup = Markup { + markupEmpty = DocEmpty, + markupString = DocString, + markupParagraph = DocParagraph, + markupAppend = DocAppend, + markupIdentifier = DocIdentifier, + markupIdentifierUnchecked = DocIdentifierUnchecked, + markupModule = DocModule, + markupWarning = DocWarning, + markupEmphasis = DocEmphasis, + markupBold = DocBold, + markupMonospaced = DocMonospaced, + markupUnorderedList = DocUnorderedList, + markupOrderedList = DocOrderedList, + markupDefList = DocDefList, + markupCodeBlock = DocCodeBlock, + markupHyperlink = DocHyperlink, + markupAName = DocAName, + markupPic = DocPic, + markupMathInline = DocMathInline, + markupMathDisplay = DocMathDisplay, + markupProperty = DocProperty, + markupExample = DocExamples, + markupHeader = DocHeader, + markupTable = DocTable + } diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -1,5 +1,6 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module : Documentation.Haddock.Parser -- Copyright : (c) Mateusz Kowalczyk 2013-2014, @@ -14,7 +15,7 @@ -- library, the most commonly used combination of functions is going -- to be -- --- @'toRegular' . 'parseParas'@ +-- @'toRegular' . '_doc' . 'parseParas'@ module Documentation.Haddock.Parser ( parseString, parseParas , overIdentifier, toRegular, Identifier ) where @@ -23,20 +24,47 @@ import Control.Arrow (first) import Control.Monad import qualified Data.ByteString.Char8 as BS -import Data.Char (chr, isAsciiUpper) -import Data.List (stripPrefix, intercalate, unfoldr) -import Data.Maybe (fromMaybe) +import Data.Char (chr, isUpper, isAlpha, isAlphaNum) +import Data.List (stripPrefix, intercalate, unfoldr, elemIndex) +import Data.Maybe (fromMaybe, mapMaybe) import Data.Monoid +import qualified Data.Set as Set import Documentation.Haddock.Doc import Documentation.Haddock.Parser.Monad hiding (take, endOfLine) import Documentation.Haddock.Parser.Util import Documentation.Haddock.Types import Documentation.Haddock.Utf8 import Prelude hiding (takeWhile) +import qualified Prelude as P +#if MIN_VERSION_base(4,9,0) +import Text.Read.Lex (isSymbolChar) +#else +import Data.Char (GeneralCategory (..), + generalCategory) +#endif + -- $setup -- >>> :set -XOverloadedStrings +#if !MIN_VERSION_base(4,9,0) +-- inlined from base-4.10.0.0 +isSymbolChar :: Char -> Bool +isSymbolChar c = not (isPuncChar c) && case generalCategory c of + MathSymbol -> True + CurrencySymbol -> True + ModifierSymbol -> True + OtherSymbol -> True + DashPunctuation -> True + OtherPunctuation -> not (c `elem` ("'\"" :: String)) + ConnectorPunctuation -> c /= '_' + _ -> False + where + -- | The @special@ character class as defined in the Haskell Report. + isPuncChar :: Char -> Bool + isPuncChar = (`elem` (",;()[]{}`" :: String)) +#endif + -- | Identifier string surrounded with opening and closing quotes/backticks. type Identifier = (Char, String, Char) @@ -79,6 +107,7 @@ g (DocProperty x) = DocProperty x g (DocExamples x) = DocExamples x g (DocHeader (Header l x)) = DocHeader . Header l $ g x + g (DocTable (Table h b)) = DocTable (Table (map (fmap g) h) (map (fmap g) b)) parse :: Parser a -> BS.ByteString -> (ParserState, a) parse p = either err id . parseOnly (p <* endOfInput) @@ -202,21 +231,20 @@ monospace = DocMonospaced . parseStringBS <$> ("@" *> takeWhile1_ (/= '@') <* "@") --- | Module names: we try our reasonable best to only allow valid --- Haskell module names, with caveat about not matching on technically --- valid unicode symbols. +-- | Module names. +-- +-- Note that we allow '#' and '\' to support anchors (old style anchors are of +-- the form "SomeModule\#anchor"). moduleName :: Parser (DocH mod a) moduleName = DocModule <$> (char '"' *> modid <* char '"') where modid = intercalate "." <$> conid `sepBy1` "." conid = (:) - <$> satisfy isAsciiUpper - -- NOTE: According to Haskell 2010 we should actually only - -- accept {small | large | digit | ' } here. But as we can't - -- match on unicode characters, this is currently not possible. - -- Note that we allow ‘#’ to suport anchors. - <*> (decodeUtf8 <$> takeWhile (notInClass " .&[{}(=*)+]!|@/;,^?\"\n")) + <$> satisfyUnicode (\c -> isAlpha c && isUpper c) + <*> many (satisfyUnicode conChar <|> char '\\' <|> char '#') + conChar c = isAlphaNum c || c == '_' + -- | Picture parser, surrounded by \<\< and \>\>. It's possible to specify -- a title for the picture. -- @@ -251,7 +279,7 @@ -- | Paragraph parser, called by 'parseParas'. paragraph :: Parser (DocH mod Identifier) -paragraph = examples <|> do +paragraph = examples <|> table <|> do indent <- takeIndent choice [ since @@ -266,6 +294,193 @@ , docParagraph <$> textParagraph ] +-- | Provides support for grid tables. +-- +-- Tables are composed by an optional header and body. The header is composed by +-- a single row. The body is composed by a non-empty list of rows. +-- +-- Example table with header: +-- +-- > +----------+----------+ +-- > | /32bit/ | 64bit | +-- > +==========+==========+ +-- > | 0x0000 | @0x0000@ | +-- > +----------+----------+ +-- +-- Algorithms loosely follows ideas in +-- http://docutils.sourceforge.net/docutils/parsers/rst/tableparser.py +-- +table :: Parser (DocH mod Identifier) +table = do + -- first we parse the first row, which determines the width of the table + firstRow <- parseFirstRow + let len = BS.length firstRow + + -- then we parse all consequtive rows starting and ending with + or |, + -- of the width `len`. + restRows <- many (parseRestRows len) + + -- Now we gathered the table block, the next step is to split the block + -- into cells. + DocTable <$> tableStepTwo len (firstRow : restRows) + where + parseFirstRow :: Parser BS.ByteString + parseFirstRow = do + skipHorizontalSpace + -- upper-left corner is + + c <- char '+' + cs <- many1 (char '-' <|> char '+') + + -- upper right corner is + too + guard (last cs == '+') + + -- trailing space + skipHorizontalSpace + _ <- char '\n' + + return (BS.cons c $ BS.pack cs) + + parseRestRows :: Int -> Parser BS.ByteString + parseRestRows l = do + skipHorizontalSpace + + c <- char '|' <|> char '+' + bs <- scan (l - 2) predicate + c2 <- char '|' <|> char '+' + + -- trailing space + skipHorizontalSpace + _ <- char '\n' + + return (BS.cons c (BS.snoc bs c2)) + where + predicate n c + | n <= 0 = Nothing + | c == '\n' = Nothing + | otherwise = Just (n - 1) + +-- Second step searchs for row of '+' and '=' characters, records it's index +-- and changes to '=' to '-'. +tableStepTwo + :: Int -- ^ width + -> [BS.ByteString] -- ^ rows + -> Parser (Table (DocH mod Identifier)) +tableStepTwo width = go 0 [] where + go _ left [] = tableStepThree width (reverse left) Nothing + go n left (r : rs) + | BS.all (`elem` ['+', '=']) r = + tableStepThree width (reverse left ++ r' : rs) (Just n) + | otherwise = + go (n + 1) (r : left) rs + where + r' = BS.map (\c -> if c == '=' then '-' else c) r + +-- Third step recognises cells in the table area, returning a list of TC, cells. +tableStepThree + :: Int -- ^ width + -> [BS.ByteString] -- ^ rows + -> Maybe Int -- ^ index of header separator + -> Parser (Table (DocH mod Identifier)) +tableStepThree width rs hdrIndex = do + cells <- loop (Set.singleton (0, 0)) + tableStepFour rs hdrIndex cells + where + height = length rs + + loop :: Set.Set (Int, Int) -> Parser [TC] + loop queue = case Set.minView queue of + Nothing -> return [] + Just ((y, x), queue') + | y + 1 >= height || x + 1 >= width -> loop queue' + | otherwise -> case scanRight x y of + Nothing -> loop queue' + Just (x2, y2) -> do + let tc = TC y x y2 x2 + fmap (tc :) $ loop $ queue' `Set.union` Set.fromList + [(y, x2), (y2, x), (y2, x2)] + + -- scan right looking for +, then try scan down + -- + -- do we need to record + saw on the way left and down? + scanRight :: Int -> Int -> Maybe (Int, Int) + scanRight x y = go (x + 1) where + bs = rs !! y + go x' | x' >= width = fail "overflow right " + | BS.index bs x' == '+' = scanDown x y x' <|> go (x' + 1) + | BS.index bs x' == '-' = go (x' + 1) + | otherwise = fail $ "not a border (right) " ++ show (x,y,x') + + -- scan down looking for + + scanDown :: Int -> Int -> Int -> Maybe (Int, Int) + scanDown x y x2 = go (y + 1) where + go y' | y' >= height = fail "overflow down" + | BS.index (rs !! y') x2 == '+' = scanLeft x y x2 y' <|> go (y' + 1) + | BS.index (rs !! y') x2 == '|' = go (y' + 1) + | otherwise = fail $ "not a border (down) " ++ show (x,y,x2,y') + + -- check that at y2 x..x2 characters are '+' or '-' + scanLeft :: Int -> Int -> Int -> Int -> Maybe (Int, Int) + scanLeft x y x2 y2 + | all (\x' -> BS.index bs x' `elem` ['+', '-']) [x..x2] = scanUp x y x2 y2 + | otherwise = fail $ "not a border (left) " ++ show (x,y,x2,y2) + where + bs = rs !! y2 + + -- check that at y2 x..x2 characters are '+' or '-' + scanUp :: Int -> Int -> Int -> Int -> Maybe (Int, Int) + scanUp x y x2 y2 + | all (\y' -> BS.index (rs !! y') x `elem` ['+', '|']) [y..y2] = return (x2, y2) + | otherwise = fail $ "not a border (up) " ++ show (x,y,x2,y2) + +-- | table cell: top left bottom right +data TC = TC !Int !Int !Int !Int + deriving Show + +tcXS :: TC -> [Int] +tcXS (TC _ x _ x2) = [x, x2] + +tcYS :: TC -> [Int] +tcYS (TC y _ y2 _) = [y, y2] + +-- | Fourth step. Given the locations of cells, forms 'Table' structure. +tableStepFour :: [BS.ByteString] -> Maybe Int -> [TC] -> Parser (Table (DocH mod Identifier)) +tableStepFour rs hdrIndex cells = case hdrIndex of + Nothing -> return $ Table [] rowsDoc + Just i -> case elemIndex i yTabStops of + Nothing -> return $ Table [] rowsDoc + Just i' -> return $ uncurry Table $ splitAt i' rowsDoc + where + xTabStops = sortNub $ concatMap tcXS cells + yTabStops = sortNub $ concatMap tcYS cells + + sortNub :: Ord a => [a] -> [a] + sortNub = Set.toList . Set.fromList + + init' :: [a] -> [a] + init' [] = [] + init' [_] = [] + init' (x : xs) = x : init' xs + + rowsDoc = (fmap . fmap) parseStringBS rows + + rows = map makeRow (init' yTabStops) + where + makeRow y = TableRow $ mapMaybe (makeCell y) cells + makeCell y (TC y' x y2 x2) + | y /= y' = Nothing + | otherwise = Just $ TableCell xts yts (extract (x + 1) (y + 1) (x2 - 1) (y2 - 1)) + where + xts = length $ P.takeWhile (< x2) $ dropWhile (< x) xTabStops + yts = length $ P.takeWhile (< y2) $ dropWhile (< y) yTabStops + + -- extract cell contents given boundaries + extract :: Int -> Int -> Int -> Int -> BS.ByteString + extract x y x2 y2 = BS.intercalate "\n" + [ BS.take (x2 - x + 1) $ BS.drop x $ rs !! y' + | y' <- [y .. y2] + ] + +-- | Parse \@since annotations. since :: Parser (DocH mod a) since = ("@since " *> version <* skipHorizontalSpace <* endOfLine) >>= setSince >> return DocEmpty where @@ -338,7 +553,7 @@ definitionList indent = DocDefList <$> p where p = do - label <- "[" *> (parseStringBS <$> takeWhile1 (notInClass "]\n")) <* ("]" <* optional ":") + label <- "[" *> (parseStringBS <$> takeWhile1_ (notInClass "]\n")) <* ("]" <* optional ":") c <- takeLine (cs, items) <- more indent p let contents = parseString . dropNLs . unlines $ c : cs @@ -570,25 +785,15 @@ parseValid :: Parser String parseValid = p some where - idChar = - satisfy (\c -> isAlpha_ascii c - || isDigit c - -- N.B. '-' is placed first otherwise attoparsec thinks - -- it belongs to a character class - || inClass "-_.!#$%&*+/<=>?@\\|~:^" c) + idChar = satisfyUnicode (\c -> isAlphaNum c || isSymbolChar c || c == '_') p p' = do - vs' <- p' $ utf8String "⋆" <|> return <$> idChar - let vs = concat vs' + vs <- p' idChar c <- peekChar' case c of '`' -> return vs '\'' -> (\x -> vs ++ "'" ++ x) <$> ("'" *> p many') <|> return vs _ -> fail "outofvalid" - --- | Parses UTF8 strings from ByteString streams. -utf8String :: String -> Parser String -utf8String x = decodeUtf8 <$> string (encodeUtf8 x) -- | Parses identifiers with help of 'parseValid'. Asks GHC for -- 'String' from the string it deems valid. diff --git a/haddock-library/src/Documentation/Haddock/Parser/Monad.hs b/haddock-library/src/Documentation/Haddock/Parser/Monad.hs --- a/haddock-library/src/Documentation/Haddock/Parser/Monad.hs +++ b/haddock-library/src/Documentation/Haddock/Parser/Monad.hs @@ -31,9 +31,10 @@ import Control.Applicative import Control.Monad import Data.String -import Data.ByteString (ByteString) +import Data.ByteString (ByteString, length) import qualified Data.ByteString.Lazy as LB import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec +import qualified Data.Attoparsec.Combinator as Attoparsec import Control.Monad.Trans.State import qualified Control.Monad.Trans.Class as Trans import Data.Word @@ -41,6 +42,7 @@ import Data.Tuple import Documentation.Haddock.Types (Version) +import Documentation.Haddock.Utf8 (encodeUtf8, decodeUtf8) newtype ParserState = ParserState { parserStateSince :: Maybe Version @@ -72,6 +74,25 @@ char8 :: Char -> Parser Word8 char8 = lift . Attoparsec.char8 + +-- | Peek a unicode character and return the number of bytes that it took up +peekUnicode :: Parser (Char, Int) +peekUnicode = lift $ Attoparsec.lookAhead $ do + + -- attoparsec's take fails on shorter inputs rather than truncate + bs <- Attoparsec.choice (map Attoparsec.take [4,3,2,1]) + + let c = head . decodeUtf8 $ bs + n = Data.ByteString.length . encodeUtf8 $ [c] + pure (c, fromIntegral n) + +-- | Like 'satisfy', but consuming a unicode character +satisfyUnicode :: (Char -> Bool) -> Parser Char +satisfyUnicode predicate = do + (c,n) <- peekUnicode + if predicate c + then Documentation.Haddock.Parser.Monad.take n *> pure c + else fail "satsifyUnicode" anyChar :: Parser Char anyChar = lift Attoparsec.anyChar diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs --- a/haddock-library/src/Documentation/Haddock/Types.hs +++ b/haddock-library/src/Documentation/Haddock/Types.hs @@ -15,10 +15,21 @@ module Documentation.Haddock.Types where #if !MIN_VERSION_base(4,8,0) +import Control.Applicative import Data.Foldable import Data.Traversable #endif +#if MIN_VERSION_base(4,8,0) +import Control.Arrow ((***)) +import Data.Bifunctor +#endif + +#if MIN_VERSION_base(4,10,0) +import Data.Bifoldable +import Data.Bitraversable +#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 @@ -30,9 +41,25 @@ , _doc :: DocH mod id } deriving (Eq, Show, Functor, Foldable, Traversable) +#if MIN_VERSION_base(4,8,0) +instance Bifunctor MetaDoc where + bimap f g (MetaDoc m d) = MetaDoc m (bimap f g d) +#endif + +#if MIN_VERSION_base(4,10,0) +instance Bifoldable MetaDoc where + bifoldr f g z d = bifoldr f g z (_doc d) + +instance Bitraversable MetaDoc where + bitraverse f g (MetaDoc m d) = MetaDoc m <$> bitraverse f g d +#endif + 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 @@ -55,6 +82,21 @@ , exampleResult :: [String] } deriving (Eq, Show) +data TableCell id = TableCell + { tableCellColspan :: Int + , tableCellRowspan :: Int + , tableCellContents :: id + } deriving (Eq, Show, Functor, Foldable, Traversable) + +newtype TableRow id = TableRow + { tableRowCells :: [TableCell id] + } deriving (Eq, Show, Functor, Foldable, Traversable) + +data Table id = Table + { tableHeaderRows :: [TableRow id] + , tableBodyRows :: [TableRow id] + } deriving (Eq, Show, Functor, Foldable, Traversable) + data DocH mod id = DocEmpty | DocAppend (DocH mod id) (DocH mod id) @@ -79,4 +121,113 @@ | DocProperty String | DocExamples [Example] | DocHeader (Header (DocH mod id)) + | DocTable (Table (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)) + bimap f g (DocTable (Table header body)) = DocTable (Table (map (fmap (bimap f g)) header) (map (fmap (bimap f g)) body)) +#endif + +#if MIN_VERSION_base(4,10,0) +instance Bifoldable DocH where + bifoldr f g z (DocAppend docA docB) = bifoldr f g (bifoldr f g z docA) docB + bifoldr f g z (DocParagraph doc) = bifoldr f g z doc + bifoldr _ g z (DocIdentifier i) = g i z + bifoldr f _ z (DocIdentifierUnchecked m) = f m z + bifoldr f g z (DocWarning doc) = bifoldr f g z doc + bifoldr f g z (DocEmphasis doc) = bifoldr f g z doc + bifoldr f g z (DocMonospaced doc) = bifoldr f g z doc + bifoldr f g z (DocBold doc) = bifoldr f g z doc + bifoldr f g z (DocUnorderedList docs) = foldr (flip (bifoldr f g)) z docs + bifoldr f g z (DocOrderedList docs) = foldr (flip (bifoldr f g)) z docs + bifoldr f g z (DocDefList docs) = foldr (\(l, r) acc -> bifoldr f g (bifoldr f g acc l) r) z docs + bifoldr f g z (DocCodeBlock doc) = bifoldr f g z doc + bifoldr f g z (DocHeader (Header _ title)) = bifoldr f g z title + bifoldr f g z (DocTable (Table header body)) = foldr (\r acc -> foldr (flip (bifoldr f g)) acc r) (foldr (\r acc -> foldr (flip (bifoldr f g)) acc r) z body) header + bifoldr _ _ z _ = z + +instance Bitraversable DocH where + bitraverse _ _ DocEmpty = pure DocEmpty + bitraverse f g (DocAppend docA docB) = DocAppend <$> bitraverse f g docA <*> bitraverse f g docB + bitraverse _ _ (DocString s) = pure (DocString s) + bitraverse f g (DocParagraph doc) = DocParagraph <$> bitraverse f g doc + bitraverse _ g (DocIdentifier i) = DocIdentifier <$> g i + bitraverse f _ (DocIdentifierUnchecked m) = DocIdentifierUnchecked <$> f m + bitraverse _ _ (DocModule s) = pure (DocModule s) + bitraverse f g (DocWarning doc) = DocWarning <$> bitraverse f g doc + bitraverse f g (DocEmphasis doc) = DocEmphasis <$> bitraverse f g doc + bitraverse f g (DocMonospaced doc) = DocMonospaced <$> bitraverse f g doc + bitraverse f g (DocBold doc) = DocBold <$> bitraverse f g doc + bitraverse f g (DocUnorderedList docs) = DocUnorderedList <$> traverse (bitraverse f g) docs + bitraverse f g (DocOrderedList docs) = DocOrderedList <$> traverse (bitraverse f g) docs + bitraverse f g (DocDefList docs) = DocDefList <$> traverse (bitraverse (bitraverse f g) (bitraverse f g)) docs + bitraverse f g (DocCodeBlock doc) = DocCodeBlock <$> bitraverse f g doc + bitraverse _ _ (DocHyperlink hyperlink) = pure (DocHyperlink hyperlink) + bitraverse _ _ (DocPic picture) = pure (DocPic picture) + bitraverse _ _ (DocMathInline s) = pure (DocMathInline s) + bitraverse _ _ (DocMathDisplay s) = pure (DocMathDisplay s) + bitraverse _ _ (DocAName s) = pure (DocAName s) + bitraverse _ _ (DocProperty s) = pure (DocProperty s) + bitraverse _ _ (DocExamples examples) = pure (DocExamples examples) + bitraverse f g (DocHeader (Header level title)) = (DocHeader . Header level) <$> bitraverse f g title + bitraverse f g (DocTable (Table header body)) = (\h b -> DocTable (Table h b)) <$> traverse (traverse (bitraverse f g)) header <*> traverse (traverse (bitraverse f g)) body +#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). +-- Use 'Documentation.Haddock.Markup.markup' to apply a 'DocMarkupH' to +-- a 'DocH'. +-- +-- @since 1.4.5 +-- +data DocMarkupH mod id a = Markup + { markupEmpty :: a + , markupString :: String -> a + , markupParagraph :: a -> a + , markupAppend :: a -> a -> a + , markupIdentifier :: id -> a + , markupIdentifierUnchecked :: mod -> a + , markupModule :: String -> a + , markupWarning :: a -> a + , markupEmphasis :: a -> a + , markupBold :: a -> a + , markupMonospaced :: a -> a + , markupUnorderedList :: [a] -> a + , markupOrderedList :: [a] -> a + , markupDefList :: [(a,a)] -> a + , markupCodeBlock :: a -> a + , markupHyperlink :: Hyperlink -> a + , markupAName :: String -> a + , markupPic :: Picture -> a + , markupMathInline :: String -> a + , markupMathDisplay :: String -> a + , markupProperty :: String -> a + , markupExample :: [Example] -> a + , markupHeader :: Header a -> a + , markupTable :: Table a -> a + } diff --git a/haddock.cabal b/haddock.cabal --- a/haddock.cabal +++ b/haddock.cabal @@ -1,5 +1,6 @@ +cabal-version: 2.0 name: haddock -version: 2.18.1 +version: 2.19.0.1 synopsis: A documentation-generation tool for Haskell libraries description: This is Haddock, a tool for automatically generating documentation @@ -32,8 +33,7 @@ copyright: (c) Simon Marlow, David Waern category: Documentation build-type: Simple -cabal-version: >= 2.0 -tested-with: GHC==8.2.* +tested-with: GHC==8.4.* extra-source-files: CHANGES.md @@ -65,7 +65,7 @@ -- haddock typically only supports a single GHC major version build-depends: - base >= 4.3 && < 4.11 + base ^>= 4.11.0 if flag(in-ghc-tree) hs-source-dirs: haddock-api/src, haddock-library/vendor/attoparsec-0.13.1.0, haddock-library/src cpp-options: -DIN_GHC_TREE @@ -78,7 +78,7 @@ xhtml >= 3000.2 && < 3000.3, Cabal >= 1.10, ghc-boot, - ghc == 8.2.*, + ghc == 8.4.*, bytestring, transformers @@ -102,10 +102,12 @@ Data.Attoparsec.Number Documentation.Haddock.Utf8 Documentation.Haddock.Parser.Util + Documentation.Haddock.Markup Documentation.Haddock Haddock Haddock.Interface + Haddock.Interface.Json Haddock.Interface.Rename Haddock.Interface.Create Haddock.Interface.AttachInstances @@ -114,10 +116,12 @@ Haddock.Interface.Specialize Haddock.Parser Haddock.Utils + Haddock.Utils.Json Haddock.Backends.Xhtml Haddock.Backends.Xhtml.Decl Haddock.Backends.Xhtml.DocMarkup Haddock.Backends.Xhtml.Layout + Haddock.Backends.Xhtml.Meta Haddock.Backends.Xhtml.Names Haddock.Backends.Xhtml.Themes Haddock.Backends.Xhtml.Types @@ -140,10 +144,16 @@ Haddock.GhcUtils Haddock.Syb Haddock.Convert + + Paths_haddock + + autogen-modules: + Paths_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.18.1 + build-depends: haddock-api == 2.19.0.1 other-modules: ResponseFile diff --git a/html-test/Main.hs b/html-test/Main.hs --- a/html-test/Main.hs +++ b/html-test/Main.hs @@ -47,7 +47,22 @@ preserveLinksModules :: [String] preserveLinksModules = ["Bug253"] +ingoredTests :: [FilePath] +ingoredTests = + [ + -- Currently some declarations are exported twice + -- we need a reliable way to deduplicate here. + -- Happens since PR #688. + "B" + -- ignore-exports flag broke with PR #688. We use + -- the Avails calculated by GHC now. Probably + -- requires a change to GHC to "ignore" a modules + -- export list reliably. + , "IgnoreExports" + ] + checkIgnore :: FilePath -> Bool +checkIgnore file | takeBaseName file `elem` ingoredTests = True checkIgnore file@(c:_) | takeExtension file == ".html" && isUpper c = False checkIgnore _ = True diff --git a/html-test/ref/A.html b/html-test/ref/A.html --- a/html-test/ref/A.html +++ b/html-test/ref/A.html @@ -4,15 +4,11 @@ />A
A

Synopsis

other :: :: Int #

test2 :: :: Bool #

reExport :: :: Int #B

B

Synopsis

Bold
Bold

Synopsis

Synopsis

Bug1
Bug1

Synopsis

  • data T = T
Synopsis
  • data T = T

We should have different anchors for constructors and types/classes. This hyperlink should point to the type constructor by default: T.

Bug195
Bug2

x :: :: A #Bug201

Bug201

Synopsis

  • f :: ()
    • Synopsis
    • g :: ()
    f :: ()
  • g :: ()

Bug253

Synopsis

Synopsis

This link should generate #v anchor: fakeFakeFake

Bug26

Synopsis

  • f :: ()
  • g :: ()
    • Synopsis
    • class C a where
        f :: ()
      • g :: ()
      • class C a where

    Minimal complete definition

    c_f

    Instances

    Instances
    C ()
    Instance details

    Methods

    #

    Bug280

    x :: [ :: [Char] #Bug294

    #

    Instances

    Instances
    data DP A
    Instance details
    data DP A = ProblemCtor' A
    data TP TP A
    Instance details
    data TP TP A = ProblemCtor A

    problemField :: TO :: TO A -> -> A #

    problemField' :: DO :: DO A -> -> A #

    gadtField :: ({..} -> GADT :: ({..} -> GADT A) -> ) -> A #

    data family TP t :: * #

    Instances
    data TP A #
    Instance details
    data TP A = ProblemCtor A

    data family DP t :: t :: * #

    Instances

    Instances
    data DP A
    Instance details
    data DP A = ProblemCtor' A

    data family TO' t :: * #

    Instances
    data TO' a #
    Instance details
    data TO' a = PolyCtor
    Bug298
    Bug298

    Synopsis

    Links to <^> and ^>, <^ and ⋆^.

    Bug3
    Bug3

    Synopsis

    Synopsis

    foo :: :: Int #Bug308

    Bug308

    Synopsis

    • f :: ()
      • Synopsis
      • g :: ()
      f :: ()
    • g :: ()

    Bug308CrossModule
    Bug308CrossModule

    Synopsis

    • h :: ()
    Synopsis
    • h :: ()

    Bug310
    Bug310

    Synopsis

    • type family (a :: Nat) + (b :: Nat) :: Nat where ...
    Synopsis
    • type family (a :: Nat) + (b :: Nat) :: Nat where ...

    type family (a :: (a :: Nat) + (b :: (b :: Nat) :: ) :: Nat where ...

    Addition of type-level naturals.

    Since: 4.7.0.0

    Bug313

    Synopsis

    • a :: a
      • Synopsis
      • b :: a
      a :: a
    • b :: a

    Bug335
    Bug335

    Synopsis

    • f :: ()
      • Synopsis
      • g :: ()
      f :: ()
    • g :: ()

    #

    ExF:

    Expand

    abc

    #

    ExG:

    Expand
    >>> Under ex

    foo

    Out of Ex

    Bug387

    Synopsis

    Section1

    Section1

    test1 :: :: Int #

    Section2

    Section2

    test2 :: :: Int #Bug4

    Bug4

    Synopsis

    Synopsis

    foo :: :: Int #Bug458

    Safe HaskellSafe

    Bug458

    Synopsis

    Documentation

    (⊆) :: () -> () -> () #

    See the defn of ⊆.

    diff --git a/html-test/ref/Bug546.html b/html-test/ref/Bug546.html new file mode 100644 --- /dev/null +++ b/html-test/ref/Bug546.html @@ -0,0 +1,273 @@ +Bug546
    Safe HaskellSafe

    Bug546

    Synopsis

    Documentation

    x :: Integer #

    Test:

    [code with square \ brackets]
    lorem ipsum

    compile :: String -> String #

    [..]
    Matches any of the enclosed characters. Ranges of characters can + be specified by separating the endpoints with a '-'. '-' or + ']' can be matched by including them as the first character(s) + in the list. Never matches path separators: [/] matches + nothing at all. Named character classes can also be matched: + [:x:] within [] specifies the class named x, which matches + certain predefined characters. See below for a full list.
    [^..] or [!..]
    Like [..], but matches any character not listed. + Note that [^-x] is not the inverse of [-x], but + the range [^-x].
    <m-n>
    Matches any integer in the range m to n, inclusive. The range may + be open-ended by leaving out either number: "<->", for + instance, matches any integer.
    **/
    Matches any number of characters, including path separators, + excluding the empty string.

    Supported character classes:

    [:alnum:]
    Equivalent to "0-9A-Za-z".
    [:alpha:]
    Equivalent to "A-Za-z".
    [:blank:]
    Equivalent to "\t ".
    [:cntrl:]
    Equivalent to "\0-\x1f\x7f".
    [:digit:]
    Equivalent to "0-9".
    [:graph:]
    Equivalent to "!-~".
    [:lower:]
    Equivalent to "a-z".
    [:print:]
    Equivalent to " -~".
    [:punct:]
    Equivalent to "!-/:-@[-`{-~".
    [:space:]
    Equivalent to "\t-\r ".
    [:upper:]
    Equivalent to "A-Z".
    [:xdigit:]
    Equivalent to "0-9A-Fa-f".
    diff --git a/html-test/ref/Bug548.html b/html-test/ref/Bug548.html new file mode 100644 --- /dev/null +++ b/html-test/ref/Bug548.html @@ -0,0 +1,586 @@ +Bug548
    Safe HaskellSafe

    Bug548

    Documentation

    newtype WrappedArrow (a :: * -> * -> *) b c #

    Constructors

    WrapArrow

    Fields

    Instances
    Generic1 (WrappedArrow a b :: * -> *)
    Instance details

    Associated Types

    type Rep1 (WrappedArrow a b) :: k -> * #

    Methods

    from1 :: WrappedArrow a b a0 -> Rep1 (WrappedArrow a b) a0 #

    to1 :: Rep1 (WrappedArrow a b) a0 -> WrappedArrow a b a0 #

    Arrow a => Functor (WrappedArrow a b)

    Since: 2.1

    Instance details

    Methods

    fmap :: (a0 -> b0) -> WrappedArrow a b a0 -> WrappedArrow a b b0 #

    (<$) :: a0 -> WrappedArrow a b b0 -> WrappedArrow a b a0 #

    Arrow a => Applicative (WrappedArrow a b)

    Since: 2.1

    Instance details

    Methods

    pure :: a0 -> WrappedArrow a b a0 #

    (<*>) :: WrappedArrow a b (a0 -> b0) -> WrappedArrow a b a0 -> WrappedArrow a b b0 #

    liftA2 :: (a0 -> b0 -> c) -> WrappedArrow a b a0 -> WrappedArrow a b b0 -> WrappedArrow a b c #

    (*>) :: WrappedArrow a b a0 -> WrappedArrow a b b0 -> WrappedArrow a b b0 #

    (<*) :: WrappedArrow a b a0 -> WrappedArrow a b b0 -> WrappedArrow a b a0 #

    (ArrowZero a, ArrowPlus a) => Alternative (WrappedArrow a b)

    Since: 2.1

    Instance details

    Methods

    empty :: WrappedArrow a b a0 #

    (<|>) :: WrappedArrow a b a0 -> WrappedArrow a b a0 -> WrappedArrow a b a0 #

    some :: WrappedArrow a b a0 -> WrappedArrow a b [a0] #

    many :: WrappedArrow a b a0 -> WrappedArrow a b [a0] #

    Generic (WrappedArrow a b c)
    Instance details

    Associated Types

    type Rep (WrappedArrow a b c) :: * -> * #

    Methods

    from :: WrappedArrow a b c -> Rep (WrappedArrow a b c) x #

    to :: Rep (WrappedArrow a b c) x -> WrappedArrow a b c #

    type Rep1 (WrappedArrow a b :: * -> *)
    Instance details
    type Rep1 (WrappedArrow a b :: * -> *) = D1 (MetaData "WrappedArrow" "Control.Applicative" "base" True) (C1 (MetaCons "WrapArrow" PrefixI True) (S1 (MetaSel (Just "unwrapArrow") NoSourceUnpackedness NoSourceStrictness DecidedLazy) (Rec1 (a b))))
    type Rep (WrappedArrow a b c)
    Instance details
    type Rep (WrappedArrow a b c) = D1 (MetaData "WrappedArrow" "Control.Applicative" "base" True) (C1 (MetaCons "WrapArrow" PrefixI True) (S1 (MetaSel (Just "unwrapArrow") NoSourceUnpackedness NoSourceStrictness DecidedLazy) (Rec0 (a b c))))
    diff --git a/html-test/ref/Bug6.html b/html-test/ref/Bug6.html --- a/html-test/ref/Bug6.html +++ b/html-test/ref/Bug6.html @@ -4,15 +4,11 @@ />Bug6

    Synopsis

    A IntB Int

    Fields

    b :: B -> Int #

    data c1 :: :: Int

    c2 :: :: Int
    D Int IntE IntBug613
    Safe HaskellSafe

    Bug613

    Synopsis

    Documentation

    class Functor f where #

    Minimal complete definition

    fmap

    Methods

    fmap :: (a -> b) -> f a -> f b #

    Instances
    Functor (Either a) #
    Instance details

    Methods

    fmap :: (a0 -> b) -> Either a a0 -> Either a b #

    Functor (ThreeVars a0 a) #
    Instance details

    Methods

    fmap :: (a1 -> b) -> ThreeVars a0 a a1 -> ThreeVars a0 a b #

    data ThreeVars a0 a b #

    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

    Constructors

    ThreeVars a b
    Instances
    Functor (ThreeVars a0 a) #
    Instance details

    Methods

    fmap :: (a1 -> b) -> ThreeVars a0 a a1 -> ThreeVars a0 a b #

    diff --git a/html-test/ref/Bug647.html b/html-test/ref/Bug647.html --- a/html-test/ref/Bug647.html +++ b/html-test/ref/Bug647.html @@ -4,15 +4,11 @@ />Bug647

    Minimal complete definition

    f

    Bug679
    Safe HaskellNone

    Bug679

    Documentation

    data Bar a #

    Constructors

    Bar
    Instances
    Foo (Bar a) #
    Instance details

    Methods

    foo :: Bar a -> Bar a #

    class Foo a where #

    Minimal complete definition

    foo

    Methods

    foo :: a -> a #

    Instances
    Foo (Bar a) #
    Instance details

    Methods

    foo :: Bar a -> Bar a #

    diff --git a/html-test/ref/Bug7.html b/html-test/ref/Bug7.html --- a/html-test/ref/Bug7.html +++ b/html-test/ref/Bug7.html @@ -4,15 +4,11 @@ />Bug7

    Synopsis

    Instances

    Instances
    Bar Foo Foo
    Instance details
    The Bar class

    Instances

    Instances
    Bar Foo Foo
    Instance details
    Bug8
    Type ( (Typ, [, [Typ])TFree ( (Typ, [, [Typ])

    (-->) :: p1 -> p2 -> :: p1 -> p2 -> Typ infix 9

    (--->) :: :: Foldable t0 => t0 t -> t0 => t0 t -> Typ -> -> Typ infix 9Bug85

    data Foo :: ( :: (* -> -> *) -> ) -> * -> -> * whereBar :: f x -> :: f x -> Foo f (f x)data Baz :: :: * whereBaz' :: :: BazQuux :: :: QuxBugDeprecated
    BugDeprecated

    Synopsis

    foo :: :: Int #

    bar :: :: Int #

    baz :: :: Int #

    one :: :: Int #

    two :: :: Int #

    three :: :: Int #BugExportHeadings

    Synopsis

    Two

    Two

    two :: :: Int #

    Three

    Three

    three :: :: Int #Bugs

    A a (a -> a (a -> Int)BundledPatterns
    BundledPatterns

    Synopsis

    data Vec :: :: Nat -> -> * -> -> * whereLists with their length encoded in their type
  • Vector elements have an subscript starting from 0 and ending at length - 1Nil :: :: Vec 0 apattern (:>) :: a -> :: a -> Vec n a -> n a -> Vec (n (n + 1) a infixr 5data RTree :: :: Nat -> -> * -> -> * wherepattern LR :: a -> :: a -> RTree 0 apattern BR :: :: RTree d a -> d a -> RTree d a -> d a -> RTree (d (d + 1) aBundledPatterns2
    BundledPatterns2

    Synopsis

    data Vec :: :: Nat -> -> * -> -> * whereLists with their length encoded in their type

  • Vector elements have an subscript starting from 0 and ending at length - 1pattern Empty :: Vec 0 apattern (:>) :: a -> :: a -> Vec n a -> n a -> Vec (n (n + 1) a infixr 5pattern Empty :: Vec 0 a

    • data RTree :: :: Nat -> -> * -> -> * wherepattern LR :: a -> :: a -> RTree 0 apattern BR :: :: RTree d a -> d a -> RTree d a -> d a -> RTree (d (d + 1) aConstructorPatternExport
    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) #

    diff --git a/html-test/ref/DeprecatedClass.html b/html-test/ref/DeprecatedClass.html --- a/html-test/ref/DeprecatedClass.html +++ b/html-test/ref/DeprecatedClass.html @@ -4,15 +4,11 @@ />DeprecatedClass
    DeprecatedClass

    Synopsis

    Minimal complete definition

    foo

    Minimal complete definition

    bar

    DeprecatedData
    DeprecatedData

    Synopsis

    DeprecatedFunction
    DeprecatedFunction

    Synopsis

    foo :: :: Int #

    Deprecated: use bar instead

    bar :: :: Int #DeprecatedFunction2

    DeprecatedFunction2

    Synopsis

    Synopsis

    foo :: :: Int #DeprecatedFunction3

    DeprecatedFunction3

    Synopsis

    Synopsis

    foo :: :: Integer #DeprecatedModule

    foo :: :: Int #DeprecatedModule2

    foo :: :: Int #DeprecatedNewtype

    DeprecatedNewtype

    SomeNewTypeConst StringSomeOtherNewTypeConst StringDeprecatedReExport

    Synopsis

    Synopsis

    Re-exported from an other module

    Re-exported from an other module

    foo :: :: Int #

    Deprecated: use bar instead

    some documentation for foo

    Re-exported from an other package

    Re-exported from an other package

    Not yet working, see DeprecatedRecord

    fooName :: :: String
    fooValue :: :: Int
    DeprecatedTypeFamily
    DeprecatedTypeFamily

    Synopsis

    data family SomeTypeFamily k :: k :: * -> -> * #data family SomeOtherTypeFamily k :: k :: * -> -> * #DeprecatedTypeSynonym
    DeprecatedTypeSynonym

    Synopsis

    type TypeSyn = = String #type OtherTypeSyn = = String #DuplicateRecordFields
    Examples
    Examples

    Synopsis

    Synopsis

    fib :: :: Integer -> -> Integer #

    Fibonacci number of given Integer.

    Extensions
    Extensions

    Synopsis

    Synopsis

    FunArgs
    :: :: Ord a
    => => Int
    -> -> Bool:: forall (b :: ()). d ~ (b :: ()). d ~ ()GADTRecords
    GADTRecords

    Synopsis

    		C1 :: :: H1 a bC2 :: :: Ord a => [a] -> a => [a] -> H1 a aC3 :: {..} -> :: {..} -> H1 Int Intfield :: :: Int
    		C4 :: {..} -> :: {..} -> H1 Int aHash

    Synopsis

    The HashTable type

    The HashTable type

    key should be an instance of Eq.

    Operations on HashTables

    Operations on HashTables

    new :: ( :: (Eq key, key, Hash key) => key) => Int -> -> IO ( (HashTable key val) #

    insert :: ( :: (Eq key, key, Hash key) => key -> val -> key) => key -> val -> IO () #

    lookup :: :: Hash key => key -> key => key -> IO ( (Maybe val) #

    Looks up a key in the hash table, returns Just val if the key was found, or Nothing otherwise.

    The Hash class

    The Hash class

    Minimal complete definition

    hash

    hash :: a -> :: a -> Int #hashes the value of type a into an Int

    Instances

    Instances
    Hash Float
    Instance details

    Methods

    hash :: :: Float -> -> Int #

    Hash Int
    Instance details

    Methods

    hash :: :: Int -> -> Int #

    ( (Hash a, a, Hash b) => b) => Hash (a, b)
    Instance details

    Methods

    hash :: (a, b) -> :: (a, b) -> Int #

    HiddenInstances
    HiddenInstances

    Synopsis

    Should be visible

    Instances

    Instances
    VisibleClass Int
    Instance details
    VisibleClass VisibleData
    Instance details
    Should be visible

    Instances

    HiddenInstancesB
    HiddenInstancesB

    Synopsis

    Should be visible

    Instances

    Instances
    Foo Bar
    Instance details
    Should be visible

    Instances

    Instances
    Foo Bar
    Instance details
    Hyperlinks
    Hyperlinks

    Synopsis

    Synopsis

    foo :: :: Int #IgnoreExports

    IgnoreExports

    Synopsis

    ImplicitParams

    c :: (?x :: :: (?x :: X) => ) => X #

    d :: (?x :: :: (?x :: X, ?y :: , ?y :: X) => () => (X, , X) #

    f :: ((?x :: :: ((?x :: X) => a) -> a #Instances

    Safe HaskellSafe

    Instances

    Documentation

    newtype a <~~ b #

    Constructors

    Xyzzy (b -> (a, a))

    Instances

    Foo ((<~~) a) #

    Methods

    foo :: (a <~~ Int) -> a -> a <~~ a #

    foo' :: (a <~~ (a <~~ a)) -> Int -> a <~~ (a <~~ Int) #

    class Foo f where #

    Methods

    foo :: f Int -> a -> f a #

    foo' :: f (f a) -> Int -> f (f Int) #

    Instances

    Foo [] #

    Methods

    foo :: [Int] -> a -> [a] #

    foo' :: [[a]] -> Int -> [[Int]] #

    Foo Maybe #

    Methods

    foo :: Maybe Int -> a -> Maybe a #

    foo' :: Maybe (Maybe a) -> Int -> Maybe (Maybe Int) #

    Foo (Either a) #

    Methods

    foo :: Either a Int -> a -> Either a a #

    foo' :: Either a (Either a a) -> Int -> Either a (Either a Int) #

    (Eq a, Foo f) => Foo ((,) (f a)) #

    Methods

    foo :: (f a, Int) -> a -> (f a, a) #

    foo' :: (f a, (f a, a)) -> Int -> (f a, (f a, Int)) #

    Foo ((<~~) a) #

    Methods

    foo :: (a <~~ Int) -> a -> a <~~ a #

    foo' :: (a <~~ (a <~~ a)) -> Int -> a <~~ (a <~~ Int) #

    Foo ((,,) a a) #

    Methods

    foo :: (a, a, Int) -> a -> (a, a, a) #

    foo' :: (a, a, (a, a, a)) -> Int -> (a, a, (a, a, Int)) #

    Foo (Quux a b) #

    Methods

    foo :: Quux a b Int -> a -> Quux a b a #

    foo' :: Quux a b (Quux a b a) -> Int -> Quux a b (Quux a b Int) #

    Foo ((->) LiftedRep LiftedRep a) #

    Methods

    foo :: (LiftedRep -> LiftedRep) a Int -> a -> (LiftedRep -> LiftedRep) a a #

    foo' :: (LiftedRep -> LiftedRep) a ((LiftedRep -> LiftedRep) a a) -> Int -> (LiftedRep -> LiftedRep) a ((LiftedRep -> LiftedRep) a Int) #

    class Foo f => Bar f a where #

    Methods

    bar :: f a -> f Bool -> a #

    bar' :: f (f a) -> f (f (f b)) #

    bar0 :: (f a, f a) -> (f b, f c) #

    bar1 :: (f a, f a) -> (f b, f c) #

    Instances

    Bar Maybe Bool #

    Methods

    bar :: Maybe Bool -> Maybe Bool -> Bool #

    bar' :: Maybe (Maybe Bool) -> Maybe (Maybe (Maybe b)) #

    bar0 :: (Maybe Bool, Maybe Bool) -> (Maybe b, Maybe c) #

    bar1 :: (Maybe Bool, Maybe Bool) -> (Maybe b, Maybe c) #

    Bar Maybe [a] #

    Methods

    bar :: Maybe [a] -> Maybe Bool -> [a] #

    bar' :: Maybe (Maybe [a]) -> Maybe (Maybe (Maybe b)) #

    bar0 :: (Maybe [a], Maybe [a]) -> (Maybe b, Maybe c) #

    bar1 :: (Maybe [a], Maybe [a]) -> (Maybe b, Maybe c) #

    Bar [] (a, a) #

    Methods

    bar :: [(a, a)] -> [Bool] -> (a, a) #

    bar' :: [[(a, a)]] -> [[[b]]] #

    bar0 :: ([(a, a)], [(a, a)]) -> ([b], [c]) #

    bar1 :: ([(a, a)], [(a, a)]) -> ([b], [c]) #

    Foo f => Bar (Either a) (f a) #

    Methods

    bar :: Either a (f a) -> Either a Bool -> f a #

    bar' :: Either a (Either a (f a)) -> Either a (Either a (Either a b)) #

    bar0 :: (Either a (f a), Either a (f a)) -> (Either a b, Either a c) #

    bar1 :: (Either a (f a), Either a (f a)) -> (Either a b, Either a c) #

    Foo ((,,) a b) => Bar ((,,) a b) (a, b, a) #

    Methods

    bar :: (a, b, (a, b, a)) -> (a, b, Bool) -> (a, b, a) #

    bar' :: (a, b, (a, b, (a, b, a))) -> (a, b, (a, b, (a, b, b))) #

    bar0 :: ((a, b, (a, b, a)), (a, b, (a, b, a))) -> ((a, b, b), (a, b, c)) #

    bar1 :: ((a, b, (a, b, a)), (a, b, (a, b, a))) -> ((a, b, b), (a, b, c)) #

    Bar (Quux a c) (Quux a b c) #

    Methods

    bar :: Quux a c (Quux a b c) -> Quux a c Bool -> Quux a b c #

    bar' :: Quux a c (Quux a c (Quux a b c)) -> Quux a c (Quux a c (Quux a c b)) #

    bar0 :: (Quux a c (Quux a b c), Quux a c (Quux a b c)) -> (Quux a c b, Quux a c c) #

    bar1 :: (Quux a c (Quux a b c), Quux a c (Quux a b c)) -> (Quux a c b, Quux a c c) #

    class Baz a where #

    Methods

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

    baz' :: b -> (forall b. b -> a) -> (forall b. b -> a) -> [(b, a)] #

    baz'' :: b -> (forall b. (forall b. b -> a) -> c) -> forall c. c -> b #

    Instances

    Baz [c] #

    Methods

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

    baz' :: b -> (forall b. b -> [c]) -> (forall b. b -> [c]) -> [(b, [c])] #

    baz'' :: b -> (forall b. (forall a. a -> [c]) -> c) -> forall a. a -> b #

    Baz (a -> b) #

    Methods

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

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

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

    Baz (a, b, c) #

    Methods

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

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

    baz'' :: b -> (forall d. (forall e. e -> (a, b, c)) -> c) -> forall d. d -> b #

    Baz (Quux a b c) #

    Methods

    baz :: Quux a b c -> (forall d. d -> d) -> (b, forall d. d -> Quux a b c) -> (b, c) #

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

    baz'' :: b -> (forall d. (forall e. e -> Quux a b c) -> c) -> forall d. d -> b #

    Baz (a, [b], b, a) #

    Methods

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

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

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

    data Quux a b c #

    Constructors

    Qx a
    Qux a b
    Quux a b c

    Instances

    Foo (Quux a b) #

    Methods

    foo :: Quux a b Int -> a -> Quux a b a #

    foo' :: Quux a b (Quux a b a) -> Int -> Quux a b (Quux a b Int) #

    Bar (Quux a c) (Quux a b c) #

    Methods

    bar :: Quux a c (Quux a b c) -> Quux a c Bool -> Quux a b c #

    bar' :: Quux a c (Quux a c (Quux a b c)) -> Quux a c (Quux a c (Quux a c b)) #

    bar0 :: (Quux a c (Quux a b c), Quux a c (Quux a b c)) -> (Quux a c b, Quux a c c) #

    bar1 :: (Quux a c (Quux a b c), Quux a c (Quux a b c)) -> (Quux a c b, Quux a c c) #

    Baz (Quux a b c) #

    Methods

    baz :: Quux a b c -> (forall d. d -> d) -> (b, forall d. d -> Quux a b c) -> (b, c) #

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

    baz'' :: b -> (forall d. (forall e. e -> Quux a b c) -> c) -> forall d. d -> b #

    data Thud Int (Quux a [a] c) #
    data Thud Int (Quux a [a] c)

    class Norf a b where #

    Associated Types

    type Plugh a c b #

    data Thud a c #

    Methods

    norf :: Plugh a c b -> a -> (a -> c) -> b #

    Instances

    Norf Int Bool #

    Associated Types

    type Plugh Int c Bool :: * #

    data Thud Int c :: * #

    Methods

    norf :: Plugh Int c Bool -> Int -> (Int -> c) -> Bool #

    Norf [a] [b] #

    Associated Types

    type Plugh [a] c [b] :: * #

    data Thud [a] c :: * #

    Methods

    norf :: Plugh [a] c [b] -> [a] -> ([a] -> c) -> [b] #

    Safe HaskellSafe

    Instances

    Documentation

    newtype a <~~ b #

    Constructors

    Xyzzy (b -> (a, a))
    Instances
    Foo ((<~~) a) #
    Instance details

    Methods

    foo :: (a <~~ Int) -> a0 -> a <~~ a0 #

    foo' :: (a <~~ (a <~~ a0)) -> Int -> a <~~ (a <~~ Int) #

    class Foo f where #

    Methods

    foo :: f Int -> a -> f a #

    foo' :: f (f a) -> Int -> f (f Int) #

    Instances
    Foo [] #
    Instance details

    Methods

    foo :: [Int] -> a -> [a] #

    foo' :: [[a]] -> Int -> [[Int]] #

    Foo Maybe #
    Instance details

    Methods

    foo :: Maybe Int -> a -> Maybe a #

    foo' :: Maybe (Maybe a) -> Int -> Maybe (Maybe Int) #

    Foo (Either a) #
    Instance details

    Methods

    foo :: Either a Int -> a0 -> Either a a0 #

    foo' :: Either a (Either a a0) -> Int -> Either a (Either a Int) #

    (Eq a, Foo f) => Foo ((,) (f a)) #
    Instance details

    Methods

    foo :: (f a, Int) -> a0 -> (f a, a0) #

    foo' :: (f a, (f a, a0)) -> Int -> (f a, (f a, Int)) #

    Foo ((<~~) a) #
    Instance details

    Methods

    foo :: (a <~~ Int) -> a0 -> a <~~ a0 #

    foo' :: (a <~~ (a <~~ a0)) -> Int -> a <~~ (a <~~ Int) #

    Foo ((,,) a a) #
    Instance details

    Methods

    foo :: (a, a, Int) -> a0 -> (a, a, a0) #

    foo' :: (a, a, (a, a, a0)) -> Int -> (a, a, (a, a, Int)) #

    Foo (Quux a b) #
    Instance details

    Methods

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

    foo' :: Quux a b (Quux a b a0) -> Int -> Quux a b (Quux a b Int) #

    Foo ((->) a :: * -> *) #
    Instance details

    Methods

    foo :: (a -> Int) -> a0 -> a -> a0 #

    foo' :: (a -> a -> a0) -> Int -> a -> a -> Int #

    class Foo f => Bar f a where #

    Methods

    bar :: f a -> f Bool -> a #

    bar' :: f (f a) -> f (f (f b)) #

    bar0 :: (f a, f a) -> (f b, f c) #

    bar1 :: (f a, f a) -> (f b, f c) #

    Instances
    Bar Maybe Bool #
    Instance details

    Methods

    bar :: Maybe Bool -> Maybe Bool -> Bool #

    bar' :: Maybe (Maybe Bool) -> Maybe (Maybe (Maybe b)) #

    bar0 :: (Maybe Bool, Maybe Bool) -> (Maybe b, Maybe c) #

    bar1 :: (Maybe Bool, Maybe Bool) -> (Maybe b, Maybe c) #

    Bar Maybe [a] #
    Instance details

    Methods

    bar :: Maybe [a] -> Maybe Bool -> [a] #

    bar' :: Maybe (Maybe [a]) -> Maybe (Maybe (Maybe b)) #

    bar0 :: (Maybe [a], Maybe [a]) -> (Maybe b, Maybe c) #

    bar1 :: (Maybe [a], Maybe [a]) -> (Maybe b, Maybe c) #

    Bar [] (a, a) #
    Instance details

    Methods

    bar :: [(a, a)] -> [Bool] -> (a, a) #

    bar' :: [[(a, a)]] -> [[[b]]] #

    bar0 :: ([(a, a)], [(a, a)]) -> ([b], [c]) #

    bar1 :: ([(a, a)], [(a, a)]) -> ([b], [c]) #

    Foo f => Bar (Either a) (f a) #
    Instance details

    Methods

    bar :: Either a (f a) -> Either a Bool -> f a #

    bar' :: Either a (Either a (f a)) -> Either a (Either a (Either a b)) #

    bar0 :: (Either a (f a), Either a (f a)) -> (Either a b, Either a c) #

    bar1 :: (Either a (f a), Either a (f a)) -> (Either a b, Either a c) #

    Foo ((,,) a b) => Bar ((,,) a b) (a, b, a) #
    Instance details

    Methods

    bar :: (a, b, (a, b, a)) -> (a, b, Bool) -> (a, b, a) #

    bar' :: (a, b, (a, b, (a, b, a))) -> (a, b, (a, b, (a, b, b0))) #

    bar0 :: ((a, b, (a, b, a)), (a, b, (a, b, a))) -> ((a, b, b0), (a, b, c)) #

    bar1 :: ((a, b, (a, b, a)), (a, b, (a, b, a))) -> ((a, b, b0), (a, b, c)) #

    Bar (Quux a c) (Quux a b c) #
    Instance details

    Methods

    bar :: Quux a c (Quux a b c) -> Quux a c Bool -> Quux a b c #

    bar' :: Quux a c (Quux a c (Quux a b c)) -> Quux a c (Quux a c (Quux a c b0)) #

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

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

    class Baz a where #

    Methods

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

    baz' :: b -> (forall b. b -> a) -> (forall b. b -> a) -> [(b, a)] #

    baz'' :: b -> (forall b. (forall b. b -> a) -> c) -> forall c. c -> b #

    Instances
    Baz [c] #
    Instance details

    Methods

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

    baz' :: b -> (forall b. b -> [c]) -> (forall b. b -> [c]) -> [(b, [c])] #

    baz'' :: b -> (forall b. (forall b. b -> [c]) -> c0) -> forall c1. c1 -> b #

    Baz (a -> b) #
    Instance details

    Methods

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

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

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

    Baz (a, b, c) #
    Instance details

    Methods

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

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

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

    Baz (Quux a b c) #
    Instance details

    Methods

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

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

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

    Baz (a, [b], b, a) #
    Instance details

    Methods

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

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

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

    data Quux a b c #

    Constructors

    Qx a
    Qux a b
    Quux a b c
    Instances
    Foo (Quux a b) #
    Instance details

    Methods

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

    foo' :: Quux a b (Quux a b a0) -> Int -> Quux a b (Quux a b Int) #

    Bar (Quux a c) (Quux a b c) #
    Instance details

    Methods

    bar :: Quux a c (Quux a b c) -> Quux a c Bool -> Quux a b c #

    bar' :: Quux a c (Quux a c (Quux a b c)) -> Quux a c (Quux a c (Quux a c b0)) #

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

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

    Baz (Quux a b c) #
    Instance details

    Methods

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

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

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

    data Thud Int (Quux a [a] c) #
    Instance details
    data Thud Int (Quux a [a] c)

    class Norf a b where #

    Associated Types

    type Plugh a c b #

    data Thud a c #

    Methods

    norf :: Plugh a c b -> a -> (a -> c) -> b #

    Instances
    Norf Int Bool #
    Instance details

    Associated Types

    type Plugh Int c Bool :: * #

    data Thud Int c :: * #

    Methods

    norf :: Plugh Int c Bool -> Int -> (Int -> c) -> Bool #

    Norf [a] [b] #
    Instance details

    Associated Types

    type Plugh [a] c [b] :: * #

    data Thud [a] c :: * #

    Methods

    norf :: Plugh [a] c [b] -> [a] -> ([a] -> c) -> [b] #

    Math

    Synopsis

    Synopsis

    f :: :: Integer #Minimal

    Minimal complete definition

    foo, , bar | | bar, , bat | | foo, , bat | | fooBarBat

    Minimal complete definition

    x, , y

    Minimal complete definition

    aaa, , bbb

    Minimal complete definition

    ccc, ddd

    ModuleWithWarning

    foo :: :: Int #NamedDoc

    NamedDoc

    Synopsis

      Synopsis

        Nesting
        Nesting

        Synopsis

        • d :: t
        • e :: t
        • f :: t
        • g :: t
        • h :: t
        • i :: t
        • j :: t
          • Synopsis
          • k :: t
          d :: t
        • e :: t
        • f :: t
        • g :: t
        • h :: t
        • i :: t
        • j :: t
        • k :: t

        NoLayout
        NoLayout

        Synopsis

        Synopsis

        g :: :: Int #

        the function g

        NonGreedy
        NonGreedy

        Synopsis

        • f :: a
        Synopsis
        • f :: a

        Operators

        Synopsis

        Foo `Bar` Foo infixl 3
        Foo :- Foo infixr 5(:<->) :: a -> b -> a :: a -> b -> a <-> b infixr 6

        Minimal complete definition

        (>><), , (<<>), , (**>), , (**<), , (>**), , (<**)

        type a <>< b :: b :: * infixl 2type (>-<) a b = a a b = a <-> b infixl 6OrphanInstances

        Synopsis

          Documentation

          Orphan instances

          AClass AType
          Instance details

          Methods

          aClass :: :: AType -> -> Int #

          OrphanInstancesClass

          Minimal complete definition

          aClass

          aClass :: a -> :: a -> Int #

          Instances
          AClass AType #

          This is an orphan instance.

          Instance details

          Methods

          aClass :: AType -> Int #

          OrphanInstancesType
          		AType Int

          Instances
          AClass AType #

          This is an orphan instance.

          Instance details

          Methods

          aClass :: AType -> Int #

          PR643
          PR643

          Synopsis

          Synopsis

          PR643_1
          Safe HaskellSafe

          PR643_1

          Synopsis

          Documentation

          test :: () infixr 5 #

          Some big documentation

          diff --git a/html-test/ref/PatternSyns.html b/html-test/ref/PatternSyns.html --- a/html-test/ref/PatternSyns.html +++ b/html-test/ref/PatternSyns.html @@ -4,15 +4,11 @@ />PatternSyns

          Synopsis

          Foo :: forall x. x -> x. x -> FooType x #

          Pattern synonym for Foo x

          Bar :: forall x. x -> x. x -> FooType ( (FooType x) #

          Pattern synonym for Bar x

          (:<->) :: forall x x1. x -> x1 -> ( x x1. x -> x1 -> (FooType x, x, FooType ( (FooType x1)) #

          Pattern synonym for (:<->)

          data (a :: BlubType #

          BlubType is existentially quantified

          Constructors

          Show x => BlubCtor x

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

          Pattern synonym for Blub x

          data (a :: *) ><

          Doc for (><)

          E :: forall k a (b :: k). (><) k a b k a (b :: k). a >< b #

          Pattern for Empty

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

          ((RevList a) :>data Pattern :: [ :: [*] -> ] -> * whereNil :: :: Pattern '[]Cons :: :: Maybe h -> h -> Pattern t -> t -> Pattern (h ': t)data RevPattern :: :: RevList * -> -> * whereRevNil :: :: RevPattern RNilRevCons :: :: Maybe h -> h -> RevPattern t -> t -> RevPattern (t (t :> h)data Tuple :: ( :: (*, , *) -> ) -> * whereTuple :: a -> b -> :: a -> b -> Tuple '(a, b)Properties
          Properties

          Synopsis

          Synopsis

          fib :: :: Integer -> -> Integer #

          Fibonacci number of given Integer.

          PruneWithWarning
          QuasiExpr

          		IntExpr IntegerAntiIntExpr StringBinopExpr BinOp Expr ExprAntiExpr String

          Instances

          Instances

          eval :: :: Expr -> -> Integer #

          expr :: QuasiQuoter :: QuasiQuoter #

          parseExprExp :: :: String -> Q Exp -> Q Exp #

          QuasiQuote

          val :: :: Integer #SpuriousSuperclassConstraints

          TH

          decl :: Q [Dec] :: Q [Dec] #

          TH2
          Table
          Safe HaskellSafe

          Table

          Description

          This tests the table markup

          Synopsis

          Documentation

          tableWithHeader :: a -> a #

          Table with header.

          code message description
          200 OK operation successful
          204 No Content operation successful, no body returned

          tableWithoutHeader :: a -> a #

          Table without header.

          200 OK operation successful
          204 No Content operation successful, no body returned
          404 Not Found resource not found

          fancyTable :: a -> a #

          Fancy table.

          Header row, column 1 + (header rows optional) Header 2 + Header 3 + Header 4 +
          body row 1, column 1 column 2 column 3 column 4
          tableWithHeader Cells may span columns.
          body row 3 Cells may + span rows. + \[ + f(n) = \sum_{i=1} + \]
          body row 4
          diff --git a/html-test/ref/Test.html b/html-test/ref/Test.html --- a/html-test/ref/Test.html +++ b/html-test/ref/Test.html @@ -4,2260 +4,2362 @@ />Test
          Copyright(c) Simon Marlow 2002
          LicenseBSD-style
          Maintainerlibraries@haskell.org
          Stabilityprovisional
          Portabilityportable
          Safe HaskellSafe

          Test

          Description

          This module illustrates & tests most of the features of Haddock. - Testing references from the description: T, f, g, visible.

          Synopsis

          Type declarations

          Data types

          data T a b #

          This comment applies to the following declaration - and it continues until the next non-comment line

          Constructors

          A Int (Maybe Float)

          This comment describes the A constructor

          B (T a b, T Int Float)

          This comment describes the B constructor

          data T2 a b #

          An abstract data declaration

          data T3 a b #

          A data declaration with no documentation annotations on the constructors

          Constructors

          A1 a
          B1 b

          data T4 a b #

          Constructors

          A2 a
          B2 b

          data T5 a b #

          Constructors

          A3 a

          documents A3

          B3 b

          documents B3

          data T6 #

          Testing alternative comment styles

          Constructors

          A4

          This is the doc for A4

          B4

          This is the doc for B4

          C4

          This is the doc for C4

          newtype N1 a #

          A newtype

          Constructors

          N1 a

          newtype N2 a b #

          A newtype with a fieldname

          Constructors

          N2

          Fields

          • n :: a b

          newtype N3 a b #

          A newtype with a fieldname, documentation on the field

          Constructors

          N3

          Fields

          • n3 :: a b

            this is the n3 field

          data N4 a b #

          An abstract newtype - we show this one as data rather than newtype because - the difference isn't visible to the programmer for an abstract type.

          newtype N5 a b #

          Constructors

          N5

          Fields

          • n5 :: a b

            no docs on the datatype or the constructor

          newtype N6 a b #

          Constructors

          N6

          docs on the constructor only

          Fields

          newtype N7 a b #

          docs on the newtype and the constructor

          Constructors

          N7

          The N7 constructor

          Fields

          Records

          data R #

          This is the documentation for the R record, which has four fields, - p, q, r, and s.

          Constructors

          C1

          This is the C1 record constructor, with the following fields:

          Fields

          • p :: Int

            This comment applies to the p field

          • q :: forall a. a -> a

            This comment applies to the q field

          • r, s :: Int

            This comment applies to both r and s

          C2

          This is the C2 record constructor, also with some fields:

          Fields

          data R1 #

          Testing different record commenting styles

          Constructors

          C3

          This is the C3 record constructor

          Fields

          test that we can export record selectors on their own:

          Class declarations

          class D a => C a where #

          This comment applies to the previous declaration (the C class)

          Minimal complete definition

          a, b

          Methods

          a :: IO a #

          this is a description of the a method

          b :: [a] #

          this is a description of the b method

          class D a where #

          This is a class declaration with no separate docs for the methods

          Minimal complete definition

          d, e

          Methods

          d :: T a b #

          e :: (a, a) #

          Instances

          D Float #

          Methods

          d :: T Float b #

          e :: (Float, Float) #

          D Int #

          Methods

          d :: T Int b #

          e :: (Int, Int) #

          class E a #

          This is a class declaration with no methods (or no methods exported)

          Minimal complete definition

          ee

          class F a where #

          Minimal complete definition

          ff

          Methods

          ff :: a #

          Test that we can export a class method on its own:

          a :: C a => IO a #

          this is a description of the a method

          Function types

          f :: C a => a -> Int #

          In a comment string we can refer to identifiers in scope with -single quotes like this: T, and we can refer to modules by -using double quotes: Foo. We can add emphasis like this.

          • This is a bulleted list
          • This is the next item (different kind of bullet)
          1. This is an ordered list
          2. This is the next item (different kind of bullet)
          cat
          a small, furry, domesticated mammal
          pineapple
          a fruit grown in the tropics
               This is a block of code, which can include other markup: R
-     formatting
-               is
-                 significant
-
          this is another block of code

          We can also include URLs in documentation: http://www.haskell.org/.

          g :: Int -> IO CInt #

          we can export foreign declarations too

          Auxiliary stuff

          This is some documentation that is attached to a name ($aux1) - rather than a source declaration. The documentation may be - referred to in the export list using its name.

           code block in named doc

          This is some documentation that is attached to a name ($aux2)

           code block on its own in named doc
           code block on its own in named doc (after newline)

          a nested, named doc comment

          with a paragraph,

           and a code block
          test
-test1
           test2
-  test3
-
          test1
-test2
-
          test3
-test4
          test1
-test2
-
          test3
-test4
          test3
-test4
          test1
-test2
-

          aux11:

          test3
-test4
          test1
-test2
-
          foo
          bar

          This is some inline documentation in the export list

          a code block using bird-tracks
-each line must begin with > (which isn't significant unless it
-is at the beginning of the line).

          A hidden module

          hidden :: Int -> Int #

          A visible module

          module Visible

          nested-style doc comments

          Existential / Universal types

          data Ex a #

          A data-type using existential/universal types

          Constructors

          C b => Ex1 b
          Ex2 b
          C a => Ex3 b
          Ex4 (forall a. a -> a)

          Type signatures with argument docs

          k #

          Arguments

          :: T () ()

          This argument has type T

          -> T2 Int Int

          This argument has type 'T2 Int Int'

          -> (T3 Bool Bool -> T4 Float Float)

          This argument has type T3 Bool Bool -> T4 Float Float

          -> T5 () ()

          This argument has a very long description that should - hopefully cause some wrapping to happen when it is finally - rendered by Haddock in the generated HTML page.

          -> IO ()

          This is the result type

          This is a function with documentation for each argument

          l #

          Arguments

          :: (Int, Int, Float)

          takes a triple

          -> Int

          returns an Int

          m #

          Arguments

          :: R
          -> N1 ()

          one of the arguments

          -> IO Int

          and the return value

          This function has some arg docs

          o #

          Arguments

          :: Float

          The input float

          -> IO Float

          The output float

          A foreign import with argument docs

          A section

          A subsection

          a literal line

          $ a non literal line $

          f' :: Int #

          a function with a prime can be referred to as f' - but f' doesn't get link'd 'f\''

          withType ::

          Copyright(c) Simon Marlow 2002
          LicenseBSD-style
          Maintainerlibraries@haskell.org
          Stabilityprovisional
          Portabilityportable
          Safe HaskellSafe

          Test

          Description

          This module illustrates & tests most of the features of Haddock. + Testing references from the description: T, f, g, visible.

          Synopsis

          Type declarations

          Data types

          data T a b #

          This comment applies to the following declaration + and it continues until the next non-comment line

          Constructors

          A Int (Maybe Float)

          This comment describes the A constructor

          B (T a b, T Int Float)

          This comment describes the B constructor

          data T2 a b #

          An abstract data declaration

          data T3 a b #

          A data declaration with no documentation annotations on the constructors

          Constructors

          A1 a
          B1 b

          data T4 a b #

          Constructors

          A2 a
          B2 b

          data T5 a b #

          Constructors

          A3 a

          documents A3

          B3 b

          documents B3

          data T6 #

          Testing alternative comment styles

          Constructors

          A4

          This is the doc for A4

          B4

          This is the doc for B4

          C4

          This is the doc for C4

          newtype N1 a #

          A newtype

          Constructors

          N1 a

          newtype N2 a b #

          A newtype with a fieldname

          Constructors

          N2

          Fields

          • n :: a b

          newtype N3 a b #

          A newtype with a fieldname, documentation on the field

          Constructors

          N3

          Fields

          • n3 :: a b

            this is the n3 field

          data N4 a b #

          An abstract newtype - we show this one as data rather than newtype because + the difference isn't visible to the programmer for an abstract type.

          newtype N5 a b #

          Constructors

          N5

          Fields

          • n5 :: a b

            no docs on the datatype or the constructor

          newtype N6 a b #

          Constructors

          N6

          docs on the constructor only

          Fields

          newtype N7 a b #

          docs on the newtype and the constructor

          Constructors

          N7

          The N7 constructor

          Fields

          Records

          data R #

          This is the documentation for the R record, which has four fields, + p, q, r, and s.

          Constructors

          C1

          This is the C1 record constructor, with the following fields:

          Fields

          • p :: Int

            This comment applies to the p field

          • q :: forall a. a -> a

            This comment applies to the q field

          • r, s :: Int

            This comment applies to both r and s

          C2

          This is the C2 record constructor, also with some fields:

          Fields

          data R1 #

          Testing different record commenting styles

          Constructors

          C3

          This is the C3 record constructor

          Fields

          test that we can export record selectors on their own:

          p :: R -> Int #

          This comment applies to the p field

          q :: R -> forall a. a -> a #

          This comment applies to the q field

          u :: R -> Int #

          Class declarations

          class D a => C a where #

          This comment applies to the previous declaration (the C class)

          Minimal complete definition

          a, b

          Methods

          a :: IO a #

          this is a description of the a method

          b :: [a] #

          this is a description of the b method

          class D a where #

          This is a class declaration with no separate docs for the methods

          Minimal complete definition

          d, e

          Methods

          d :: T a b #

          e :: (a, a) #

          Instances
          D Float #
          Instance details

          Methods

          d :: T Float b #

          e :: (Float, Float) #

          D Int #
          Instance details

          Methods

          d :: T Int b #

          e :: (Int, Int) #

          class E a #

          This is a class declaration with no methods (or no methods exported)

          Minimal complete definition

          ee

          class F a where #

          Minimal complete definition

          ff

          Methods

          ff :: a #

          Test that we can export a class method on its own:

          a :: C a => IO a #

          this is a description of the a method

          Function types

          f :: C a => a -> Int #

          In a comment string we can refer to identifiers in scope with +single quotes like this: T, and we can refer to modules by +using double quotes: Foo. We can add emphasis like this.

          • This is a bulleted list
          • This is the next item (different kind of bullet)
          1. This is an ordered list
          2. This is the next item (different kind of bullet)
          cat
          a small, furry, domesticated mammal
          pineapple
          a fruit grown in the tropics
               This is a block of code, which can include other markup: R
+     formatting
+               is
+                 significant
+
          this is another block of code

          We can also include URLs in documentation: http://www.haskell.org/.

          g :: Int -> IO CInt #

          we can export foreign declarations too

          Auxiliary stuff

          This is some documentation that is attached to a name ($aux1) + rather than a source declaration. The documentation may be + referred to in the export list using its name.

           code block in named doc

          This is some documentation that is attached to a name ($aux2)

           code block on its own in named doc
           code block on its own in named doc (after newline)

          a nested, named doc comment

          with a paragraph,

           and a code block
          test
+test1
           test2
+  test3
+
          test1
+test2
+
          test3
+test4
          test1
+test2
+
          test3
+test4
          test3
+test4
          test1
+test2
+

          aux11:

          test3
+test4
          test1
+test2
+
          foo
          bar

          This is some inline documentation in the export list

          a code block using bird-tracks
+each line must begin with > (which isn't significant unless it
+is at the beginning of the line).

          A hidden module

          hidden :: Int -> Int #

          A visible module

          module Visible

          nested-style doc comments

          Existential / Universal types

          data Ex a #

          A data-type using existential/universal types

          Constructors

          C b => Ex1 b
          Ex2 b
          C a => Ex3 b
          Ex4 (forall a. a -> a)

          Type signatures with argument docs

          k #

          Arguments

          :: T () ()

          This argument has type T

          -> T2 Int Int

          This argument has type 'T2 Int Int'

          -> (T3 Bool Bool -> T4 Float Float)

          This argument has type T3 Bool Bool -> T4 Float Float

          -> T5 () ()

          This argument has a very long description that should + hopefully cause some wrapping to happen when it is finally + rendered by Haddock in the generated HTML page.

          -> IO ()

          This is the result type

          This is a function with documentation for each argument

          l #

          Arguments

          :: (Int, Int, Float)

          takes a triple

          -> Int

          returns an Int

          m #

          Arguments

          :: R
          -> N1 ()

          one of the arguments

          -> IO Int

          and the return value

          This function has some arg docs

          o #

          Arguments

          :: Float

          The input float

          -> IO Float

          The output float

          A foreign import with argument docs

          A section

          A subsection

          a literal line

          $ a non literal line $

          f' :: Int #

          a function with a prime can be referred to as f' + but f' doesn't get link'd 'f\''

          withType :: Int #Threaded

          Synopsis

          Synopsis

          f :: :: Integer #Threaded_TH

          Synopsis

          Synopsis

          forkTH :: Q Exp :: Q Exp #

          Ticket112
          Ticket112

          Synopsis

          • f :: a
          Synopsis
          • f :: a

          ...given a raw Addr# to the string, and the length of the string.

          Ticket61

          Minimal complete definition

          f

          Ticket75
          Ticket75

          Synopsis

          f :: :: Int #

          A reference to :-

          TitledPicture
          TitledPicture

          Synopsis

          foo :: :: Integer #

          Picture for foo without a title

          bar :: :: Integer #

          Picture for bar with title TypeFamilies

          Safe HaskellSafe

          TypeFamilies

          Description

          Doc for: module TypeFamilies

          Synopsis

          Documentation

          data X #

          Doc for: data X

          Constructors

          X

          Doc for: X

          XX

          Doc for: XX

          XXX

          Doc for: XXX

          Instances

          (><) X XX XXX #
          Assoc * X #

          Doc for: instance Assoc X

          Associated Types

          data AssocD X (a :: X) :: * #

          type AssocT X (a :: X) :: * #

          Test * X #

          Doc for: instance Test X

          type Foo X #
          type Foo X = Y
          type (<>) X XXX XX #
          type (<>) X XXX XX = X
          data AssocD * X #
          data AssocD * X = AssocX
          type AssocT * X #
          type AssocT * X = Foo * X
          data Bat * X #

          Doc for: data instance Bat X

          data Bat * X
          type Foo * X #
          type Foo * X = Y
          type (<>) * X a #
          type (<>) * X a = X

          data Y #

          Doc for: data Y

          Instances

          Assoc * Y #

          Doc for: instance Assoc Y

          Associated Types

          data AssocD Y (a :: Y) :: * #

          type AssocT Y (a :: Y) :: * #

          Test * Y #

          Doc for: instance Test Y

          data Bar Y #
          data Bar Y
          data AssocD * Y #
          data AssocD * Y = AssocY
          type AssocT * Y #
          type AssocT * Y = Bat * Y
          data Bat * Y #

          Doc for: data instance Bat Y

          data Bat * Y = BatY Y
          type Foo * Y #
          type Foo * Y = X
          type (<>) * Y a #
          type (<>) * Y a = a

          data Z #

          Doc for: data Z

          Constructors

          ZA
          ZB

          Instances

          data Bat Z #

          Doc for: data instance Bat Z

          data Bat Z where

          class Test a #

          Doc for: class Test a

          Instances

          Test * Y #

          Doc for: instance Test Y

          Test * X #

          Doc for: instance Test X

          type family Foo a :: k #

          Doc for: type family Foo a

          Instances

          type Foo * Y #
          type Foo * Y = X
          type Foo * X #
          type Foo * X = Y

          data family Bat (a :: k) :: * #

          Doc for: data family Bat a

          Instances

          data Bat Z #

          Doc for: data instance Bat Z

          data Bat Z where
          data Bat * Y #

          Doc for: data instance Bat Y

          data Bat * Y = BatY Y
          data Bat * X #

          Doc for: data instance Bat X

          data Bat * X

          class Assoc a #

          Doc for: class Assoc a

          Associated Types

          data AssocD a :: * #

          Doc for: data AssocD a

          type AssocT a :: * #

          Doc for: type AssocT a

          Instances

          Assoc * Y #

          Doc for: instance Assoc Y

          Associated Types

          data AssocD Y (a :: Y) :: * #

          type AssocT Y (a :: Y) :: * #

          Assoc * X #

          Doc for: instance Assoc X

          Associated Types

          data AssocD X (a :: X) :: * #

          type AssocT X (a :: X) :: * #

          type family Bar b where ... #

          Doc for: type family Bar b

          Equations

          Bar X = X
          Bar y = Y

          type family (a :: k) <> (b :: k) :: k #

          Instances

          type (<>) X XXX XX #
          type (<>) X XXX XX = X
          type (<>) * Y a #
          type (<>) * Y a = a
          type (<>) * X a #
          type (<>) * X a = X

          class (a :: k) >< (b :: k) #

          Instances

          (><) X XX XXX #
          Safe HaskellSafe

          TypeFamilies

          Description

          Doc for: module TypeFamilies

          Synopsis

          Documentation

          data X #

          Doc for: data X

          Constructors

          X

          Doc for: X

          XX

          Doc for: XX

          XXX

          Doc for: XXX

          Instances
          XX >< XXX #
          Instance details
          Assoc X #

          Doc for: instance Assoc X

          Instance details

          Associated Types

          data AssocD X :: * #

          type AssocT X :: * #

          Test X #

          Doc for: instance Test X

          Instance details
          type Foo X #
          Instance details
          type Foo X = Y
          type XXX <> XX #
          Instance details
          type XXX <> XX = X
          data AssocD X #
          Instance details
          data AssocD X = AssocX
          type AssocT X #
          Instance details
          type AssocT X = (Foo X :: *)
          data Bat X #

          Doc for: data instance Bat X

          Instance details
          data Bat X
          type Foo X #
          Instance details
          type Foo X = Y
          type X <> (a :: *) #
          Instance details
          type X <> (a :: *) = X

          data Y #

          Doc for: data Y

          Instances
          Assoc Y #

          Doc for: instance Assoc Y

          Instance details

          Associated Types

          data AssocD Y :: * #

          type AssocT Y :: * #

          Test Y #

          Doc for: instance Test Y

          Instance details
          data Bar Y #
          Instance details
          data Bar Y
          data AssocD Y #
          Instance details
          data AssocD Y = AssocY
          type AssocT Y #
          Instance details
          type AssocT Y = Bat Y
          data Bat Y #

          Doc for: data instance Bat Y

          Instance details
          data Bat Y = BatY Y
          type Foo Y #
          Instance details
          type Foo Y = X
          type Y <> (a :: *) #
          Instance details
          type Y <> (a :: *) = a

          data Z #

          Doc for: data Z

          Constructors

          ZA
          ZB
          Instances
          data Bat (z :: Z) #

          Doc for: data instance Bat Z

          Instance details
          data Bat (z :: Z) where

          class Test a #

          Doc for: class Test a

          Instances
          Test Y #

          Doc for: instance Test Y

          Instance details
          Test X #

          Doc for: instance Test X

          Instance details

          type family Foo a :: k #

          Doc for: type family Foo a

          Instances
          type Foo Y #
          Instance details
          type Foo Y = X
          type Foo X #
          Instance details
          type Foo X = Y

          data family Bat (a :: k) :: * #

          Doc for: data family Bat a

          Instances
          data Bat (z :: Z) #

          Doc for: data instance Bat Z

          Instance details
          data Bat (z :: Z) where
          data Bat Y #

          Doc for: data instance Bat Y

          Instance details
          data Bat Y = BatY Y
          data Bat X #

          Doc for: data instance Bat X

          Instance details
          data Bat X

          class Assoc a #

          Doc for: class Assoc a

          Associated Types

          data AssocD a :: * #

          Doc for: data AssocD a

          type AssocT a :: * #

          Doc for: type AssocT a

          Instances
          Assoc Y #

          Doc for: instance Assoc Y

          Instance details

          Associated Types

          data AssocD Y :: * #

          type AssocT Y :: * #

          Assoc X #

          Doc for: instance Assoc X

          Instance details

          Associated Types

          data AssocD X :: * #

          type AssocT X :: * #

          type family Bar b where ... #

          Doc for: type family Bar b

          Equations

          Bar X = X
          Bar y = Y

          type family (a :: k) <> (b :: k) :: k #

          Instances
          type XXX <> XX #
          Instance details
          type XXX <> XX = X
          type Y <> (a :: *) #
          Instance details
          type Y <> (a :: *) = a
          type X <> (a :: *) #
          Instance details
          type X <> (a :: *) = X

          class (a :: k) >< (b :: k) #

          Instances
          XX >< XXX #
          Instance details
          TypeFamilies2
          TypeFamilies2

          Synopsis

          • data W
          • type family Foo a
            • Synopsis
            • data family Bar a
            data W
          • type family Foo a
          • data family Bar a

          Exported type

          Instances

          Instances
          data Bar W
          Instance details
          data Bar W = BarX Z
          type Foo W
          Instance details
          type Foo W
          Exported type family

          Instances

          Instances
          type Foo W
          Instance details
          type Foo W
          type Foo X
          Instance details
          type Foo X = = Y
          Exported data family

          Instances

          Instances
          data Bar W
          Instance details
          data Bar W = BarX Z
          data Bar Y
          Instance details
          data Bar Y
          TypeOperators

          biO :: (g :: (g `O` f) a #

          x :: (a :: (a :-: a) a) <=> (a (a `Op` a) => a #

          y :: (a :: (a <=> a, (a a, (a `Op` a) a) <=> a) => a #Unicode

          Unicode

          Synopsis

          Synopsis

          x :: :: Int #Visible

          visible :: :: Int -> -> Int # () -> () +_ ⊆ _ = () + diff --git a/html-test/src/Bug546.hs b/html-test/src/Bug546.hs new file mode 100644 --- /dev/null +++ b/html-test/src/Bug546.hs @@ -0,0 +1,55 @@ +module Bug546 where + +-- |Test: +-- +-- [@[code with square \\ brackets\]@] lorem ipsum +x = 1 + +-- | +-- +-- [@[..\]@] Matches any of the enclosed characters. Ranges of characters can +-- be specified by separating the endpoints with a @\'-'@. @\'-'@ or +-- @']'@ can be matched by including them as the first character(s) +-- in the list. Never matches path separators: @[\/]@ matches +-- nothing at all. Named character classes can also be matched: +-- @[:x:]@ within @[]@ specifies the class named @x@, which matches +-- certain predefined characters. See below for a full list. +-- +-- [@[^..\]@ or @[!..\]@] Like @[..]@, but matches any character /not/ listed. +-- Note that @[^-x]@ is not the inverse of @[-x]@, but +-- the range @[^-x]@. +-- +-- [@\@] Matches any integer in the range m to n, inclusive. The range may +-- be open-ended by leaving out either number: @\"\<->\"@, for +-- instance, matches any integer. +-- +-- [@**/@] Matches any number of characters, including path separators, +-- excluding the empty string. +-- +-- Supported character classes: +-- +-- [@[:alnum:\]@] Equivalent to @\"0-9A-Za-z\"@. +-- +-- [@[:alpha:\]@] Equivalent to @\"A-Za-z\"@. +-- +-- [@[:blank:\]@] Equivalent to @\"\\t \"@. +-- +-- [@[:cntrl:\]@] Equivalent to @\"\\0-\\x1f\\x7f\"@. +-- +-- [@[:digit:\]@] Equivalent to @\"0-9\"@. +-- +-- [@[:graph:\]@] Equivalent to @\"!-~\"@. +-- +-- [@[:lower:\]@] Equivalent to @\"a-z\"@. +-- +-- [@[:print:\]@] Equivalent to @\" -~\"@. +-- +-- [@[:punct:\]@] Equivalent to @\"!-\/:-\@[-`{-~\"@. +-- +-- [@[:space:\]@] Equivalent to @\"\\t-\\r \"@. +-- +-- [@[:upper:\]@] Equivalent to @\"A-Z\"@. +-- +-- [@[:xdigit:\]@] Equivalent to @\"0-9A-Fa-f\"@. +compile :: String -> String +compile = id diff --git a/html-test/src/Bug548.hs b/html-test/src/Bug548.hs new file mode 100644 --- /dev/null +++ b/html-test/src/Bug548.hs @@ -0,0 +1,3 @@ +module Bug548 (WrappedArrow(..)) where + +import Control.Applicative diff --git a/html-test/src/Bug613.hs b/html-test/src/Bug613.hs new file mode 100644 --- /dev/null +++ b/html-test/src/Bug613.hs @@ -0,0 +1,16 @@ +module Bug613 where + +import Prelude (Either(Left, Right)) + +class Functor f where + fmap :: (a -> 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) diff --git a/html-test/src/Bug679.hs b/html-test/src/Bug679.hs new file mode 100644 --- /dev/null +++ b/html-test/src/Bug679.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Bug679 where + +import Language.Haskell.TH + +data Bar a = Bar + +$(do + a <- newName "a" + + let classN = mkName "Foo" + let methodN = mkName "foo" + + methodTy <- [t| $(varT a) -> $(varT a) |] + let cla = ClassD [] classN [PlainTV a] [] [SigD methodN methodTy] + + -- Note that we are /reusing/ the same type variable 'a' as in the class + instanceHead <- [t| $(conT classN) (Bar $(varT a)) |] + idCall <- [e| id |] + let ins = InstanceD Nothing [] instanceHead [FunD methodN [Clause [] (NormalB idCall) []]] + + pure [cla,ins]) + diff --git a/html-test/src/ConstructorPatternExport.hs b/html-test/src/ConstructorPatternExport.hs new file mode 100644 --- /dev/null +++ b/html-test/src/ConstructorPatternExport.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} + +module ConstructorPatternExport ( + pattern FooCons + , pattern MyRecCons + , pattern (:+) + , pattern BlubCons + , pattern MyGADTCons + ) where + +data Foo a = FooCons String a + +data MyRec = MyRecCons { one :: Bool, two :: Int } + +data MyInfix a = String :+ a + +data Blub = forall b. Show b => 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 diff --git a/html-test/src/PatternSyns.hs b/html-test/src/PatternSyns.hs --- 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 @@ -14,6 +14,12 @@ -- | 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 diff --git a/html-test/src/Table.hs b/html-test/src/Table.hs new file mode 100644 --- /dev/null +++ b/html-test/src/Table.hs @@ -0,0 +1,47 @@ +-- | This tests the table markup +module Table + ( tableWithHeader + , tableWithoutHeader + , fancyTable + ) where + +-- | Table with header. +-- +-- +------+--------------+------------------------------------------+ +-- | code | message | description | +-- +======+==============+==========================================+ +-- | 200 | @OK@ | operation successful | +-- +------+--------------+------------------------------------------+ +-- | 204 | @No Content@ | operation successful, no body returned | +-- +------+--------------+------------------------------------------+ +tableWithHeader :: a -> a +tableWithHeader a = a + +-- | Table without header. +-- +-- +------+--------------+------------------------------------------+ +-- | 200 | @OK@ | operation successful | +-- +------+--------------+------------------------------------------+ +-- | 204 | @No Content@ | operation successful, no body returned | +-- +------+--------------+------------------------------------------+ +-- | 404 | @Not Found@ | resource not found | +-- +------+--------------+------------------------------------------+ +tableWithoutHeader :: a -> a +tableWithoutHeader a = a + +-- | Fancy table. +-- +-- +------------------------+------------+----------+----------+ +-- | Header row, column 1 | Header 2 | Header 3 | Header 4 | +-- | (header rows optional) | | | | +-- +========================+============+==========+==========+ +-- | body row 1, column 1 | column 2 | column 3 | column 4 | +-- +------------------------+------------+----------+----------+ +-- | 'tableWithHeader' | Cells may span columns. | +-- +------------------------+------------+---------------------+ +-- | body row 3 | Cells may | \[ | +-- +------------------------+ span rows. | f(n) = \sum_{i=1} | +-- | body row 4 | | \] | +-- +------------------------+------------+---------------------+ +fancyTable :: a -> a +fancyTable x = x diff --git a/hypsrc-test/ref/src/Classes.html b/hypsrc-test/ref/src/Classes.html --- a/hypsrc-test/ref/src/Classes.html +++ b/hypsrc-test/ref/src/Classes.html @@ -60,8 +60,12 @@ > barbar bazbaz quuxquux norfnorf plughplugh Identifiers.norfIdentifiers.norf