diff options
Diffstat (limited to 'haddock-api/src')
33 files changed, 2718 insertions, 783 deletions
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 72c544e1..70cdf8a3 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -30,6 +30,7 @@ import Haddock.Backends.Xhtml import Haddock.Backends.Xhtml.Themes (getThemes) import Haddock.Backends.LaTeX import Haddock.Backends.Hoogle +import Haddock.Backends.Hyperlinker import Haddock.Interface import Haddock.Parser import Haddock.Types @@ -39,11 +40,13 @@ import Haddock.Options import Haddock.Utils import Control.Monad hiding (forM_) +import Control.Applicative import Data.Foldable (forM_) import Data.List (isPrefixOf) import Control.Exception import Data.Maybe import Data.IORef +import Data.Map (Map) import qualified Data.Map as Map import System.IO import System.Exit @@ -118,11 +121,8 @@ handleGhcExceptions = -- error messages propagated as exceptions handleGhcException $ \e -> do hFlush stdout - case e of - PhaseFailed _ code -> exitWith code - _ -> do - print (e :: GhcException) - exitFailure + print (e :: GhcException) + exitFailure ------------------------------------------------------------------------------- @@ -157,6 +157,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do _ -> return flags unless (Flag_NoWarnings `elem` flags) $ do + hypSrcWarnings flags forM_ (warnings args) $ \warning -> do hPutStrLn stderr warning @@ -225,13 +226,16 @@ renderStep dflags flags qual pkgs interfaces = do let ifaceFiles = map snd pkgs installedIfaces = concatMap ifInstalledIfaces ifaceFiles - srcMap = Map.fromList [ (ifPackageKey if_, x) | ((_, Just x), if_) <- pkgs ] - render dflags flags qual interfaces installedIfaces srcMap + extSrcMap = Map.fromList $ do + ((_, Just path), ifile) <- pkgs + iface <- ifInstalledIfaces ifile + return (instMod iface, path) + render dflags flags qual interfaces installedIfaces extSrcMap -- | Render the interfaces with whatever backend is specified in the flags. -render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> SrcMap -> IO () -render dflags flags qual ifaces installedIfaces srcMap = do +render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> Map Module FilePath -> IO () +render dflags flags qual ifaces installedIfaces extSrcMap = do let title = fromMaybe "" (optTitle flags) @@ -242,6 +246,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do opt_index_url = optIndexUrl flags odir = outputDir flags opt_latex_style = optLaTeXStyle flags + opt_source_css = optSourceCssFile flags visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ] @@ -250,15 +255,35 @@ render dflags flags qual ifaces installedIfaces srcMap = do allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ] pkgMod = ifaceMod (head ifaces) - pkgKey = modulePackageKey pkgMod - pkgStr = Just (packageKeyString pkgKey) - (pkgName,pkgVer) = modulePackageInfo dflags flags pkgMod + pkgKey = moduleUnitId pkgMod + pkgStr = Just (unitIdString pkgKey) + pkgNameVer = modulePackageInfo dflags flags pkgMod (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags - srcMap' = maybe srcMap (\path -> Map.insert pkgKey path srcMap) srcEntity + + srcModule' + | Flag_HyperlinkedSource `elem` flags = Just hypSrcModuleUrlFormat + | otherwise = srcModule + + srcMap = mkSrcMap $ Map.union + (Map.map SrcExternal extSrcMap) + (Map.fromList [ (ifaceMod iface, SrcLocal) | iface <- ifaces ]) + + pkgSrcMap = Map.mapKeys moduleUnitId extSrcMap + pkgSrcMap' + | Flag_HyperlinkedSource `elem` flags = + Map.insert pkgKey hypSrcModuleNameUrlFormat pkgSrcMap + | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl pkgSrcMap + | otherwise = pkgSrcMap + -- TODO: Get these from the interface files as with srcMap - srcLMap' = maybe Map.empty (\path -> Map.singleton pkgKey path) srcLEntity - sourceUrls' = (srcBase, srcModule, srcMap', srcLMap') + pkgSrcLMap' + | Flag_HyperlinkedSource `elem` flags = + Map.singleton pkgKey hypSrcModuleLineUrlFormat + | Just path <- srcLEntity = Map.singleton pkgKey path + | otherwise = Map.empty + + sourceUrls' = (srcBase, srcModule', pkgSrcMap', pkgSrcLMap') libDir <- getHaddockLibDir flags prologue <- getPrologue dflags flags @@ -288,17 +313,28 @@ render dflags flags qual ifaces installedIfaces srcMap = do -- 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 when (Flag_Hoogle `elem` flags) $ do - let pkgNameStr | unpackFS pkgNameFS == "main" && title /= [] - = title - | otherwise = unpackFS pkgNameFS - where PackageName pkgNameFS = pkgName - ppHoogle dflags pkgNameStr pkgVer title (fmap _doc prologue) visibleIfaces - odir + case pkgNameVer of + Nothing -> putStrLn . unlines $ + [ "haddock: Unable to find a package providing module " + ++ moduleNameString (moduleName pkgMod) ++ ", skipping Hoogle." + , "" + , " Perhaps try specifying the desired package explicitly" + ++ " using the --package-name" + , " and --package-version arguments." + ] + Just (PackageName pkgNameFS, pkgVer) -> + let pkgNameStr | unpackFS pkgNameFS == "main" && title /= [] = title + | otherwise = unpackFS pkgNameFS + in ppHoogle dflags pkgNameStr pkgVer title (fmap _doc prologue) + visibleIfaces odir when (Flag_LaTeX `elem` flags) $ do ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style libDir + when (Flag_HyperlinkedSource `elem` flags) $ do + ppHyperlinkedSource odir libDir opt_source_css pretty srcMap ifaces + -- | From GHC 7.10, this function has a potential to crash with a -- nasty message such as @expectJust getPackageDetails@ because -- package name and versions can no longer reliably be extracted in @@ -312,12 +348,12 @@ modulePackageInfo :: DynFlags -- contain the package name or version -- provided by the user which we -- prioritise - -> Module -> (PackageName, Data.Version.Version) + -> Module -> Maybe (PackageName, Data.Version.Version) modulePackageInfo dflags flags modu = - (fromMaybe (packageName pkg) (optPackageName flags), - fromMaybe (packageVersion pkg) (optPackageVersion flags)) + cmdline <|> pkgDb where - pkg = getPackageDetails dflags (modulePackageKey modu) + cmdline = (,) <$> optPackageName flags <*> optPackageVersion flags + pkgDb = (\pkg -> (packageName pkg, packageVersion pkg)) <$> lookupPackage dflags (moduleUnitId modu) ------------------------------------------------------------------------------- @@ -467,6 +503,35 @@ shortcutFlags flags = do ++ "Ported to use the GHC API by David Waern 2006-2008\n" +-- | Generate some warnings about potential misuse of @--hyperlinked-source@. +hypSrcWarnings :: [Flag] -> IO () +hypSrcWarnings flags = do + + when (hypSrc && any isSourceUrlFlag flags) $ + hPutStrLn stderr $ concat + [ "Warning: " + , "--source-* options are ignored when " + , "--hyperlinked-source is enabled." + ] + + when (not hypSrc && any isSourceCssFlag flags) $ + hPutStrLn stderr $ concat + [ "Warning: " + , "source CSS file is specified but " + , "--hyperlinked-source is disabled." + ] + + where + hypSrc = Flag_HyperlinkedSource `elem` flags + isSourceUrlFlag (Flag_SourceBaseURL _) = True + isSourceUrlFlag (Flag_SourceModuleURL _) = True + isSourceUrlFlag (Flag_SourceEntityURL _) = True + isSourceUrlFlag (Flag_SourceLEntityURL _) = True + isSourceUrlFlag _ = False + isSourceCssFlag (Flag_SourceCss _) = True + isSourceCssFlag _ = False + + updateHTMLXRefs :: [(DocPaths, InterfaceFile)] -> IO () updateHTMLXRefs packages = do writeIORef html_xrefs_ref (Map.fromList mapping) diff --git a/haddock-api/src/Haddock/Backends/HaddockDB.hs b/haddock-api/src/Haddock/Backends/HaddockDB.hs index 1c248bfb..0bdc9057 100644 --- a/haddock-api/src/Haddock/Backends/HaddockDB.hs +++ b/haddock-api/src/Haddock/Backends/HaddockDB.hs @@ -40,7 +40,7 @@ ppIfaces mods where do_mod (Module mod, iface) = text "<sect1 id=\"sec-" <> text mod <> text "\">" - $$ text "<title><literal>" + $$ text "<title><literal>" <> text mod <> text "</literal></title>" $$ text "<indexterm><primary><literal>" @@ -50,10 +50,10 @@ ppIfaces mods $$ vcat (map (do_export mod) (eltsFM (iface_decls iface))) $$ text "</variablelist>" $$ text "</sect1>" - + do_export mod decl | (nm:_) <- declBinders decl = text "<varlistentry id=" <> ppLinkId mod nm <> char '>' - $$ text "<term><literal>" + $$ text "<term><literal>" <> do_decl decl <> text "</literal></term>" $$ text "<listitem>" @@ -63,11 +63,11 @@ ppIfaces mods $$ text "</varlistentry>" do_export _ _ = empty - do_decl (HsTypeSig _ [nm] ty _) + do_decl (HsTypeSig _ [nm] ty _) = ppHsName nm <> text " :: " <> ppHsType ty do_decl (HsTypeDecl _ nm args ty _) = hsep ([text "type", ppHsName nm ] - ++ map ppHsName args + ++ map ppHsName args ++ [equals, ppHsType ty]) do_decl (HsNewTypeDecl loc ctx nm args con drv _) = hsep ([text "data", ppHsName nm] -- data, not newtype @@ -87,7 +87,7 @@ ppHsConstr :: HsConDecl -> Doc ppHsConstr (HsRecDecl pos name tvs ctxt fieldList maybe_doc) = ppHsName name <> (braces . hsep . punctuate comma . map ppField $ fieldList) -ppHsConstr (HsConDecl pos name tvs ctxt typeList maybe_doc) = +ppHsConstr (HsConDecl pos name tvs ctxt typeList maybe_doc) = hsep (ppHsName name : map ppHsBangType typeList) ppField (HsFieldDecl ns ty doc) @@ -100,7 +100,7 @@ ppHsBangType (HsUnBangedTy ty) = ppHsType ty ppHsContext :: HsContext -> Doc ppHsContext [] = empty -ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+> +ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+> hsep (map ppHsAType b)) context) ppHsType :: HsType -> Doc @@ -109,7 +109,7 @@ ppHsType (HsForAllType Nothing context htype) = ppHsType (HsForAllType (Just tvs) [] htype) = hsep (text "forall" : map ppHsName tvs ++ text "." : [ppHsType htype]) ppHsType (HsForAllType (Just tvs) context htype) = - hsep (text "forall" : map ppHsName tvs ++ text "." : + hsep (text "forall" : map ppHsName tvs ++ text "." : ppHsContext context : text "=>" : [ppHsType htype]) ppHsType (HsTyFun a b) = fsep [ppHsBType a, text "->", ppHsType b] ppHsType (HsTyIP n t) = fsep [(char '?' <> ppHsName n), text "::", ppHsType t] @@ -135,7 +135,7 @@ ppHsQName (UnQual str) = ppHsName str ppHsQName n@(Qual (Module mod) str) | n == unit_con_name = ppHsName str | isSpecial str = ppHsName str - | otherwise + | otherwise = text "<link linkend=" <> ppLinkId mod str <> char '>' <> ppHsName str <> text "</link>" diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index fe656a4b..a9bc9a8b 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -15,12 +15,15 @@ module Haddock.Backends.Hoogle ( ppHoogle ) where - +import BasicTypes (OverlapFlag(..), OverlapMode(..)) +import InstEnv (ClsInst(..)) import Haddock.GhcUtils import Haddock.Types hiding (Version) import Haddock.Utils hiding (out) + import GHC import Outputable +import NameSet import Data.Char import Data.List @@ -64,7 +67,8 @@ dropHsDocTy :: HsType a -> HsType a dropHsDocTy = f where g (L src x) = L src (f x) - f (HsForAllTy a b c d e) = HsForAllTy a b c d (g e) + f (HsForAllTy a e) = HsForAllTy a (g e) + f (HsQualTy a e) = HsQualTy a (g e) f (HsBangTy a b) = HsBangTy a (g b) f (HsAppTy a b) = HsAppTy (g a) (g b) f (HsFunTy a b) = HsFunTy (g a) (g b) @@ -81,32 +85,28 @@ outHsType :: OutputableBndr a => DynFlags -> HsType a -> String outHsType dflags = out dflags . dropHsDocTy -makeExplicit :: HsType a -> HsType a -makeExplicit (HsForAllTy _ a b c d) = HsForAllTy Explicit a b c d -makeExplicit x = x - -makeExplicitL :: LHsType a -> LHsType a -makeExplicitL (L src x) = L src (makeExplicit x) - - dropComment :: String -> String dropComment (' ':'-':'-':' ':_) = [] dropComment (x:xs) = x : dropComment xs dropComment [] = [] -out :: Outputable a => DynFlags -> a -> String -out dflags = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual dflags . ppr +outWith :: Outputable a => (SDoc -> String) -> a -> [Char] +outWith p = f . unwords . map (dropWhile isSpace) . lines . p . ppr where f xs | " <document comment>" `isPrefixOf` xs = f $ drop 19 xs f (x:xs) = x : f xs f [] = [] +out :: Outputable a => DynFlags -> a -> String +out dflags = outWith $ showSDocUnqual dflags operator :: String -> String operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x:xs ++ ")" operator x = x +commaSeparate :: Outputable a => DynFlags -> [a] -> String +commaSeparate dflags = showSDocUnqual dflags . interpp'SP --------------------------------------------------------------------- -- How to print each export @@ -115,49 +115,84 @@ ppExport :: DynFlags -> ExportItem Name -> [String] ppExport dflags ExportDecl { expItemDecl = L _ decl , expItemMbDoc = (dc, _) , expItemSubDocs = subdocs + , expItemFixities = fixities } = ppDocumentation dflags dc ++ f decl where f (TyClD d@DataDecl{}) = ppData dflags d subdocs f (TyClD d@SynDecl{}) = ppSynonym dflags d - f (TyClD d@ClassDecl{}) = ppClass dflags d - f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ [] - f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ [] - f (SigD sig) = ppSig dflags sig + f (TyClD d@ClassDecl{}) = ppClass dflags d subdocs + f (ForD (ForeignImport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)] + f (ForD (ForeignExport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)] + f (SigD sig) = ppSig dflags sig ++ ppFixities f _ = [] + + ppFixities = concatMap (ppFixity dflags) fixities ppExport _ _ = [] +ppSigWithDoc :: DynFlags -> Sig Name -> [(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)] + + getDoc :: Located Name -> [Documentation Name] + getDoc n = maybe [] (return . fst) (lookup (unL n) subdocs) + +ppSigWithDoc _ _ _ = [] ppSig :: DynFlags -> Sig Name -> [String] -ppSig dflags (TypeSig names sig _) - = [operator prettyNames ++ " :: " ++ outHsType dflags typ] - where - prettyNames = intercalate ", " $ map (out dflags) names - typ = case unL sig of - HsForAllTy Explicit a b c d -> HsForAllTy Implicit a b c d - HsForAllTy Qualified a b c d -> HsForAllTy Implicit a b c d - x -> x -ppSig _ _ = [] +ppSig dflags x = ppSigWithDoc dflags x [] +pp_sig :: DynFlags -> [Located Name] -> LHsType Name -> 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 -> [String] -ppClass dflags x = out dflags x{tcdSigs=[]} : - concatMap (ppSig dflags . addContext . unL) (tcdSigs x) +ppClass :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String] +ppClass dflags decl subdocs = (out dflags decl{tcdSigs=[]} ++ ppTyFams) : ppMethods where - addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs - addContext (MinimalSig src sig) = MinimalSig src sig - addContext _ = error "expected TypeSig" - f (HsForAllTy a b c con d) = HsForAllTy a b c (reL (context : unLoc con)) d - f t = HsForAllTy Implicit Nothing emptyHsQTvs (reL [context]) (reL t) + ppMethods = concat . map (ppSig' . unLoc . add_ctxt) $ tcdSigs decl + ppSig' = flip (ppSigWithDoc dflags) subdocs - context = nlHsTyConApp (tcdName x) - (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars x))) + add_ctxt = addClassContext (tcdName decl) (tyClDeclTyVars decl) + ppTyFams + | null $ tcdATs decl = "" + | otherwise = (" " ++) . showSDocUnqual dflags . whereWrapper $ concat + [ map ppr (tcdATs decl) + , map (ppr . tyFamEqnToSyn . unLoc) (tcdATDefs decl) + ] + + whereWrapper elems = vcat' + [ text "where" <+> lbrace + , nest 4 . vcat . map (<> semi) $ elems + , rbrace + ] + + tyFamEqnToSyn :: TyFamDefltEqn Name -> TyClDecl Name + tyFamEqnToSyn tfe = SynDecl + { tcdLName = tfe_tycon tfe + , tcdTyVars = tfe_pats tfe + , tcdRhs = tfe_rhs tfe + , tcdFVs = emptyNameSet + } -ppInstance :: DynFlags -> ClsInst -> [String] -ppInstance dflags x = [dropComment $ out dflags x] +ppInstance :: DynFlags -> ClsInst -> [String] +ppInstance dflags x = + [dropComment $ outWith (showSDocForUser dflags alwaysQualify) cls] + where + -- As per #168, we don't want safety information about the class + -- in Hoogle output. The easiest way to achieve this is to set the + -- safety information to a state where the Outputable instance + -- produces no output which means no overlap and unsafe (or [safe] + -- is generated). + cls = x { is_flag = OverlapFlag { overlapMode = NoOverlap mempty + , isSafeOverlap = False } } ppSynonym :: DynFlags -> TyClDecl Name -> [String] ppSynonym dflags x = [out dflags x] @@ -184,26 +219,40 @@ lookupCon dflags subdocs (L _ name) = case lookup name subdocs of _ -> [] ppCtor :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String] -ppCtor dflags dat subdocs con - = concatMap (lookupCon dflags subdocs) (con_names con) ++ f (con_details con) +ppCtor dflags dat subdocs con@ConDeclH98 {} + -- AZ:TODO get rid of the concatMap + = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConDetails con) where f (PrefixCon args) = [typeSig name $ args ++ [resType]] f (InfixCon a1 a2) = f $ PrefixCon [a1,a2] f (RecCon (L _ recs)) = f (PrefixCon $ map cd_fld_type (map unLoc recs)) ++ concat - [(concatMap (lookupCon dflags subdocs) (cd_fld_names r)) ++ - [out dflags (map unL $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] + [(concatMap (lookupCon dflags subdocs . noLoc . selectorFieldOcc . unLoc) (cd_fld_names r)) ++ + [out dflags (map (selectorFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] | r <- map unLoc recs] - funs = foldr1 (\x y -> reL $ HsFunTy (makeExplicitL x) (makeExplicitL y)) + funs = foldr1 (\x y -> reL $ HsFunTy x y) apps = foldl1 (\x y -> reL $ HsAppTy x y) - typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (makeExplicit $ unL $ funs flds) - name = out dflags $ map unL $ con_names con + typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds) + + -- We print the constructors as comma-separated list. See GHC + -- docs for con_names on why it is a list to begin with. + name = commaSeparate dflags . map unL $ getConNames con + + resType = apps $ map (reL . HsTyVar . reL) $ + (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvExplicit $ tyClDeclTyVars dat] + +ppCtor dflags _dat subdocs con@ConDeclGADT {} + = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f + where + f = [typeSig name (hsib_body $ con_type con)] + + typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty) + name = out dflags $ map unL $ getConNames con - resType = case con_res con of - ResTyH98 -> apps $ map (reL . HsTyVar) $ - (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvBndrs $ tyClDeclTyVars dat] - ResTyGADT _ x -> x + +ppFixity :: DynFlags -> (Name, Fixity) -> [String] +ppFixity dflags (name, fixity) = [out dflags (FixitySig [noLoc name] fixity)] --------------------------------------------------------------------- @@ -334,3 +383,8 @@ escape = concatMap f f '>' = ">" f '&' = "&" f x = [x] + + +-- | Just like 'vcat' but uses '($+$)' instead of '($$)'. +vcat' :: [SDoc] -> SDoc +vcat' = foldr ($+$) empty diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs new file mode 100644 index 00000000..248a8a54 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -0,0 +1,64 @@ +module Haddock.Backends.Hyperlinker + ( ppHyperlinkedSource + , module Haddock.Backends.Hyperlinker.Types + , module Haddock.Backends.Hyperlinker.Utils + ) where + + +import Haddock.Types +import Haddock.Backends.Hyperlinker.Renderer +import Haddock.Backends.Hyperlinker.Types +import Haddock.Backends.Hyperlinker.Utils + +import Text.XHtml hiding ((</>)) + +import Data.Maybe +import System.Directory +import System.FilePath + + +-- | Generate hyperlinked source for given interfaces. +-- +-- Note that list of interfaces should also contain interfaces normally hidden +-- when generating documentation. Otherwise this could lead to dead links in +-- produced source. +ppHyperlinkedSource :: FilePath -- ^ Output directory + -> FilePath -- ^ Resource directory + -> Maybe FilePath -- ^ Custom CSS file path + -> Bool -- ^ Flag indicating whether to pretty-print HTML + -> SrcMap -- ^ Paths to sources + -> [Interface] -- ^ Interfaces for which we create source + -> IO () +ppHyperlinkedSource outdir libdir mstyle pretty srcs ifaces = do + createDirectoryIfMissing True srcdir + let cssFile = fromMaybe (defaultCssFile libdir) mstyle + copyFile cssFile $ srcdir </> srcCssFile + copyFile (libdir </> "html" </> highlightScript) $ + srcdir </> highlightScript + mapM_ (ppHyperlinkedModuleSource srcdir pretty srcs) ifaces + where + srcdir = outdir </> hypSrcDir + +-- | Generate hyperlinked source for particular interface. +ppHyperlinkedModuleSource :: FilePath -> Bool -> SrcMap -> Interface + -> IO () +ppHyperlinkedModuleSource srcdir pretty srcs iface = + case ifaceTokenizedSrc iface of + Just tokens -> writeFile path . html . render' $ tokens + Nothing -> return () + where + render' = render (Just srcCssFile) (Just highlightScript) srcs + html = if pretty then renderHtml else showHtml + path = srcdir </> hypSrcModuleFile (ifaceMod iface) + +-- | Name of CSS file in output directory. +srcCssFile :: FilePath +srcCssFile = "style.css" + +-- | Name of highlight script in output and resource directory. +highlightScript :: FilePath +highlightScript = "highlight.js" + +-- | Path to default CSS file. +defaultCssFile :: FilePath -> FilePath +defaultCssFile libdir = libdir </> "html" </> "solarized.css" diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs new file mode 100644 index 00000000..e8baae88 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + + +module Haddock.Backends.Hyperlinker.Ast (enrich) where + + +import Haddock.Syb +import Haddock.Backends.Hyperlinker.Types + +import qualified GHC + +import Control.Applicative +import Data.Data +import Data.Maybe + + +-- | Add more detailed information to token stream using GHC API. +enrich :: GHC.RenamedSource -> [Token] -> [RichToken] +enrich src = + map $ \token -> RichToken + { rtkToken = token + , rtkDetails = enrichToken token detailsMap + } + where + detailsMap = concatMap ($ src) + [ variables + , types + , decls + , binds + , imports + ] + +-- | 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)] + +lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails +lookupBySpan tspan = listToMaybe . map snd . filter (matches tspan . fst) + +enrichToken :: Token -> DetailsMap -> Maybe TokenDetails +enrichToken (Token typ _ spn) dm + | typ `elem` [TkIdentifier, TkOperator] = lookupBySpan spn dm +enrichToken _ _ = Nothing + +-- | Obtain details map for variables ("normally" used identifiers). +variables :: GHC.RenamedSource -> DetailsMap +variables = + everything (<|>) (var `combine` rec) + where + var term = case cast term of + (Just (GHC.L sspan (GHC.HsVar name))) -> + 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) _) -> + pure (sspan, RtkVar name) + _ -> empty + +-- | Obtain details map for types. +types :: GHC.RenamedSource -> DetailsMap +types = + everything (<|>) ty + where + ty term = case cast term of + (Just (GHC.L sspan (GHC.HsTyVar name))) -> + pure (sspan, RtkType (GHC.unLoc name)) + _ -> empty + +-- | Obtain details map for identifier bindings. +-- +-- That includes both identifiers bound by pattern matching or declared using +-- ordinary assignment (in top-level declarations, let-expressions and where +-- clauses). +binds :: GHC.RenamedSource -> DetailsMap +binds = + everything (<|>) (fun `combine` pat `combine` tvar) + where + fun term = case cast term of + (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name)) -> + pure (sspan, RtkBind name) + _ -> empty + pat term = case cast term of + (Just (GHC.L sspan (GHC.VarPat name))) -> + pure (sspan, RtkBind (GHC.unLoc name)) + (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) -> + [(sspan, RtkVar name)] ++ everything (<|>) rec recs + (Just (GHC.L _ (GHC.AsPat (GHC.L sspan name) _))) -> + pure (sspan, RtkBind name) + _ -> empty + rec term = case cast term of + (Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LPat GHC.Name) _)) -> + pure (sspan, RtkVar name) + _ -> empty + tvar term = case cast term of + (Just (GHC.L sspan (GHC.UserTyVar name))) -> + 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 (group, _, _, _) = concatMap ($ group) + [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds + , everything (<|>) fun . GHC.hs_valds + , everything (<|>) (con `combine` ins) + ] + where + typ (GHC.L _ t) = case t of + GHC.DataDecl 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 + fun term = case cast term of + (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name)) + | GHC.isExternalName name -> pure (sspan, RtkDecl name) + _ -> empty + con term = case cast term of + (Just cdcl) -> + map decl (GHC.getConNames cdcl) ++ everything (<|>) 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 + _ -> empty + fld term = case cast term of + Just (field :: GHC.ConDeclField GHC.Name) + -> map (decl . fmap GHC.selectorFieldOcc) $ GHC.cd_fld_names field + Nothing -> empty + sig (GHC.L _ (GHC.TypeSig names _)) = map decl names + sig _ = [] + decl (GHC.L sspan name) = (sspan, RtkDecl name) + tyref (GHC.L sspan name) = (sspan, RtkType name) + +-- | Obtain details map for import declarations. +-- +-- This map also includes type and variable details for items in export and +-- import lists. +imports :: GHC.RenamedSource -> DetailsMap +imports src@(_, imps, _, _) = + everything (<|>) ie src ++ mapMaybe (imp . GHC.unLoc) imps + where + ie term = case cast term of + (Just (GHC.IEVar v)) -> pure $ var v + (Just (GHC.IEThingAbs t)) -> pure $ typ t + (Just (GHC.IEThingAll t)) -> pure $ typ t + (Just (GHC.IEThingWith t _ vs _fls)) -> + [typ t] ++ map var vs + _ -> 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 diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs new file mode 100644 index 00000000..e206413e --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -0,0 +1,204 @@ +module Haddock.Backends.Hyperlinker.Parser (parse) where + + +import Data.Char +import Data.List +import Data.Maybe + +import Haddock.Backends.Hyperlinker.Types + + +-- | Turn source code string into a stream of more descriptive tokens. +-- +-- 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 + +-- | Split raw source string to more meaningful chunks. +-- +-- 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] + where + chunk' (c, rest) = c:(chunk rest) + +-- | Split input to "first line" string and the rest of it. +-- +-- 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) + +-- | Split input to whitespace string, (optional) preprocessor directive and +-- the rest of it. +-- +-- 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) + +-- | Split input to comment content (including delimiters) and the rest. +-- +-- 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) + +-- | 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 + where + aux (sp, str) = Token + { tkType = classify str + , tkValue = str + , tkSpan = sp + } + +-- | 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 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 + +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" + ] + +glyphs :: [String] +glyphs = + [ ".." + , ":" + , "::" + , "=" + , "\\" + , "|" + , "<-" + , "->" + , "@" + , "~" + , "~#" + , "=>" + , "-" + , "!" + ] + +special :: [Char] +special = "()[]{},;`" + +-- 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 diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs new file mode 100644 index 00000000..15793f0c --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE RecordWildCards #-} + + +module Haddock.Backends.Hyperlinker.Renderer (render) where + + +import Haddock.Backends.Hyperlinker.Types +import Haddock.Backends.Hyperlinker.Utils + +import qualified GHC +import qualified Name as GHC +import qualified Unique as GHC + +import System.FilePath.Posix ((</>)) + +import Data.List +import Data.Maybe +import Data.Monoid +import qualified Data.Map as Map + +import Text.XHtml (Html, HtmlAttr, (!)) +import qualified Text.XHtml as Html + + +type StyleClass = String + + +render :: Maybe FilePath -> Maybe FilePath -> SrcMap -> [RichToken] + -> Html +render mcss mjs srcs tokens = header mcss mjs <> body srcs tokens + + +data TokenGroup + = GrpNormal Token + | GrpRich TokenDetails [Token] + + +-- | Group consecutive tokens pointing to the same element. +-- +-- We want to render qualified identifiers as one entity. For example, +-- @Bar.Baz.foo@ consists of 5 tokens (@Bar@, @.@, @Baz@, @.@, @foo@) but for +-- better user experience when highlighting and clicking links, these tokens +-- should be regarded as one identifier. Therefore, before rendering we must +-- group consecutive elements pointing to the same 'GHC.Name' (note that even +-- dot token has it if it is part of qualified name). +groupTokens :: [RichToken] -> [TokenGroup] +groupTokens [] = [] +groupTokens ((RichToken tok Nothing):rest) = (GrpNormal tok):(groupTokens rest) +groupTokens ((RichToken tok (Just det)):rest) = + let (grp, rest') = span same rest + in (GrpRich det (tok:(map rtkToken grp))):(groupTokens rest') + where + same (RichToken _ (Just det')) = det == det' + same _ = False + + +body :: SrcMap -> [RichToken] -> Html +body srcs tokens = + Html.body . Html.pre $ hypsrc + where + hypsrc = mconcat . map (tokenGroup srcs) . groupTokens $ tokens + + +header :: Maybe FilePath -> Maybe FilePath -> Html +header mcss mjs + | isNothing mcss && isNothing mjs = Html.noHtml +header mcss mjs = + Html.header $ css mcss <> js mjs + where + css Nothing = Html.noHtml + css (Just cssFile) = Html.thelink Html.noHtml ! + [ Html.rel "stylesheet" + , Html.thetype "text/css" + , Html.href cssFile + ] + js Nothing = Html.noHtml + js (Just scriptFile) = Html.script Html.noHtml ! + [ Html.thetype "text/javascript" + , Html.src scriptFile + ] + + +tokenGroup :: SrcMap -> TokenGroup -> Html +tokenGroup _ (GrpNormal tok@(Token { .. })) + | tkType == TkSpace = renderSpace (posRow . spStart $ tkSpan) tkValue + | otherwise = tokenSpan tok ! attrs + where + attrs = [ multiclass . tokenStyle $ tkType ] +tokenGroup srcs (GrpRich det tokens) = + externalAnchor det . internalAnchor det . hyperlink srcs det $ content + where + content = mconcat . map (richToken det) $ tokens + + +richToken :: TokenDetails -> Token -> Html +richToken det tok = + tokenSpan tok ! [ multiclass style ] + where + style = (tokenStyle . tkType) tok ++ richTokenStyle det + + +tokenSpan :: Token -> Html +tokenSpan = Html.thespan . Html.toHtml . tkValue + + +richTokenStyle :: TokenDetails -> [StyleClass] +richTokenStyle (RtkVar _) = ["hs-var"] +richTokenStyle (RtkType _) = ["hs-type"] +richTokenStyle _ = [] + +tokenStyle :: TokenType -> [StyleClass] +tokenStyle TkIdentifier = ["hs-identifier"] +tokenStyle TkKeyword = ["hs-keyword"] +tokenStyle TkString = ["hs-string"] +tokenStyle TkChar = ["hs-char"] +tokenStyle TkNumber = ["hs-number"] +tokenStyle TkOperator = ["hs-operator"] +tokenStyle TkGlyph = ["hs-glyph"] +tokenStyle TkSpecial = ["hs-special"] +tokenStyle TkSpace = [] +tokenStyle TkComment = ["hs-comment"] +tokenStyle TkCpp = ["hs-cpp"] +tokenStyle TkPragma = ["hs-pragma"] +tokenStyle TkUnknown = [] + +multiclass :: [StyleClass] -> HtmlAttr +multiclass = Html.theclass . intercalate " " + +externalAnchor :: TokenDetails -> Html -> Html +externalAnchor (RtkDecl name) content = + Html.anchor content ! [ Html.name $ externalAnchorIdent name ] +externalAnchor _ content = content + +internalAnchor :: TokenDetails -> Html -> Html +internalAnchor (RtkBind name) content = + Html.anchor content ! [ Html.name $ internalAnchorIdent name ] +internalAnchor _ content = content + +externalAnchorIdent :: GHC.Name -> String +externalAnchorIdent = hypSrcNameUrl + +internalAnchorIdent :: GHC.Name -> String +internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique + +hyperlink :: SrcMap -> TokenDetails -> Html -> Html +hyperlink srcs details = case rtkName details of + Left name -> + if GHC.isInternalName name + then internalHyperlink name + else externalNameHyperlink srcs name + Right name -> externalModHyperlink srcs name + +internalHyperlink :: GHC.Name -> Html -> Html +internalHyperlink name content = + Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] + +externalNameHyperlink :: SrcMap -> GHC.Name -> Html -> Html +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 ! + [ Html.href $ path </> hypSrcModuleNameUrl mdl name ] + Nothing -> content + where + 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 ! + [ Html.href $ hypSrcModuleUrl' name ] + Just (SrcExternal path) -> Html.anchor content ! + [ Html.href $ path </> hypSrcModuleUrl' name ] + Nothing -> content + + +renderSpace :: Int -> String -> Html +renderSpace _ [] = Html.noHtml +renderSpace line ('\n':rest) = mconcat + [ Html.thespan . Html.toHtml $ "\n" + , lineAnchor (line + 1) + , renderSpace (line + 1) rest + ] +renderSpace line space = + let (hspace, rest) = span (/= '\n') space + in (Html.thespan . Html.toHtml) hspace <> renderSpace line rest + + +lineAnchor :: Int -> Html +lineAnchor line = Html.anchor Html.noHtml ! [ Html.name $ hypSrcLineUrl line ] diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs new file mode 100644 index 00000000..5f4dbc8c --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs @@ -0,0 +1,85 @@ +module Haddock.Backends.Hyperlinker.Types where + + +import qualified GHC + +import Data.Map (Map) +import qualified Data.Map as Map + + +data Token = Token + { tkType :: TokenType + , tkValue :: String + , tkSpan :: Span + } + +data Position = Position + { posRow :: !Int + , posCol :: !Int + } + +data Span = Span + { spStart :: Position + , spEnd :: Position + } + +data TokenType + = TkIdentifier + | TkKeyword + | TkString + | TkChar + | TkNumber + | TkOperator + | TkGlyph + | TkSpecial + | TkSpace + | TkComment + | TkCpp + | TkPragma + | TkUnknown + deriving (Show, Eq) + + +data RichToken = RichToken + { rtkToken :: Token + , rtkDetails :: Maybe TokenDetails + } + +data TokenDetails + = RtkVar GHC.Name + | RtkType GHC.Name + | RtkBind GHC.Name + | RtkDecl GHC.Name + | RtkModule GHC.ModuleName + deriving (Eq) + + +rtkName :: TokenDetails -> Either GHC.Name GHC.ModuleName +rtkName (RtkVar name) = Left name +rtkName (RtkType name) = Left name +rtkName (RtkBind name) = Left name +rtkName (RtkDecl name) = Left name +rtkName (RtkModule name) = Right name + + +-- | Path for making cross-package hyperlinks in generated sources. +-- +-- Used in 'SrcMap' to determine whether module originates in current package +-- or in an external package. +data SrcPath + = SrcExternal FilePath + | 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) + +mkSrcMap :: Map GHC.Module SrcPath -> SrcMap +mkSrcMap srcs = (srcs, Map.mapKeys GHC.moduleName srcs) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs new file mode 100644 index 00000000..9de4a03d --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs @@ -0,0 +1,68 @@ +module Haddock.Backends.Hyperlinker.Utils + ( hypSrcDir, hypSrcModuleFile, hypSrcModuleFile' + , hypSrcModuleUrl, hypSrcModuleUrl' + , hypSrcNameUrl + , hypSrcLineUrl + , hypSrcModuleNameUrl, hypSrcModuleLineUrl + , hypSrcModuleUrlFormat + , hypSrcModuleNameUrlFormat, hypSrcModuleLineUrlFormat + ) where + + +import Haddock.Backends.Xhtml.Utils + +import GHC +import FastString +import System.FilePath.Posix ((</>)) + + +hypSrcDir :: FilePath +hypSrcDir = "src" + +hypSrcModuleFile :: Module -> FilePath +hypSrcModuleFile = hypSrcModuleFile' . moduleName + +hypSrcModuleFile' :: ModuleName -> FilePath +hypSrcModuleFile' mdl = spliceURL' + Nothing (Just mdl) Nothing Nothing moduleFormat + +hypSrcModuleUrl :: Module -> String +hypSrcModuleUrl = hypSrcModuleFile + +hypSrcModuleUrl' :: ModuleName -> String +hypSrcModuleUrl' = hypSrcModuleFile' + +hypSrcNameUrl :: Name -> String +hypSrcNameUrl name = spliceURL + Nothing Nothing (Just name) Nothing nameFormat + +hypSrcLineUrl :: Int -> String +hypSrcLineUrl line = spliceURL + Nothing Nothing Nothing (Just spn) lineFormat + where + loc = mkSrcLoc nilFS line 1 + spn = mkSrcSpan loc loc + +hypSrcModuleNameUrl :: Module -> Name -> String +hypSrcModuleNameUrl mdl name = hypSrcModuleUrl mdl ++ "#" ++ hypSrcNameUrl name + +hypSrcModuleLineUrl :: Module -> Int -> String +hypSrcModuleLineUrl mdl line = hypSrcModuleUrl mdl ++ "#" ++ hypSrcLineUrl line + +hypSrcModuleUrlFormat :: String +hypSrcModuleUrlFormat = hypSrcDir </> moduleFormat + +hypSrcModuleNameUrlFormat :: String +hypSrcModuleNameUrlFormat = hypSrcModuleUrlFormat ++ "#" ++ nameFormat + +hypSrcModuleLineUrlFormat :: String +hypSrcModuleLineUrlFormat = hypSrcModuleUrlFormat ++ "#" ++ lineFormat + +moduleFormat :: String +moduleFormat = "%{MODULE}.html" + +nameFormat :: String +nameFormat = "%{NAME}" + +lineFormat :: String +lineFormat = "line-%{LINE}" diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index c9262c7e..ab6bb41c 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# LANGUAGE RecordWildCards #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Backends.LaTeX @@ -212,9 +213,9 @@ processExports (e : es) = isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName) -isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames (L _ t) _)) +isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames t)) , expItemMbDoc = (Documentation Nothing Nothing, argDocs) } - | Map.null argDocs = Just (map unLoc lnames, t) + | Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t)) isSimpleSig _ = Nothing @@ -249,8 +250,8 @@ ppDocGroup lev doc = sec lev <> braces doc declNames :: LHsDecl DocName -> [DocName] declNames (L _ decl) = case decl of TyClD d -> [tcdName d] - SigD (TypeSig lnames _ _) -> map unLoc lnames - SigD (PatSynSig lname _ _ _ _) -> [unLoc lname] + SigD (TypeSig lnames _ ) -> map unLoc lnames + SigD (PatSynSig lname _) -> [unLoc lname] ForD (ForeignImport (L _ n) _ _ _) -> [n] ForD (ForeignExport (L _ n) _ _ _) -> [n] _ -> error "declaration not supported by declNames" @@ -292,10 +293,11 @@ ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of -- TyClD d@(TySynonym {}) -- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode -- Family instances happen via FamInst now - TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode - SigD (TypeSig lnames (L _ t) _) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) t unicode - SigD (PatSynSig lname qtvs prov req ty) -> - ppLPatSig loc (doc, fnArgsDoc) lname qtvs prov req ty unicode + TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode + SigD (TypeSig lnames t) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) + (hsSigWcType t) unicode + SigD (PatSynSig lname ty) -> + ppLPatSig loc (doc, fnArgsDoc) lname ty unicode ForD d -> ppFor loc (doc, fnArgsDoc) d unicode InstD _ -> empty _ -> error "declaration not supported by ppDecl" @@ -310,8 +312,8 @@ ppTyFam _ _ _ _ _ = ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> LaTeX -ppFor loc doc (ForeignImport (L _ name) (L _ typ) _ _) unicode = - ppFunSig loc doc [name] typ unicode +ppFor loc doc (ForeignImport (L _ name) typ _ _) unicode = + ppFunSig loc doc [name] (hsSigType typ) unicode ppFor _ _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" -- error "foreign declarations are currently not supported by --latex" @@ -328,7 +330,9 @@ ppTySyn loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars , tcdRhs = ltype }) unicode = ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode where - hdr = hsep (keyword "type" : ppDocBinder name : ppTyVars ltyvars) + hdr = hsep (keyword "type" + : ppDocBinder name + : map ppSymName (tyvarNames ltyvars)) full = hdr <+> char '=' <+> ppLType unicode ltype ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn" @@ -339,9 +343,9 @@ ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn" ------------------------------------------------------------------------------- -ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> HsType DocName +ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> LHsType DocName -> Bool -> LaTeX -ppFunSig loc doc docnames typ unicode = +ppFunSig loc doc docnames (L _ typ) unicode = ppTypeOrFunSig loc docnames typ doc ( ppTypeSig names typ False , hsep . punctuate comma $ map ppSymName names @@ -351,29 +355,17 @@ ppFunSig loc doc docnames typ unicode = names = map getName docnames ppLPatSig :: SrcSpan -> DocForDecl DocName -> Located DocName - -> (HsExplicitFlag, LHsTyVarBndrs DocName) - -> LHsContext DocName -> LHsContext DocName - -> LHsType DocName + -> LHsSigType DocName -> Bool -> LaTeX -ppLPatSig _loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq (L _ ty) unicode +ppLPatSig _loc (doc, _argDocs) (L _ name) ty unicode = declWithDoc pref1 (documentationToLaTeX doc) where pref1 = hsep [ keyword "pattern" , ppDocBinder name , dcolon unicode - , ppLTyVarBndrs expl qtvs unicode - , ctx - , ppType unicode ty + , ppLType unicode (hsSigType ty) ] - ctx = case (ppLContextMaybe lprov unicode, ppLContextMaybe lreq unicode) of - (Nothing, Nothing) -> empty - (Nothing, Just req) -> parens empty <+> darr <+> req <+> darr - (Just prov, Nothing) -> prov <+> darr - (Just prov, Just req) -> prov <+> darr <+> req <+> darr - - darr = darrow unicode - ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX) -> Bool -> LaTeX @@ -392,23 +384,15 @@ ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0) arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs - do_args :: Int -> LaTeX -> (HsType DocName) -> LaTeX - do_args n leader (HsForAllTy Explicit _ tvs lctxt ltype) - = decltt leader <-> - decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+> - ppLContextNoArrow lctxt unicode) <+> nl $$ - do_largs n (darrow unicode) ltype - - do_args n leader (HsForAllTy Qualified e a lctxt ltype) - = do_args n leader (HsForAllTy Implicit e a lctxt ltype) - do_args n leader (HsForAllTy Implicit _ _ lctxt ltype) - | not (null (unLoc lctxt)) - = decltt leader <-> decltt (ppLContextNoArrow lctxt unicode) <+> nl $$ - do_largs n (darrow unicode) ltype - -- if we're not showing any 'forall' or class constraints or - -- anything, skip having an empty line for the context. - | otherwise - = do_largs n leader ltype + do_args :: Int -> LaTeX -> HsType DocName -> LaTeX + do_args _n leader (HsForAllTy tvs ltype) + = decltt leader + <-> decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot])) + <+> ppLType unicode ltype + do_args n leader (HsQualTy lctxt ltype) + = decltt leader + <-> ppLContextNoArrow lctxt unicode <+> nl $$ + do_largs n (darrow unicode) ltype do_args n leader (HsFunTy lt r) = decltt leader <-> decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl $$ do_largs (n+1) (arrow unicode) r @@ -423,12 +407,12 @@ ppTypeSig nms ty unicode = <+> ppType unicode ty -ppTyVars :: LHsTyVarBndrs DocName -> [LaTeX] -ppTyVars tvs = map ppSymName (tyvarNames tvs) +ppTyVars :: [LHsTyVarBndr DocName] -> [LaTeX] +ppTyVars = map (ppSymName . getName . hsLTyVarName) -tyvarNames :: LHsTyVarBndrs DocName -> [Name] -tyvarNames = map getName . hsLTyVarNames +tyvarNames :: LHsQTyVars DocName -> [Name] +tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX @@ -477,12 +461,12 @@ rDoc = maybeDoc . fmap latexStripTrailingWhitespace ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName - -> LHsTyVarBndrs DocName -> [Located ([Located DocName], [Located DocName])] + -> LHsQTyVars DocName -> [Located ([Located DocName], [Located DocName])] -> Bool -> LaTeX ppClassHdr summ lctxt n tvs fds unicode = keyword "class" <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else empty) - <+> ppAppDocNameNames summ n (tyvarNames $ tvs) + <+> ppAppDocNameNames summ n (tyvarNames tvs) <+> ppFds fds unicode @@ -520,8 +504,8 @@ ppClassDecl instances loc doc subdocs methodTable = text "\\haddockpremethods{}\\textbf{Methods}" $$ - vcat [ ppFunSig loc doc names typ unicode - | L _ (TypeSig lnames (L _ typ) _) <- lsigs + vcat [ ppFunSig loc doc names (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 @@ -544,14 +528,14 @@ ppDocInstances unicode (i : rest) (is, rest') = spanWith isUndocdInstance rest isUndocdInstance :: DocInstance a -> Maybe (InstHead a) -isUndocdInstance (i,Nothing) = Just i +isUndocdInstance (i,Nothing,_) = Just i isUndocdInstance _ = Nothing -- | 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 unicode (instHead, doc) = +ppDocInstance unicode (instHead, doc, _) = declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX $ fmap _doc doc) @@ -560,12 +544,13 @@ ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead ppInstHead :: Bool -> InstHead DocName -> LaTeX -ppInstHead unicode (n, ks, ts, ClassInst ctx) = ppContextNoLocs ctx unicode <+> ppAppNameTypes n ks ts unicode -ppInstHead unicode (n, ks, ts, TypeInst rhs) = keyword "type" - <+> ppAppNameTypes n ks ts unicode - <+> maybe empty (\t -> equals <+> ppType unicode t) rhs -ppInstHead _unicode (_n, _ks, _ts, DataInst _dd) = - error "data instances not supported by --latex yet" +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 + tibody = maybe empty (\t -> equals <+> ppType unicode t) lookupAnySubdoc :: (Eq name1) => name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2 @@ -591,14 +576,14 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode where cons = dd_cons (tcdDataDefn dataDecl) - resTy = (con_res . unLoc . head) cons + resTy = (unLoc . head) cons body = catMaybes [constrBit, doc >>= documentationToLaTeX] (whereBit, leaders) | null cons = (empty,[]) | otherwise = case resTy of - ResTyGADT _ _ -> (decltt (keyword "where"), repeat empty) + ConDeclGADT{} -> (decltt (keyword "where"), repeat empty) _ -> (empty, (decltt (text "=") : repeat (decltt (text "|")))) constrBit @@ -612,21 +597,85 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode -- ppConstrHdr is for (non-GADT) existentials constructors' syntax -ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool -> LaTeX +ppConstrHdr :: Bool -> [Name] -> HsContext DocName -> Bool -> LaTeX ppConstrHdr forall tvs ctxt unicode = (if null tvs then empty else ppForall) <+> (if null ctxt then empty else ppContextNoArrow ctxt unicode <+> darrow unicode <+> text " ") where ppForall = case forall of - Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". " - Qualified -> empty - Implicit -> empty + True -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". " + False -> empty + + +ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX + -> LConDecl DocName -> LaTeX +ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclH98 {})) = + leader <-> + case con_details con of + + PrefixCon args -> + decltt (hsep ((header_ unicode <+> ppOcc) : + map (ppLParendType unicode) args)) + <-> rDoc mbDoc <+> nl + + RecCon (L _ fields) -> + (decltt (header_ unicode <+> ppOcc) + <-> rDoc mbDoc <+> nl) + $$ + doRecordFields fields + + InfixCon arg1 arg2 -> + decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1, + ppOcc, + ppLParendType unicode arg2 ]) + <-> rDoc mbDoc <+> nl + + where + doRecordFields fields = + vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields)) + + + header_ = ppConstrHdr False tyVars context + occ = map (nameOccName . getName . unLoc) $ getConNames con + ppOcc = case occ of + [one] -> ppBinder one + _ -> cat (punctuate comma (map ppBinder occ)) + tyVars = tyvarNames (fromMaybe (HsQTvs PlaceHolder []) (con_qvars con)) + context = unLoc (fromMaybe (noLoc []) (con_cxt con)) + + -- don't use "con_doc con", in case it's reconstructed from a .hi file, + -- or also because we want Haddock to do the doc-parsing, not GHC. + mbDoc = case getConNames con of + [] -> panic "empty con_names" + (cn:_) -> lookup (unLoc cn) subdocs >>= + fmap _doc . combineDocumentation . fst + +ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclGADT {})) = + leader <-> + doGADTCon (hsib_body $ con_type con) + + where + doGADTCon resTy = decltt (ppOcc <+> dcolon unicode <+> + ppLType unicode resTy + ) <-> rDoc mbDoc + + occ = map (nameOccName . getName . unLoc) $ getConNames con + ppOcc = case occ of + [one] -> ppBinder one + _ -> cat (punctuate comma (map ppBinder occ)) + -- don't use "con_doc con", in case it's reconstructed from a .hi file, + -- or also because we want Haddock to do the doc-parsing, not GHC. + mbDoc = case getConNames con of + [] -> panic "empty con_names" + (cn:_) -> lookup (unLoc cn) subdocs >>= + fmap _doc . combineDocumentation . fst +{- old ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX -> LConDecl DocName -> LaTeX -ppSideBySideConstr subdocs unicode leader (L _ con) = +ppSideBySideConstr subdocs unicode leader (L loc con) = leader <-> case con_res con of ResTyH98 -> case con_details con of @@ -660,13 +709,13 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = doRecordFields fields = vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields)) - doGADTCon args resTy = decltt (ppOcc <+> dcolon unicode <+> hsep [ - ppForAll forall ltvs (con_cxt con) unicode, - ppLType unicode (foldr mkFunTy resTy args) ] + doGADTCon args resTy = decltt (ppOcc <+> dcolon unicode <+> + ppLType unicode (mk_forall $ mk_phi $ + foldr mkFunTy resTy args) ) <-> rDoc mbDoc - header_ = ppConstrHdr forall tyVars context + header_ = ppConstrHdr (con_explicit con) tyVars context occ = map (nameOccName . getName . unLoc) $ con_names con ppOcc = case occ of [one] -> ppBinder one @@ -674,7 +723,12 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = ltvs = con_qvars con tyVars = tyvarNames (con_qvars con) context = unLoc (con_cxt con) - forall = con_explicit con + + mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvExplicit ltvs) ty) + | otherwise = ty + mk_phi ty | null context = ty + | otherwise = L loc (HsQualTy (con_cxt con) ty) + -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. mbDoc = case con_names con of @@ -682,16 +736,16 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = (cn:_) -> lookup (unLoc cn) subdocs >>= fmap _doc . combineDocumentation . fst mkFunTy a b = noLoc (HsFunTy a b) - +-} ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> LaTeX ppSideBySideField subdocs unicode (ConDeclField names ltype _) = - decltt (cat (punctuate comma (map (ppBinder . nameOccName . getName . unL) names)) + decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc 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 (unL $ head names) subdocs >>= fmap _doc . combineDocumentation . fst + mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst -- {- -- ppHsFullConstr :: HsConDecl -> LaTeX @@ -790,9 +844,6 @@ ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> LaTeX ppLContext = ppContext . unLoc ppLContextNoArrow = ppContextNoArrow . unLoc -ppLContextMaybe :: Located (HsContext DocName) -> Bool -> Maybe LaTeX -ppLContextMaybe = ppContextNoLocsMaybe . map unLoc . unLoc - ppContextNoLocsMaybe :: [HsType DocName] -> Bool -> Maybe LaTeX ppContextNoLocsMaybe [] _ = Nothing ppContextNoLocsMaybe cxt unicode = Just $ pp_hs_context cxt unicode @@ -822,9 +873,10 @@ pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt) ------------------------------------------------------------------------------- -ppBang :: HsBang -> LaTeX -ppBang HsNoBang = empty -ppBang _ = char '!' -- Unpacked args is an implementation detail, +ppBang :: HsSrcBang -> LaTeX +ppBang (HsSrcBang _ _ SrcStrict) = char '!' +ppBang (HsSrcBang _ _ SrcLazy) = char '~' +ppBang _ = empty tupleParens :: HsTupleSort -> [LaTeX] -> LaTeX @@ -877,33 +929,22 @@ 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 -ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName - -> Located (HsContext DocName) -> Bool -> LaTeX -ppForAll expl tvs cxt unicode = ppLTyVarBndrs expl tvs unicode <+> ppLContext cxt unicode - -ppLTyVarBndrs :: HsExplicitFlag -> LHsTyVarBndrs DocName - -> Bool -> LaTeX -ppLTyVarBndrs expl tvs unicode - | show_forall = hsep (forallSymbol unicode : ppTyVars tvs) <> dot - | otherwise = empty - where - show_forall = not (null (hsQTvBndrs tvs)) && is_explicit - is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False} - ppr_mono_lty :: Int -> LHsType DocName -> 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 ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode +ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode = maybeParen ctxt_prec pREC_FUN $ - hsep [ppForAll expl tvs ctxt' unicode, ppr_mono_lty pREC_TOP ty unicode] - where ctxt' = case extra of - Just loc -> (++ [L loc HsWildcardTy]) `fmap` ctxt - Nothing -> ctxt + sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> dot + , ppr_mono_lty pREC_TOP ty unicode ] +ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode + = maybeParen ctxt_prec pREC_FUN $ + sep [ ppLContext ctxt unicode + , ppr_mono_lty pREC_TOP ty unicode ] ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty -ppr_mono_ty _ (HsTyVar name) _ = ppDocName name +ppr_mono_ty _ (HsTyVar (L _ name)) _ = ppDocName name ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys) ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind) @@ -915,7 +956,6 @@ ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy" ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty _ (HsExplicitListTy _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys ppr_mono_ty _ (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys -ppr_mono_ty _ (HsWrapTy {}) _ = error "ppr_mono_ty HsWrapTy" ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode = maybeParen ctxt_prec pREC_OP $ @@ -925,7 +965,7 @@ ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode = maybeParen ctxt_prec pREC_CON $ hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode] -ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode +ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode = maybeParen ctxt_prec pREC_FUN $ ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode where @@ -939,12 +979,14 @@ ppr_mono_ty ctxt_prec (HsParTy ty) unicode ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode = ppr_mono_lty ctxt_prec ty unicode -ppr_mono_ty _ HsWildcardTy _ = char '_' +ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ = char '_' -ppr_mono_ty _ (HsNamedWildcardTy name) _ = ppDocName name +ppr_mono_ty _ (HsWildCardTy (NamedWildCard (L _ name))) _ = ppDocName name ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u +ppr_mono_ty _ (HsAppsTy {}) _ = panic "ppr_mono_ty:HsAppsTy" + ppr_tylit :: HsTyLit -> Bool -> LaTeX ppr_tylit (HsNumTy _ n) _ = integer n diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 6ef1e863..1554a33c 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -36,7 +36,6 @@ import Haddock.GhcUtils import Control.Monad ( when, unless ) import Data.Char ( toUpper ) -import Data.Functor ( (<$>) ) import Data.List ( sortBy, groupBy, intercalate, isPrefixOf ) import Data.Maybe import System.FilePath hiding ( (</>) ) @@ -305,7 +304,7 @@ mkNode qual ss p (Node s leaf pkg srcPkg short ts) = htmlModule = thespan ! modAttrs << (cBtn +++ if leaf - then ppModule (mkModule (stringToPackageKey (fromMaybe "" pkg)) + then ppModule (mkModule (stringToUnitId (fromMaybe "" pkg)) (mkModuleName mdl)) else toHtml s ) @@ -547,7 +546,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual synopsis | no_doc_at_all = noHtml | otherwise - = divSynposis $ + = divSynopsis $ paragraph ! collapseControl "syn" False "caption" << "Synopsis" +++ shortDeclList ( mapMaybe (processExport True linksInfo unicode qual) exports @@ -584,7 +583,7 @@ processForMiniSynopsis mdl unicode qual ExportDecl { expItemDecl = L _loc decl0 (DataDecl{}) -> [keyword "data" <+> b] (SynDecl{}) -> [keyword "type" <+> b] (ClassDecl {}) -> [keyword "class" <+> b] - SigD (TypeSig lnames (L _ _) _) -> + SigD (TypeSig lnames _) -> map (ppNameMini Prefix mdl . nameOccName . getName . unLoc) lnames _ -> [] processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) = diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 88aa966c..49149b8c 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -1,4 +1,6 @@ {-# LANGUAGE TransformListComp #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Backends.Html.Decl @@ -18,7 +20,6 @@ module Haddock.Backends.Xhtml.Decl ( tyvarNames ) where - import Haddock.Backends.Xhtml.DocMarkup import Haddock.Backends.Xhtml.Layout import Haddock.Backends.Xhtml.Names @@ -28,7 +29,6 @@ import Haddock.GhcUtils import Haddock.Types import Haddock.Doc (combineDocumentation) -import Control.Applicative import Data.List ( intersperse, sort ) import qualified Data.Map as Map import Data.Maybe @@ -38,18 +38,20 @@ import GHC import GHC.Exts import Name import BooleanFormula +import RdrName ( rdrNameOcc ) ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)] -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html ppDecl summ links (L loc decl) (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 - TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d splice unicode qual - TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual - TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual - SigD (TypeSig lnames lty _) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames lty fixities splice unicode qual - SigD (PatSynSig lname qtvs prov req ty) -> - ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname qtvs prov req ty fixities splice unicode qual + TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual + TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d splice unicode qual + TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual + TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual + SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames + (hsSigWcType lty) fixities splice unicode qual + SigD (PatSynSig lname ty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname + ty fixities splice unicode qual ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual InstD _ -> noHtml _ -> error "declaration not supported by ppDecl" @@ -59,26 +61,23 @@ ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> [Located DocName] -> LHsType DocName -> [(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) (unLoc lty) fixities + ppFunSig summary links loc doc (map unLoc lnames) lty fixities splice unicode qual ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - [DocName] -> HsType DocName -> [(DocName, Fixity)] -> + [DocName] -> LHsType DocName -> [(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 (typ, pp_typ) + ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ) splice unicode qual where - pp_typ = ppType unicode qual typ + pp_typ = ppLType unicode qual typ ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - Located DocName -> - (HsExplicitFlag, LHsTyVarBndrs DocName) -> - LHsContext DocName -> LHsContext DocName -> - LHsType DocName -> + Located DocName -> LHsSigType DocName -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html -ppLPatSig summary links loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq typ fixities splice unicode qual +ppLPatSig summary links loc (doc, _argDocs) (L _ name) typ fixities splice unicode qual | summary = pref1 | otherwise = topDeclElem links loc splice [name] (pref1 <+> ppFixities fixities qual) +++ docSection Nothing qual doc @@ -86,18 +85,9 @@ ppLPatSig summary links loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq t pref1 = hsep [ keyword "pattern" , ppBinder summary occname , dcolon unicode - , ppLTyVarBndrs expl qtvs unicode qual - , cxt - , ppLType unicode qual typ + , ppLType unicode qual (hsSigType typ) ] - cxt = case (ppLContextMaybe lprov unicode qual, ppLContextMaybe lreq unicode qual) of - (Nothing, Nothing) -> noHtml - (Nothing, Just req) -> parens noHtml <+> darr <+> req <+> darr - (Just prov, Nothing) -> prov <+> darr - (Just prov, Just req) -> prov <+> darr <+> req <+> darr - - darr = darrow unicode occname = nameOccName . getName $ name ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> @@ -131,22 +121,29 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) argDoc n = Map.lookup n argDocs do_largs n leader (L _ t) = do_args n leader t + do_args :: Int -> Html -> HsType DocName -> [SubDecl] - do_args n leader (HsForAllTy _ _ tvs lctxt ltype) - = case unLoc lctxt of - [] -> do_largs n leader' ltype - _ -> (leader' <+> ppLContextNoArrow lctxt unicode qual, Nothing, []) - : do_largs n (darrow unicode) ltype - where leader' = leader <+> ppForAll tvs unicode qual + do_args n leader (HsForAllTy tvs ltype) + = do_largs n leader' ltype + where + leader' = leader <+> ppForAll tvs unicode qual + + do_args n leader (HsQualTy lctxt ltype) + | null (unLoc lctxt) + = do_largs n leader ltype + | otherwise + = (leader <+> ppLContextNoArrow lctxt unicode qual, Nothing, []) + : do_largs n (darrow unicode) ltype + do_args n leader (HsFunTy lt r) = (leader <+> ppLFunLhType unicode qual lt, argDoc n, []) : do_largs (n+1) (arrow unicode) r do_args n leader t = [(leader <+> ppType unicode qual t, argDoc n, [])] -ppForAll :: LHsTyVarBndrs DocName -> Unicode -> Qualification -> Html +ppForAll :: [LHsTyVarBndr DocName] -> Unicode -> Qualification -> Html ppForAll tvs unicode qual = - case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- hsQTvBndrs tvs] of + case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- tvs] of [] -> noHtml ts -> forallSymbol unicode <+> hsep ts +++ dot where ppKTv n k = parens $ @@ -174,20 +171,19 @@ ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge rightEdge = thespan ! [theclass "rightedge"] << noHtml -ppTyVars :: LHsTyVarBndrs DocName -> [Html] -ppTyVars tvs = map ppTyName (tyvarNames tvs) - +ppTyVars :: [LHsTyVarBndr DocName] -> [Html] +ppTyVars tvs = map (ppTyName . getName . hsLTyVarName) tvs -tyvarNames :: LHsTyVarBndrs DocName -> [Name] -tyvarNames = map getName . hsLTyVarNames +tyvarNames :: LHsQTyVars DocName -> [Name] +tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html -ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _ _) fixities +ppFor summary links loc doc (ForeignImport (L _ name) typ _ _) fixities splice unicode qual - = ppFunSig summary links loc doc [name] typ fixities splice unicode qual + = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode qual ppFor _ _ _ _ _ _ _ _ _ = error "ppFor" @@ -202,7 +198,8 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals) splice unicode qual where - hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars) + hdr = hsep ([keyword "type", ppBinder summary occ] + ++ ppTyVars (hsQTvExplicit ltyvars)) full = hdr <+> equals <+> ppLType unicode qual ltype occ = nameOccName . getName $ name fixs @@ -222,15 +219,37 @@ ppTyName :: Name -> Html ppTyName = ppName Prefix +ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> SrcSpan + -> [DocName] -> HsType DocName + -> Html +ppSimpleSig links splice unicode qual loc names typ = + topDeclElem' names $ ppTypeSig True occNames ppTyp unicode + where + topDeclElem' = topDeclElem links loc splice + ppTyp = ppType unicode qual typ + occNames = map getOccName names + + -------------------------------------------------------------------------------- -- * Type families -------------------------------------------------------------------------------- +ppFamilyInfo :: Bool -> FamilyInfo DocName -> Html +ppFamilyInfo assoc OpenTypeFamily + | assoc = keyword "type" + | otherwise = keyword "type family" +ppFamilyInfo assoc DataFamily + | assoc = keyword "data" + | otherwise = keyword "data family" +ppFamilyInfo _ (ClosedTypeFamily _) = keyword "type family" + + ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName -> Unicode -> Qualification -> Html ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info - , fdKindSig = mkind }) + , fdResultSig = L _ result + , fdInjectivityAnn = injectivity }) unicode qual = (case info of OpenTypeFamily @@ -244,12 +263,32 @@ ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info ) <+> ppFamDeclBinderWithVars summary d <+> + ppResultSig result unicode qual <+> - (case mkind of - Just kind -> dcolon unicode <+> ppLKind unicode qual kind - Nothing -> noHtml + (case injectivity of + Nothing -> noHtml + Just (L _ injectivityAnn) -> ppInjectivityAnn unicode qual injectivityAnn ) +ppResultSig :: FamilyResultSig DocName -> 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 + -> Html +ppPseudoFamilyHeader unicode qual (PseudoFamilyDecl { .. }) = + ppFamilyInfo True pfdInfo <+> + ppAppNameTypes (unLoc pfdLName) [] (map unLoc pfdTyVars) unicode qual <+> + ppResultSig (unLoc pfdKindSig) unicode qual + +ppInjectivityAnn :: Bool -> Qualification -> InjectivityAnn DocName -> 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] -> [(DocName, Fixity)] -> SrcSpan -> Documentation DocName -> FamilyDecl DocName -> Splice -> Unicode -> Qualification -> Html @@ -270,15 +309,27 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode = subEquations qual $ map (ppTyFamEqn . unLoc) $ fromMaybe [] mb_eqns | otherwise - = ppInstances instances docname unicode qual + = 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 = HsWB { hswb_cts = ts }} + , tfe_pats = HsIB { hsib_body = ts }} = ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual <+> equals <+> ppType unicode qual (unLoc rhs) , Nothing, [] ) + + +ppPseudoFamilyDecl :: LinksInfo -> Splice -> Unicode -> Qualification + -> PseudoFamilyDecl DocName + -> Html +ppPseudoFamilyDecl links splice unicode qual + decl@(PseudoFamilyDecl { pfdLName = L loc name, .. }) = + wrapper $ ppPseudoFamilyHeader unicode qual decl + where + wrapper = topDeclElem links loc splice [name] + + -------------------------------------------------------------------------------- -- * Associated Types -------------------------------------------------------------------------------- @@ -347,10 +398,6 @@ ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Unicode ppLContext = ppContext . unLoc ppLContextNoArrow = ppContextNoArrow . unLoc - -ppLContextMaybe :: Located (HsContext DocName) -> Unicode -> Qualification -> Maybe Html -ppLContextMaybe = ppContextNoLocsMaybe . map unLoc . unLoc - ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> Html ppContextNoArrow cxt unicode qual = fromMaybe noHtml $ ppContextNoLocsMaybe (map unLoc cxt) unicode qual @@ -381,7 +428,7 @@ ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt) ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName - -> LHsTyVarBndrs DocName -> [Located ([Located DocName], [Located DocName])] + -> LHsQTyVars DocName -> [Located ([Located DocName], [Located DocName])] -> Unicode -> Qualification -> Html ppClassHdr summ lctxt n tvs fds unicode qual = keyword "class" @@ -404,7 +451,7 @@ ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc subdocs splice unicode qual = - if not (any isVanillaLSig sigs) && null ats + if not (any isUserLSig sigs) && null ats then (if summary then id else topDeclElem links loc splice [nm]) hdr else (if summary then id else topDeclElem links loc splice [nm]) (hdr <+> keyword "where") +++ shortSubDecls False @@ -414,8 +461,9 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t -- ToDo: add associated type defaults - [ ppFunSig summary links loc doc names typ [] splice unicode qual - | L _ (TypeSig lnames (L _ typ) _) <- sigs + [ ppFunSig summary links loc doc names (hsSigWcType typ) + [] splice unicode qual + | L _ (TypeSig lnames typ) <- sigs , let doc = lookupAnySubdoc (head names) subdocs names = map unLoc lnames ] -- FIXME: is taking just the first name ok? Is it possible that @@ -441,8 +489,10 @@ ppClassDecl summary links instances fixities loc d subdocs | otherwise = classheader +++ docSection Nothing qual d +++ minimalBit +++ atBit +++ methodBit +++ instancesBit where + sigs = map unLoc lsigs + classheader - | any isVanillaLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs) + | any isUserLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs) | otherwise = topDeclElem links loc splice [nm] (hdr unicode qual <+> fixs) -- Only the fixity relevant to the class header @@ -459,8 +509,9 @@ ppClassDecl summary links instances fixities loc d subdocs doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs subfixs = [ f | f@(n',_) <- fixities, n == n' ] ] - methodBit = subMethods [ ppFunSig summary links loc doc names typ subfixs splice unicode qual - | L _ (TypeSig lnames (L _ typ) _) <- lsigs + methodBit = subMethods [ ppFunSig summary links loc doc names (hsSigType typ) + subfixs splice unicode qual + | L _ (ClassOpSig _ lnames typ) <- lsigs , let doc = lookupAnySubdoc (head names) subdocs subfixs = [ f | n <- names , f@(n',_) <- fixities @@ -470,15 +521,15 @@ ppClassDecl summary links instances fixities loc d subdocs -- there are different subdocs for different names in a single -- type signature? - minimalBit = case [ s | L _ (MinimalSig _ s) <- lsigs ] of + minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of -- Miminal complete definition = every shown method - And xs : _ | sort [getName n | Var (L _ n) <- xs] == - sort [getName n | L _ (TypeSig ns _ _) <- lsigs, L _ n <- ns] + And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] == + sort [getName n | TypeSig ns _ <- sigs, L _ n <- ns] -> noHtml -- Minimal complete definition = the only shown method Var (L _ n) : _ | [getName n] == - [getName n' | L _ (TypeSig ns _ _) <- lsigs, L _ n' <- ns] + [getName n' | L _ (TypeSig ns _) <- lsigs, L _ n' <- ns] -> noHtml -- Minimal complete definition = nothing @@ -488,35 +539,98 @@ ppClassDecl summary links instances fixities loc d subdocs _ -> noHtml ppMinimal _ (Var (L _ n)) = ppDocName qual Prefix True n - ppMinimal _ (And fs) = foldr1 (\a b -> a+++", "+++b) $ map (ppMinimal True) fs - ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs + ppMinimal _ (And fs) = foldr1 (\a b -> a+++", "+++b) $ map (ppMinimal True . unLoc) fs + ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False . unLoc) fs where wrap | p = parens | otherwise = id + ppMinimal p (Parens x) = ppMinimal p (unLoc x) - instancesBit = ppInstances instances nm unicode qual + instancesBit = ppInstances links (OriginClass nm) instances + splice unicode qual ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" -ppInstances :: [DocInstance DocName] -> DocName -> Unicode -> Qualification -> Html -ppInstances instances baseName unicode qual - = subInstances qual instName (map instDecl instances) +ppInstances :: LinksInfo + -> InstOrigin DocName -> [DocInstance DocName] + -> Splice -> Unicode -> Qualification + -> Html +ppInstances links origin instances splice unicode qual + = subInstances qual instName links True (zipWith instDecl [1..] instances) + -- force Splice = True to use line URLs where - instName = getOccString $ getName baseName - instDecl :: DocInstance DocName -> SubDecl - instDecl (inst, maybeDoc) = (instHead inst, maybeDoc, []) - instHead (n, ks, ts, ClassInst cs) = ppContextNoLocs cs unicode qual - <+> ppAppNameTypes n ks ts unicode qual - instHead (n, ks, ts, TypeInst rhs) = keyword "type" - <+> ppAppNameTypes n ks ts unicode qual - <+> maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs - instHead (n, ks, ts, DataInst dd) = keyword "data" - <+> ppAppNameTypes n ks ts unicode qual - <+> ppShortDataDecl False True dd unicode qual + instName = getOccString origin + instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName) + instDecl no (inst, mdoc, loc) = + ((ppInstHead links splice unicode qual mdoc origin no inst), loc) + + +ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification + -> Maybe (MDoc DocName) + -> InstOrigin DocName -> Int -> InstHead DocName + -> SubDecl +ppInstHead links splice unicode qual mdoc origin no ihd@(InstHead {..}) = + case ihdInstType of + ClassInst { .. } -> + ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual <+> typ + , mdoc + , [subInstDetails iid ats sigs] + ) + where + iid = instanceId origin no ihd + sigs = ppInstanceSigs links splice unicode qual clsiSigs + ats = ppInstanceAssocTys links splice unicode qual clsiAssocTys + TypeInst rhs -> + (ptype, mdoc, []) + where + ptype = keyword "type" <+> typ <+> prhs + prhs = maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs + DataInst dd -> + (pdata, mdoc, []) + where + pdata = keyword "data" <+> typ <+> pdecl + pdecl = ppShortDataDecl False True dd unicode qual + where + typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode qual + + +ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification + -> [PseudoFamilyDecl DocName] + -> [Html] +ppInstanceAssocTys links splice unicode qual = + map ppFamilyDecl' + where + ppFamilyDecl' = ppPseudoFamilyDecl links splice unicode qual + + +ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification + -> [Sig DocName] + -> [Html] +ppInstanceSigs links splice unicode qual sigs = do + TypeSig lnames typ <- sigs + let names = map unLoc lnames + L loc rtyp = get_type typ + return $ ppSimpleSig links splice unicode qual loc names rtyp + where + get_type = hswc_body . hsib_body + lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n +instanceId :: InstOrigin DocName -> Int -> InstHead DocName -> String +instanceId origin no ihd = concat + [ qual origin + , ":" ++ getOccString origin + , ":" ++ (occNameString . getOccName . ihdClsName) ihd + , ":" ++ show no + ] + where + qual (OriginClass _) = "ic" + qual (OriginData _) = "id" + qual (OriginFamily _) = "if" + + ------------------------------------------------------------------------------- -- * Data & newtype declarations ------------------------------------------------------------------------------- @@ -528,11 +642,11 @@ ppShortDataDecl summary dataInst dataDecl unicode qual | [] <- cons = dataHeader - | [lcon] <- cons, ResTyH98 <- resTy, + | [lcon] <- cons, isH98, (cHead,cBody,cFoot) <- ppShortConstrParts summary dataInst (unLoc lcon) unicode qual = (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot - | ResTyH98 <- resTy = dataHeader + | isH98 = dataHeader +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons) | otherwise = (dataHeader <+> keyword "where") @@ -546,7 +660,9 @@ ppShortDataDecl summary dataInst dataDecl unicode qual doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual cons = dd_cons (tcdDataDefn dataDecl) - resTy = (con_res . unLoc . head) cons + isH98 = case unLoc (head cons) of + ConDeclH98 {} -> True + ConDeclGADT{} -> False ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] -> @@ -562,7 +678,9 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl where docname = tcdName dataDecl cons = dd_cons (tcdDataDefn dataDecl) - resTy = (con_res . unLoc . head) cons + isH98 = case unLoc (head cons) of + ConDeclH98 {} -> True + ConDeclGADT{} -> False header_ = topDeclElem links loc splice [docname] $ ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix @@ -571,18 +689,17 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl whereBit | null cons = noHtml - | otherwise = case resTy of - ResTyGADT _ _ -> keyword "where" - _ -> noHtml + | otherwise = if isH98 then noHtml else keyword "where" constrBit = subConstructors qual [ ppSideBySideConstr subdocs subfixs unicode qual c | c <- cons , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) - (map unLoc (con_names (unLoc c)))) fixities + (map unLoc (getConNames (unLoc c)))) fixities ] - instancesBit = ppInstances instances docname unicode qual + instancesBit = ppInstances links (OriginData docname) instances + splice unicode qual @@ -595,8 +712,8 @@ ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot -- 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 summary dataInst con unicode qual = case con_res con of - ResTyH98 -> case con_details con of +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) @@ -609,28 +726,15 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of ppOccInfix, ppLParendType unicode qual arg2], noHtml, noHtml) - ResTyGADT _ resTy -> case con_details con of - -- prefix & infix could use hsConDeclArgTys if it seemed to - -- simplify the code. - PrefixCon args -> (doGADTCon args resTy, noHtml, noHtml) - -- display GADT records with the new syntax, - -- Constr :: (Context) => { field :: a, field2 :: b } -> Ty (a, b) - -- (except each field gets its own line in docs, to match - -- non-GADT records) - RecCon (L _ fields) -> (ppOcc <+> dcolon unicode <+> - ppForAllCon forall_ ltvs lcontext unicode qual <+> char '{', - doRecordFields fields, - char '}' <+> arrow unicode <+> ppLType unicode qual resTy) - InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml) + ConDeclGADT {} -> (ppOcc <+> dcolon unicode <+> ppLType unicode qual resTy,noHtml,noHtml) where + resTy = hsib_body (con_type con) + doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) (map unLoc fields)) - doGADTCon args resTy = ppOcc <+> dcolon unicode <+> hsep [ - ppForAllCon forall_ ltvs lcontext unicode qual, - ppLType unicode qual (foldr mkFunTy resTy args) ] header_ = ppConstrHdr forall_ tyVars context - occ = map (nameOccName . getName . unLoc) $ con_names con + occ = map (nameOccName . getName . unLoc) $ getConNames con ppOcc = case occ of [one] -> ppBinder summary one @@ -640,35 +744,34 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of [one] -> ppBinderInfix summary one _ -> hsep (punctuate comma (map (ppBinderInfix summary) occ)) - ltvs = con_qvars con + ltvs = fromMaybe (HsQTvs PlaceHolder []) (con_qvars con) tyVars = tyvarNames ltvs - lcontext = con_cxt con - context = unLoc (con_cxt con) - forall_ = con_explicit con - mkFunTy a b = noLoc (HsFunTy a b) + lcontext = fromMaybe (noLoc []) (con_cxt con) + context = unLoc lcontext + forall_ = False -- ppConstrHdr is for (non-GADT) existentials constructors' syntax -ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Unicode +ppConstrHdr :: Bool -> [Name] -> HsContext DocName -> 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 - <+> darrow unicode +++ toHtml " ") + (if null ctxt then noHtml + else ppContextNoArrow ctxt unicode qual + <+> darrow unicode +++ toHtml " ") where - ppForall = case forall_ of - Explicit -> forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) <+> toHtml ". " - Qualified -> noHtml - Implicit -> noHtml - + ppForall | forall_ = forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) + <+> toHtml ". " + | otherwise = noHtml ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)] -> Unicode -> Qualification -> LConDecl DocName -> SubDecl -ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, fieldPart) +ppSideBySideConstr subdocs fixities unicode qual (L _ con) + = (decl, mbDoc, fieldPart) where - decl = case con_res con of - ResTyH98 -> case con_details con of + decl = case con of + ConDeclH98{} -> case con_details con of PrefixCon args -> hsep ((header_ +++ ppOcc) : map (ppLParendType unicode qual) args) @@ -682,28 +785,26 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field ppLParendType unicode qual arg2] <+> fixity - ResTyGADT _ resTy -> case con_details con of - -- prefix & infix could also use hsConDeclArgTys if it seemed to - -- simplify the code. - PrefixCon args -> doGADTCon args resTy - cd@(RecCon _) -> doGADTCon (hsConDeclArgTys cd) resTy - InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy + ConDeclGADT{} -> doGADTCon resTy + + resTy = hsib_body (con_type con) - fieldPart = case con_details con of + fieldPart = case getConDetails con of RecCon (L _ fields) -> [doRecordFields fields] _ -> [] doRecordFields fields = subFields qual (map (ppSideBySideField subdocs unicode qual) (map unLoc fields)) - doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html - doGADTCon args resTy = ppOcc <+> dcolon unicode - <+> hsep [ppForAllCon forall_ ltvs (con_cxt con) unicode qual, - ppLType unicode qual (foldr mkFunTy resTy args) ] + + doGADTCon :: Located (HsType DocName) -> Html + doGADTCon ty = ppOcc <+> dcolon unicode + -- ++AZ++ make this prepend "{..}" when it is a record style GADT + <+> ppLType unicode qual ty <+> fixity fixity = ppFixities fixities qual header_ = ppConstrHdr forall_ tyVars context unicode qual - occ = map (nameOccName . getName . unLoc) $ con_names con + occ = map (nameOccName . getName . unLoc) $ getConNames con ppOcc = case occ of [one] -> ppBinder False one @@ -713,32 +814,30 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field [one] -> ppBinderInfix False one _ -> hsep (punctuate comma (map (ppBinderInfix False) occ)) - ltvs = con_qvars con - tyVars = tyvarNames (con_qvars con) - context = unLoc (con_cxt con) - forall_ = con_explicit con + tyVars = tyvarNames (fromMaybe (HsQTvs PlaceHolder []) (con_qvars con)) + context = unLoc (fromMaybe (noLoc []) (con_cxt con)) + forall_ = False -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. - mbDoc = lookup (unLoc $ head $ con_names con) subdocs >>= + mbDoc = lookup (unLoc $ head $ getConNames con) subdocs >>= combineDocumentation . fst - mkFunTy a b = noLoc (HsFunTy a b) ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification -> ConDeclField DocName -> SubDecl ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) = - (hsep (punctuate comma (map ((ppBinder False) . nameOccName . getName . unL) names)) <+> dcolon unicode <+> ppLType unicode qual ltype, + (hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual 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 (unL $ head names) subdocs >>= combineDocumentation . fst + mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html ppShortField summary unicode qual (ConDeclField names ltype _) - = hsep (punctuate comma (map ((ppBinder summary) . nameOccName . getName . unL) names)) + = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual ltype @@ -768,10 +867,10 @@ ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument" -------------------------------------------------------------------------------- -ppBang :: HsBang -> Html -ppBang HsNoBang = noHtml -ppBang _ = toHtml "!" -- Unpacked args is an implementation detail, - -- so we just show the strictness annotation +ppBang :: HsSrcBang -> Html +ppBang (HsSrcBang _ _ SrcStrict) = toHtml "!" +ppBang (HsSrcBang _ _ SrcLazy) = toHtml "~" +ppBang _ = noHtml tupleParens :: HsTupleSort -> [Html] -> Html @@ -817,52 +916,42 @@ 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 +ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocName -> 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 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 --- Drop top-level for-all type variables in user style --- since they are implicit in Haskell - -ppForAllCon :: HsExplicitFlag -> LHsTyVarBndrs DocName - -> Located (HsContext DocName) -> Unicode -> Qualification -> Html -ppForAllCon expl tvs cxt unicode qual = - forall_part <+> ppLContext cxt unicode qual - where - forall_part = ppLTyVarBndrs expl tvs unicode qual - -ppLTyVarBndrs :: HsExplicitFlag -> LHsTyVarBndrs DocName - -> Unicode -> Qualification - -> Html -ppLTyVarBndrs expl tvs unicode _qual - | show_forall = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot - | otherwise = noHtml - where - show_forall = not (null (hsQTvBndrs tvs)) && is_explicit - is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False} - +ppForAllPart :: [LHsTyVarBndr DocName] -> Unicode -> Html +ppForAllPart tvs unicode = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> 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 expl extra tvs ctxt ty) unicode qual - = maybeParen ctxt_prec pREC_FUN $ ppForAllCon expl tvs ctxt' unicode qual - <+> ppr_mono_lty pREC_TOP ty unicode qual - where ctxt' = case extra of - Just loc -> (++ [L loc HsWildcardTy]) `fmap` ctxt - Nothing -> ctxt +ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual + = maybeParen ctxt_prec pREC_FUN $ + ppForAllPart tvs unicode <+> ppr_mono_lty pREC_TOP ty unicode qual + +ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual + = maybeParen ctxt_prec pREC_FUN $ + ppLContext ctxt unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual -- UnicodeSyntax alternatives -ppr_mono_ty _ (HsTyVar 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 name) _ q = ppDocName q Prefix True name +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 _ (HsKindSig ty kind) u q = @@ -872,11 +961,14 @@ ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TO ppr_mono_ty ctxt_prec (HsIParamTy 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 {}) _ _ = error "ppr_mono_ty HsRecTy" +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 _ tys) u q = quote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys -ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = quote $ parenList $ map (ppLType u q) tys -ppr_mono_ty _ (HsWrapTy {}) _ _ = error "ppr_mono_ty HsWrapTy" +ppr_mono_ty _ (HsExplicitListTy _ tys) u q = promoQuote $ 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 ctxt_prec (HsEqTy ty1 ty2) unicode qual = maybeParen ctxt_prec pREC_CTX $ @@ -886,11 +978,16 @@ 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] -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 where - ppr_op = ppLDocName qual Infix op + -- `(:)` 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. + ppr_op + | (getOccString . getName . unLoc) op == ":" = promoQuote ppr_op' + | otherwise = ppr_op' + ppr_op' = ppLDocName qual Infix op ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual -- = parens (ppr_mono_lty pREC_TOP ty) @@ -899,9 +996,9 @@ ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual = ppr_mono_lty ctxt_prec ty unicode qual -ppr_mono_ty _ HsWildcardTy _ _ = char '_' +ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ = char '_' -ppr_mono_ty _ (HsNamedWildcardTy name) _ q = ppDocName q Prefix True name +ppr_mono_ty _ (HsWildCardTy (NamedWildCard (L _ name))) _ q = ppDocName q Prefix True name ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index 96d734eb..3fe74a82 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -19,8 +19,6 @@ module Haddock.Backends.Xhtml.DocMarkup ( docElement, docSection, docSection_, ) where -import Control.Applicative ((<$>)) - import Data.List import Haddock.Backends.Xhtml.Names import Haddock.Backends.Xhtml.Utils @@ -64,7 +62,10 @@ parHtmlMarkup qual insertAnchors ppId = Markup { then anchor ! [href url] << fromMaybe url mLabel else toHtml $ fromMaybe url mLabel, - markupAName = \aname -> namedAnchor aname << "", + markupAName = \aname + -> if insertAnchors + then namedAnchor aname << "" + else noHtml, markupPic = \(Picture uri t) -> image ! ([src uri] ++ fromMaybe [] (return . title <$> t)), markupProperty = pre . toHtml, markupExample = examplesToHtml, @@ -160,8 +161,9 @@ hackMarkup fmt' h' = UntouchedDoc d -> (markup fmt $ _doc d, [_meta d]) CollapsingHeader (Header lvl titl) par n nm -> let id_ = makeAnchorId $ "ch:" ++ fromMaybe "noid:" nm ++ show n - col' = collapseControl id_ True "caption" - instTable = (thediv ! collapseSection id_ False [] <<) + expanded = False + col' = collapseControl id_ expanded "caption" + instTable = (thediv ! collapseSection id_ expanded [] <<) 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 index b2c60534..d24ed9c4 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -14,7 +14,7 @@ module Haddock.Backends.Xhtml.Layout ( miniBody, divPackageHeader, divContent, divModuleHeader, divFooter, - divTableOfContents, divDescription, divSynposis, divInterface, + divTableOfContents, divDescription, divSynopsis, divInterface, divIndex, divAlphabet, divModuleList, sectionName, @@ -31,7 +31,7 @@ module Haddock.Backends.Xhtml.Layout ( subConstructors, subEquations, subFields, - subInstances, + subInstances, subInstHead, subInstDetails, subMethods, subMinimal, @@ -44,7 +44,6 @@ import Haddock.Backends.Xhtml.Types import Haddock.Backends.Xhtml.Utils import Haddock.Types import Haddock.Utils (makeAnchorId) - import qualified Data.Map as Map import Text.XHtml hiding ( name, title, p, quote ) @@ -77,7 +76,7 @@ nonEmptySectionName c divPackageHeader, divContent, divModuleHeader, divFooter, - divTableOfContents, divDescription, divSynposis, divInterface, + divTableOfContents, divDescription, divSynopsis, divInterface, divIndex, divAlphabet, divModuleList :: Html -> Html @@ -87,7 +86,7 @@ divModuleHeader = sectionDiv "module-header" divFooter = sectionDiv "footer" divTableOfContents = sectionDiv "table-of-contents" divDescription = sectionDiv "description" -divSynposis = sectionDiv "synopsis" +divSynopsis = sectionDiv "synopsis" divInterface = sectionDiv "interface" divIndex = sectionDiv "index" divAlphabet = sectionDiv "alphabet" @@ -128,14 +127,12 @@ divSubDecls cssClass captionName = maybe noHtml wrap subDlist :: Qualification -> [SubDecl] -> Maybe Html subDlist _ [] = Nothing -subDlist qual decls = Just $ dlist << map subEntry decls +++ clearDiv +subDlist qual decls = Just $ ulist << map subEntry decls where subEntry (decl, mdoc, subs) = - dterm ! [theclass "src"] << decl - +++ - docElement ddef << (fmap (docToHtml Nothing qual) mdoc +++ subs) - - clearDiv = thediv ! [ theclass "clear" ] << noHtml + li << + (define ! [theclass "src"] << decl +++ + docElement thediv << (fmap (docToHtml Nothing qual) mdoc +++ subs)) subTable :: Qualification -> [SubDecl] -> Maybe Html @@ -149,6 +146,22 @@ subTable qual decls = Just $ table << aboves (concatMap subRow decls) : map (cell . (td <<)) subs +-- | Sub table with source information (optional). +subTableSrc :: Qualification -> LinksInfo -> Bool -> [(SubDecl,Located DocName)] -> Maybe Html +subTableSrc _ _ _ [] = Nothing +subTableSrc qual lnks splice decls = Just $ table << aboves (concatMap subRow decls) + where + subRow ((decl, mdoc, subs),L loc dn) = + (td ! [theclass "src clearfix"] << + (thespan ! [theclass "inst-left"] << decl) + <+> linkHtml loc dn + <-> + docElement td << fmap (docToHtml Nothing qual) mdoc + ) + : map (cell . (td <<)) subs + linkHtml loc@(RealSrcSpan _) dn = links lnks loc splice dn + linkHtml _ _ = noHtml + subBlock :: [Html] -> Maybe Html subBlock [] = Nothing subBlock hs = Just $ toHtml hs @@ -174,17 +187,43 @@ subEquations :: Qualification -> [SubDecl] -> Html subEquations qual = divSubDecls "equations" "Equations" . subTable qual +-- | Generate sub table for instance declarations, with source subInstances :: Qualification -> String -- ^ Class name, used for anchor generation - -> [SubDecl] -> Html -subInstances qual nm = maybe noHtml wrap . instTable + -> LinksInfo -> Bool + -> [(SubDecl,Located DocName)] -> Html +subInstances qual nm lnks splice = maybe noHtml wrap . instTable where wrap = (subSection <<) . (subCaption +++) - instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTable qual + instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTableSrc qual lnks splice subSection = thediv ! [theclass "subs instances"] subCaption = paragraph ! collapseControl id_ True "caption" << "Instances" id_ = makeAnchorId $ "i:" ++ nm + +subInstHead :: String -- ^ Instance unique id (for anchor generation) + -> Html -- ^ Header content (instance name and type) + -> Html +subInstHead iid hdr = + expander noHtml <+> hdr + where + expander = thespan ! collapseControl (instAnchorId iid) False "instance" + + +subInstDetails :: String -- ^ Instance unique id (for anchor generation) + -> [Html] -- ^ Associated type contents + -> [Html] -- ^ Method contents (pretty-printed signatures) + -> Html +subInstDetails iid ats mets = + section << (subAssociatedTypes ats <+> subMethods mets) + where + section = thediv ! collapseSection (instAnchorId iid) False "inst-details" + + +instAnchorId :: String -> String +instAnchorId iid = makeAnchorId $ "i:" ++ iid + + subMethods :: [Html] -> Html subMethods = divSubDecls "methods" "Methods" . subBlock @@ -200,12 +239,19 @@ declElem = paragraph ! [theclass "src"] -- a box for top level documented names -- it adds a source and wiki link at the right hand side of the box topDeclElem :: LinksInfo -> SrcSpan -> Bool -> [DocName] -> Html -> Html -topDeclElem ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice names html = - declElem << (html <+> srcLink <+> wikiLink) +topDeclElem lnks loc splice names html = + declElem << (html <+> (links lnks loc splice $ head names)) + -- FIXME: is it ok to simply take the first name? + +-- | Adds a source and wiki link at the right hand side of the box. +-- Name must be documented, otherwise we wouldn't get here. +links :: LinksInfo -> SrcSpan -> Bool -> DocName -> Html +links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice (Documented n mdl) = + (srcLink <+> wikiLink) where srcLink = let nameUrl = Map.lookup origPkg sourceMap lineUrl = Map.lookup origPkg lineMap mUrl | splice = lineUrl - -- Use the lineUrl as a backup + -- Use the lineUrl as a backup | otherwise = maybe lineUrl Just nameUrl in case mUrl of Nothing -> noHtml @@ -225,12 +271,9 @@ topDeclElem ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice names htm -- TODO: do something about type instances. They will point to -- the module defining the type family, which is wrong. origMod = nameModule n - origPkg = modulePackageKey origMod - - -- Name must be documented, otherwise we wouldn't get here - Documented n mdl = head names - -- FIXME: is it ok to simply take the first name? + origPkg = moduleUnitId origMod fname = case loc of - RealSrcSpan l -> unpackFS (srcSpanFile l) - UnhelpfulSpan _ -> error "topDeclElem UnhelpfulSpan" + RealSrcSpan l -> unpackFS (srcSpanFile l) + UnhelpfulSpan _ -> error "links: UnhelpfulSpan" +links _ _ _ _ = noHtml diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs index cf12da40..c69710d1 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs @@ -110,16 +110,21 @@ ppName notation name = wrapInfix notation (getOccName name) $ toHtml (getOccStri ppBinder :: Bool -> OccName -> Html --- The Bool indicates whether we are generating the summary, in which case --- the binder will be a link to the full definition. -ppBinder True n = linkedAnchor (nameAnchorId n) << ppBinder' Prefix n -ppBinder False n = namedAnchor (nameAnchorId n) ! [theclass "def"] - << ppBinder' Prefix n +ppBinder = ppBinderWith Prefix ppBinderInfix :: Bool -> OccName -> Html -ppBinderInfix True n = linkedAnchor (nameAnchorId n) << ppBinder' Infix n -ppBinderInfix False n = namedAnchor (nameAnchorId n) ! [theclass "def"] - << ppBinder' Infix n +ppBinderInfix = ppBinderWith Infix + +ppBinderWith :: Notation -> Bool -> OccName -> Html +-- 'isRef' indicates whether this is merely a reference from another part of +-- the documentation or is the actual definition; in the latter case, we also +-- set the 'id' and 'class' attributes. +ppBinderWith notation isRef n = + linkedAnchor name ! attributes << ppBinder' notation n + where + name = nameAnchorId n + attributes | isRef = [] + | otherwise = [identifier name, theclass "def"] ppBinder' :: Notation -> OccName -> Html ppBinder' notation n = wrapInfix notation n $ ppOccName n diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs index 79b093ec..10d6ab10 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs @@ -18,7 +18,6 @@ module Haddock.Backends.Xhtml.Themes ( import Haddock.Options -import Control.Applicative import Control.Monad (liftM) import Data.Char (toLower) import Data.Either (lefts, rights) @@ -206,4 +205,3 @@ liftEither f = either Left (Right . f) concatEither :: [Either a [b]] -> Either a [b] concatEither = liftEither concat . sequenceEither - diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Types.hs b/haddock-api/src/Haddock/Backends/Xhtml/Types.hs index 3d1db887..d1561791 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Types.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Types.hs @@ -23,7 +23,7 @@ import GHC -- the base, module and entity URLs for the source code and wiki links. -type SourceURLs = (Maybe FilePath, Maybe FilePath, Map PackageKey FilePath, Map PackageKey FilePath) +type SourceURLs = (Maybe FilePath, Maybe FilePath, Map UnitId FilePath, Map UnitId FilePath) type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs index cbcbbd6d..98ff4007 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs @@ -14,14 +14,14 @@ module Haddock.Backends.Xhtml.Utils ( renderToString, namedAnchor, linkedAnchor, - spliceURL, + spliceURL, spliceURL', groupId, (<+>), (<=>), char, keyword, punctuate, braces, brackets, pabrackets, parens, parenList, ubxParenList, - arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote, + arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote, promoQuote, hsep, vcat, @@ -29,7 +29,6 @@ module Haddock.Backends.Xhtml.Utils ( ) where -import Haddock.GhcUtils import Haddock.Utils import Data.Maybe @@ -38,18 +37,31 @@ import Text.XHtml hiding ( name, title, p, quote ) import qualified Text.XHtml as XHtml import GHC ( SrcSpan(..), srcSpanStartLine, Name ) -import Module ( Module ) +import Module ( Module, ModuleName, moduleName, moduleNameString ) import Name ( getOccString, nameOccName, isValOcc ) +-- | Replace placeholder string elements with provided values. +-- +-- Used to generate URL for customized external paths, usually provided with +-- @--source-module@, @--source-entity@ and related command-line arguments. +-- +-- >>> spliceURL Nothing mmod mname Nothing "output/%{MODULE}.hs#%{NAME}" +-- "output/Foo.hs#foo" spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name -> Maybe SrcSpan -> String -> String -spliceURL maybe_file maybe_mod maybe_name maybe_loc = run +spliceURL mfile mmod = spliceURL' mfile (moduleName <$> mmod) + + +-- | Same as 'spliceURL' but takes 'ModuleName' instead of 'Module'. +spliceURL' :: Maybe FilePath -> Maybe ModuleName -> Maybe GHC.Name -> + Maybe SrcSpan -> String -> String +spliceURL' maybe_file maybe_mod maybe_name maybe_loc = run where file = fromMaybe "" maybe_file mdl = case maybe_mod of Nothing -> "" - Just m -> moduleString m + Just m -> moduleNameString m (name, kind) = case maybe_name of @@ -138,6 +150,11 @@ quote :: Html -> Html quote h = char '`' +++ h +++ '`' +-- | Promoted type quote (e.g. @'[a, b]@, @'(a, b, c)@). +promoQuote :: Html -> Html +promoQuote h = char '\'' +++ h + + parens, brackets, pabrackets, braces :: Html -> Html parens h = char '(' +++ h +++ char ')' brackets h = char '[' +++ h +++ char ']' @@ -203,7 +220,7 @@ collapseSection id_ state classes = [ identifier sid, theclass cs ] collapseToggle :: String -> [HtmlAttr] collapseToggle id_ = [ strAttr "onclick" js ] where js = "toggleSection('" ++ id_ ++ "')"; - + -- | Attributes for an area that toggles a collapsed area, -- and displays a control. collapseControl :: String -> Bool -> String -> [HtmlAttr] diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index d841aecc..bc293731 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -22,26 +22,27 @@ import Class import CoAxiom import ConLike import Data.Either (lefts, rights) -import Data.List( partition ) -import Data.Monoid (mempty) import DataCon import FamInstEnv -import Haddock.Types import HsSyn -import Kind ( splitKindFunTys, synTyConResKind, isKind ) import Name +import RdrName ( mkVarUnqual ) import PatSyn -import PrelNames (ipClassName) -import SrcLoc ( Located, noLoc, unLoc, noSrcSpan ) +import SrcLoc ( Located, noLoc, unLoc ) import TcType ( tcSplitSigmaTy ) import TyCon -import Type (isStrLitTy, mkFunTys) -import TypeRep +import Type +import TyCoRep import TysPrim ( alphaTyVars ) -import TysWiredIn ( listTyConName, eqTyCon ) +import TysWiredIn ( listTyConName, ipTyCon ) +import PrelNames ( hasKey, eqTyConKey ) import Unique ( getUnique ) +import Util ( filterByList, filterOut ) import Var +import Haddock.Types +import Haddock.Interface.Specialize + -- the main function here! yay! @@ -77,7 +78,7 @@ tyThingToLHsDecl t = case t of , tcdFDs = map (\ (l,r) -> noLoc (map (noLoc . getName) l, map (noLoc . getName) r) ) $ snd $ classTvsFds cl - , tcdSigs = noLoc (MinimalSig mempty . fmap noLoc $ classMinimalDef cl) : + , tcdSigs = noLoc (MinimalSig mempty . noLoc . fmap noLoc $ classMinimalDef cl) : map (noLoc . synifyIdSig DeleteTopLevelQuantification) (classMethods cl) , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature @@ -95,17 +96,11 @@ tyThingToLHsDecl t = case t of -- a data-constructor alone just gets rendered as a function: AConLike (RealDataCon dc) -> allOK $ SigD (TypeSig [synifyName dc] - (synifyType ImplicitizeForAll (dataConUserType dc)) []) + (synifySigWcType ImplicitizeForAll (dataConUserType dc))) AConLike (PatSynCon ps) -> - let (univ_tvs, ex_tvs, req_theta, prov_theta, arg_tys, res_ty) = patSynSig ps - qtvs = univ_tvs ++ ex_tvs - ty = mkFunTys arg_tys res_ty - in allOK . SigD $ PatSynSig (synifyName ps) - (Implicit, synifyTyVars qtvs) - (synifyCtx req_theta) - (synifyCtx prov_theta) - (synifyType WithinType ty) + allOK . SigD $ PatSynSig (synifyName ps) (synifySigType WithinType + (patSynType ps)) where withErrs e x = return (e, x) allOK x = return (mempty, x) @@ -115,12 +110,9 @@ 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 - (kvs, tvs) = partition isKindVar tkvs in TyFamEqn { tfe_tycon = name - , tfe_pats = HsWB { hswb_cts = typats - , hswb_kvs = map tyVarName kvs - , hswb_tvs = map tyVarName tvs - , hswb_wcs = [] } + , tfe_pats = HsIB { hsib_body = typats + , hsib_vars = map tyVarName tkvs } , tfe_rhs = hs_rhs } synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl Name) @@ -140,7 +132,7 @@ synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) -- | Turn type constructors into type class declarations synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> Either ErrMsg (TyClDecl Name) -synifyTyCon coax tc +synifyTyCon _coax tc | isFunTyCon tc || isPrimTyCon tc = return $ DataDecl { tcdLName = synifyName tc @@ -148,8 +140,8 @@ synifyTyCon coax tc let mk_hs_tv realKind fakeTyVar = noLoc $ KindedTyVar (noLoc (getName fakeTyVar)) (synifyKindSig realKind) - in HsQTvs { hsq_kvs = [] -- No kind polymorphism - , hsq_tvs = zipWith mk_hs_tv (fst (splitKindFunTys (tyConKind tc))) + in HsQTvs { hsq_implicit = [] -- No kind polymorphism + , hsq_explicit = zipWith mk_hs_tv (fst (splitFunTys (tyConKind tc))) alphaTyVars --a, b, c... which are unfortunately all kind * } @@ -163,37 +155,38 @@ synifyTyCon coax tc , dd_derivs = Nothing } , tcdFVs = placeHolderNamesTc } - | isTypeFamilyTyCon tc - = case famTyConFlav_maybe tc of - Just rhs -> - let info = case rhs of - OpenSynFamilyTyCon -> return OpenTypeFamily - ClosedSynFamilyTyCon mb -> case mb of - Just (CoAxiom { co_ax_branches = branches }) - -> return $ ClosedTypeFamily $ Just $ - brListMap (noLoc . synifyAxBranch tc) branches - Nothing -> return $ ClosedTypeFamily $ Just [] - BuiltInSynFamTyCon {} - -> return $ ClosedTypeFamily $ Just [] - AbstractClosedSynFamilyTyCon {} - -> return $ ClosedTypeFamily Nothing - in info >>= \i -> - return (FamDecl - (FamilyDecl { fdInfo = i - , fdLName = synifyName tc - , fdTyVars = synifyTyVars (tyConTyVars tc) - , fdKindSig = - Just (synifyKindSig (synTyConResKind tc)) - })) - Nothing -> Left "synifyTyCon: impossible open type synonym?" - - | isDataFamilyTyCon tc - = --(why no "isOpenAlgTyCon"?) - case algTyConRhs tc of - DataFamilyTyCon -> return $ - FamDecl (FamilyDecl DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc)) - Nothing) --always kind '*' - _ -> Left "synifyTyCon: impossible open data type?" +synifyTyCon _coax tc + | Just flav <- famTyConFlav_maybe tc + = case flav of + -- Type families + OpenSynFamilyTyCon -> mkFamDecl OpenTypeFamily + ClosedSynFamilyTyCon mb + | Just (CoAxiom { co_ax_branches = branches }) <- mb + -> mkFamDecl $ ClosedTypeFamily $ Just + $ map (noLoc . synifyAxBranch tc) (fromBranches branches) + | otherwise + -> mkFamDecl $ ClosedTypeFamily $ Just [] + BuiltInSynFamTyCon {} + -> mkFamDecl $ ClosedTypeFamily $ Just [] + AbstractClosedSynFamilyTyCon {} + -> mkFamDecl $ ClosedTypeFamily Nothing + DataFamilyTyCon {} + -> mkFamDecl DataFamily + where + resultVar = famTcResVar tc + mkFamDecl i = return $ FamDecl $ + FamilyDecl { fdInfo = i + , fdLName = synifyName tc + , fdTyVars = synifyTyVars (tyConTyVars tc) + , fdResultSig = + synifyFamilyResultSig resultVar tyConResKind + , fdInjectivityAnn = + synifyInjectivityAnn resultVar (tyConTyVars tc) + (familyTyConInjectivityInfo tc) + } + tyConResKind = piResultTys (tyConKind tc) (mkTyVarTys (tyConTyVars tc)) + +synifyTyCon coax tc | Just ty <- synTyConRhs_maybe tc = return $ SynDecl { tcdLName = synifyName tc , tcdTyVars = synifyTyVars (tyConTyVars tc) @@ -243,6 +236,20 @@ synifyTyCon coax tc , tcdFVs = placeHolderNamesTc } dataConErrs -> Left $ unlines dataConErrs +synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity + -> Maybe (LInjectivityAnn Name) +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 Nothing kind = + noLoc $ KindSig (synifyKindSig kind) +synifyFamilyResultSig (Just name) kind = + noLoc $ TyVarSig (noLoc $ KindedTyVar (noLoc name) (synifyKindSig kind)) + -- User beware: it is your responsibility to pass True (use_gadt_syntax) -- for any constructor that would be misrepresented by omitting its -- result-type. @@ -266,21 +273,18 @@ synifyDataCon use_gadt_syntax dc = -- skip any EqTheta, use 'orig'inal syntax ctx = synifyCtx theta - linear_tys = zipWith (\ty bang -> - let tySyn = synifyType WithinType ty - src_bang = case bang of - HsUnpack {} -> HsSrcBang Nothing (Just True) True - HsStrict -> HsSrcBang Nothing (Just False) True - _ -> bang - in case src_bang of - HsNoBang -> tySyn - _ -> noLoc $ HsBangTy bang tySyn - -- HsNoBang never appears, it's implied instead. - ) - arg_tys (dataConSrcBangs dc) - field_tys = zipWith (\field synTy -> noLoc $ ConDeclField - [synifyName field] synTy Nothing) - (dataConFieldLabels dc) linear_tys + linear_tys = + zipWith (\ty bang -> + let tySyn = synifyType WithinType ty + in case bang of + (HsSrcBang _ NoSrcUnpack NoSrcStrict) -> tySyn + bang' -> noLoc $ HsBangTy bang' tySyn) + arg_tys (dataConSrcBangs dc) + + field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys + con_decl_field fl synTy = noLoc $ + ConDeclField [noLoc $ FieldOcc (mkVarUnqual $ flLabel fl) (flSelector fl)] synTy + Nothing hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of (True,True) -> Left "synifyDataCon: contradiction!" (True,False) -> return $ RecCon (noLoc field_tys) @@ -288,39 +292,45 @@ synifyDataCon use_gadt_syntax dc = (False,True) -> case linear_tys of [a,b] -> return $ InfixCon a b _ -> Left "synifyDataCon: infix with non-2 args?" - hs_res_ty = if use_gadt_syntax - then ResTyGADT noSrcSpan (synifyType WithinType res_ty) - else ResTyH98 + gadt_ty = HsIB [] (synifyType WithinType res_ty) -- finally we get synifyDataCon's result! in hs_arg_tys >>= - \hat -> return . noLoc $ ConDecl [name] Implicit -- we don't know nor care - qvars ctx hat hs_res_ty Nothing - -- we don't want any "deprecated GADT syntax" warnings! - False + \hat -> + if use_gadt_syntax + then return $ noLoc $ + ConDeclGADT { con_names = [name] + , con_type = gadt_ty + , con_doc = Nothing } + else return $ noLoc $ + ConDeclH98 { con_name = name + , con_qvars = Just qvars + , con_cxt = Just ctx + , con_details = hat + , con_doc = Nothing } synifyName :: NamedThing n => n -> Located Name synifyName = noLoc . getName synifyIdSig :: SynifyTypeState -> Id -> Sig Name -synifyIdSig s i = TypeSig [synifyName i] (synifyType s (varType i)) [] +synifyIdSig s i = TypeSig [synifyName i] (synifySigWcType s (varType i)) synifyCtx :: [PredType] -> LHsContext Name synifyCtx = noLoc . map (synifyType WithinType) -synifyTyVars :: [TyVar] -> LHsTyVarBndrs Name -synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs - , hsq_tvs = map synifyTyVar tvs } +synifyTyVars :: [TyVar] -> LHsQTyVars Name +synifyTyVars ktvs = HsQTvs { hsq_implicit = [] + , hsq_explicit = map synifyTyVar ktvs } + +synifyTyVar :: TyVar -> LHsTyVarBndr Name +synifyTyVar tv + | isLiftedTypeKind kind = noLoc (UserTyVar (noLoc name)) + | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind)) where - (kvs, tvs) = partition isKindVar ktvs - synifyTyVar tv - | isLiftedTypeKind kind = noLoc (UserTyVar name) - | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind)) - where - kind = tyVarKind tv - name = getName tv + kind = tyVarKind tv + name = getName tv --states of what to do with foralls: data SynifyTypeState @@ -338,8 +348,17 @@ data SynifyTypeState -- the defining class gets to quantify all its functions for free! +synifySigType :: SynifyTypeState -> Type -> LHsSigType Name +-- 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 +-- Ditto (see synifySigType) +synifySigWcType s ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs (synifyType s ty)) + synifyType :: SynifyTypeState -> Type -> LHsType Name -synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv) +synifyType _ (TyVarTy tv) = noLoc $ HsTyVar $ noLoc (getName tv) synifyType _ (TyConApp tc tys) -- Use non-prefix tuple syntax where possible, because it looks nicer. | Just sort <- tyConTuple_maybe tc @@ -353,40 +372,42 @@ synifyType _ (TyConApp tc tys) | getName tc == listTyConName, [ty] <- tys = noLoc $ HsListTy (synifyType WithinType ty) -- ditto for implicit parameter tycons - | tyConName tc == ipClassName + | tc == ipTyCon , [name, ty] <- tys , Just x <- isStrLitTy name = noLoc $ HsIParamTy (HsIPName x) (synifyType WithinType ty) -- and equalities - | tc == eqTyCon + | 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 (getName tc)) - (map (synifyType WithinType) tys) + (noLoc $ HsTyVar $ noLoc (getName tc)) + (map (synifyType WithinType) $ + filterOut isCoercionTy tys) +synifyType s (AppTy t1 (CoercionTy {})) = synifyType s t1 synifyType _ (AppTy t1 t2) = let s1 = synifyType WithinType t1 s2 = synifyType WithinType t2 in noLoc $ HsAppTy s1 s2 -synifyType _ (FunTy t1 t2) = let +synifyType _ (ForAllTy (Anon t1) t2) = let s1 = synifyType WithinType t1 s2 = synifyType WithinType t2 in noLoc $ HsFunTy s1 s2 synifyType s forallty@(ForAllTy _tv _ty) = let (tvs, ctx, tau) = tcSplitSigmaTy forallty - sTvs = synifyTyVars tvs - sCtx = synifyCtx ctx - sTau = synifyType WithinType tau - mkHsForAllTy forallPlicitness = - noLoc $ HsForAllTy forallPlicitness Nothing sTvs sCtx sTau + sPhi = HsQualTy { hst_ctxt = synifyCtx ctx + , hst_body = synifyType WithinType tau } in case s of DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau - WithinType -> mkHsForAllTy Explicit - ImplicitizeForAll -> mkHsForAllTy Implicit + WithinType -> noLoc $ HsForAllTy { hst_bndrs = map synifyTyVar tvs + , hst_body = noLoc sPhi } + ImplicitizeForAll -> noLoc sPhi synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t +synifyType s (CastTy t _) = synifyType s t +synifyType _ (CoercionTy {}) = error "synifyType:Coercion" synifyTyLit :: TyLit -> HsTyLit synifyTyLit (NumTyLit n) = HsNumTy mempty n @@ -396,23 +417,38 @@ synifyKindSig :: Kind -> LHsKind Name synifyKindSig k = synifyType WithinType k synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name -synifyInstHead (_, preds, cls, types) = - ( getName cls - , map (unLoc . synifyType WithinType) ks - , map (unLoc . synifyType WithinType) ts - , ClassInst $ map (unLoc . synifyType WithinType) preds - ) - where (ks,ts) = break (not . isKind) types +synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead + { ihdClsName = getName cls + , ihdKinds = map (unLoc . synifyType WithinType) ks + , ihdTypes = map (unLoc . synifyType WithinType) ts + , ihdInstType = ClassInst + { clsiCtx = map (unLoc . synifyType WithinType) preds + , clsiTyVars = synifyTyVars $ classTyVars cls + , clsiSigs = map synifyClsIdSig $ classMethods cls + , clsiAssocTys = do + (Right (FamDecl fam)) <- map (synifyTyCon Nothing) $ classATs cls + pure $ mkPseudoFamilyDecl fam + } + } + where + (ks,ts) = partitionInvisibles (classTyCon cls) id types + synifyClsIdSig = synifyIdSig DeleteTopLevelQuantification -- Convert a family instance, this could be a type family or data family synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead Name) -synifyFamInst fi opaque = - let fff = case fi_flavor fi of - SynFamilyInst | opaque -> return $ TypeInst Nothing - SynFamilyInst -> - return . TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi - DataFamilyInst c -> - synifyTyCon (Just $ famInstAxiom fi) c >>= return . DataInst - in fff >>= \f' -> return (fi_fam fi , map (unLoc . synifyType WithinType) ks, - map (unLoc . synifyType WithinType) ts , f') - where (ks,ts) = break (not . isKind) $ fi_tys fi +synifyFamInst fi opaque = do + ityp' <- ityp $ fi_flavor fi + return InstHead + { ihdClsName = fi_fam fi + , ihdKinds = synifyTypes ks + , ihdTypes = synifyTypes ts + , ihdInstType = ityp' + } + where + ityp SynFamilyInst | opaque = return $ TypeInst Nothing + ityp SynFamilyInst = + return . TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi + ityp (DataFamilyInst c) = + DataInst <$> synifyTyCon (Just $ famInstAxiom fi) c + (ks,ts) = partitionInvisibles (famInstTyCon fi) id $ fi_tys fi + synifyTypes = map (unLoc. synifyType WithinType) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 5caefa77..4e5e008b 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -16,7 +16,6 @@ module Haddock.GhcUtils where -import Control.Applicative ( (<$>) ) import Control.Arrow import Data.Function @@ -69,7 +68,7 @@ getMainDeclBinder _ = [] -- to correlate InstDecls with their Instance/CoAxiom Names, via the -- instanceMap. getInstLoc :: InstDecl name -> SrcSpan -getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = L l _ })) = l +getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty) getInstLoc (DataFamInstD (DataFamInstDecl { dfid_tycon = L l _ })) = l getInstLoc (TyFamInstD (TyFamInstDecl -- Since CoAxioms' Names refer to the whole line for type family instances @@ -92,10 +91,14 @@ filterSigNames p (FixSig (FixitySig ns ty)) = [] -> Nothing filtered -> Just (FixSig (FixitySig filtered ty)) filterSigNames _ orig@(MinimalSig _ _) = Just orig -filterSigNames p (TypeSig ns ty nwcs) = +filterSigNames p (TypeSig ns ty) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (TypeSig filtered ty nwcs) + filtered -> Just (TypeSig filtered ty) +filterSigNames p (ClassOpSig is_default ns ty) = + case filter (p . unLoc) ns of + [] -> Nothing + filtered -> Just (ClassOpSig is_default filtered ty) filterSigNames _ _ = Nothing ifTrueJust :: Bool -> name -> Maybe name @@ -106,13 +109,19 @@ sigName :: LSig name -> [name] sigName (L _ sig) = sigNameNoLoc sig sigNameNoLoc :: Sig name -> [name] -sigNameNoLoc (TypeSig ns _ _) = map unLoc ns -sigNameNoLoc (PatSynSig n _ _ _ _) = [unLoc n] -sigNameNoLoc (SpecSig n _ _) = [unLoc n] -sigNameNoLoc (InlineSig n _) = [unLoc n] +sigNameNoLoc (TypeSig ns _) = map unLoc ns +sigNameNoLoc (ClassOpSig _ ns _) = map unLoc ns +sigNameNoLoc (PatSynSig n _) = [unLoc n] +sigNameNoLoc (SpecSig n _ _) = [unLoc n] +sigNameNoLoc (InlineSig n _) = [unLoc n] sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns sigNameNoLoc _ = [] +-- | Was this signature given by the user? +isUserLSig :: LSig name -> Bool +isUserLSig (L _(TypeSig {})) = True +isUserLSig (L _(ClassOpSig {})) = True +isUserLSig _ = False isTyClD :: HsDecl a -> Bool isTyClD (TyClD _) = True @@ -188,17 +197,18 @@ class Parent a where instance Parent (ConDecl Name) where children con = - case con_details con of - RecCon fields -> map unL $ concatMap (cd_fld_names . unL) (unL fields) + case getConDetails con of + RecCon fields -> map (selectorFieldOcc . unL) $ + concatMap (cd_fld_names . unL) (unL fields) _ -> [] instance Parent (TyClDecl Name) where children d - | isDataDecl d = map unL $ concatMap (con_names . unL) + | isDataDecl d = map unL $ concatMap (getConNames . unL) $ (dd_cons . tcdDataDefn) $ d | isClassDecl d = map (unL . fdLName . unL) (tcdATs d) ++ - [ unL n | L _ (TypeSig ns _ _) <- tcdSigs d, n <- ns ] + [ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ] | otherwise = [] @@ -208,7 +218,7 @@ family = getName &&& children familyConDecl :: ConDecl Name -> [(Name, [Name])] -familyConDecl d = zip (map unL (con_names d)) (repeat $ children d) +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. diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 080de6ff..faf043aa 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -22,6 +22,7 @@ import Control.Arrow hiding ((<+>)) import Data.List import Data.Ord (comparing) import Data.Function (on) +import Data.Maybe ( maybeToList, mapMaybe ) import qualified Data.Map as Map import qualified Data.Set as Set @@ -32,16 +33,15 @@ import FamInstEnv import FastString import GHC import GhcMonad (withSession) -import Id import InstEnv import MonadUtils (liftIO) import Name import Outputable (text, sep, (<+>)) import PrelNames +import SrcLoc import TcRnDriver (tcRnGetInfo) -import TcType (tcSplitSigmaTy) import TyCon -import TypeRep +import TyCoRep import TysPrim( funTyCon ) import Var hiding (varName) #define FSLIT(x) (mkFastString# (x#)) @@ -68,25 +68,26 @@ attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> Ghc (ExportItem Name) attachToExportItem expInfo iface ifaceMap instIfaceMap export = case attachFixities export of - e@ExportDecl { expItemDecl = L _ (TyClD d) } -> do + e@ExportDecl { expItemDecl = L eSpan (TyClD d) } -> do mb_info <- getAllInfo (tcdName d) insts <- case mb_info of Just (_, _, cls_instances, fam_instances) -> - let fam_insts = [ (synifyFamInst i opaque, n) + let fam_insts = [ (synifyFamInst i opaque, doc,spanNameE n (synifyFamInst i opaque) (L eSpan (tcdName d)) ) | i <- sortBy (comparing instFam) fam_instances - , let n = instLookup instDocMap (getName i) iface ifaceMap instIfaceMap + , let n = getName i + , let doc = instLookup instDocMap n iface ifaceMap instIfaceMap , not $ isNameHidden expInfo (fi_fam i) , not $ any (isTypeHidden expInfo) (fi_tys i) , let opaque = isTypeHidden expInfo (fi_rhs i) ] - cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap) + cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, spanName n (synifyInstHead i) (L eSpan (tcdName d))) | let is = [ (instanceSig i, getName i) | i <- cls_instances ] , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is , not $ isInstanceHidden expInfo cls tys ] -- fam_insts but with failing type fams filtered out - cleanFamInsts = [ (fi, n) | (Right fi, n) <- fam_insts ] - famInstErrs = [ errm | (Left errm, _) <- fam_insts ] + cleanFamInsts = [ (fi, n, L l r) | (Right fi, n, L l (Right r)) <- fam_insts ] + famInstErrs = [ errm | (Left errm, _, _) <- fam_insts ] in do dfs <- getDynFlags let mkBug = (text "haddock-bug:" <+>) . text @@ -105,6 +106,18 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export = ] } attachFixities e = e + -- spanName: attach the location to the name that is the same file as the instance location + spanName s (InstHead { ihdClsName = clsn }) (L instL instn) = + let s1 = getSrcSpan s + sn = if srcSpanFileName_maybe s1 == srcSpanFileName_maybe instL + then instn + else clsn + in L (getSrcSpan s) sn + -- spanName on Either + spanNameE s (Left e) _ = L (getSrcSpan s) (Left e) + spanNameE s (Right ok) linst = + let L l r = spanName s ok linst + in L l (Right r) instLookup :: (InstalledInterface -> Map.Map Name a) -> Name @@ -146,18 +159,26 @@ instHead (_, _, cls, args) argCount :: Type -> Int argCount (AppTy t _) = argCount t + 1 argCount (TyConApp _ ts) = length ts -argCount (FunTy _ _ ) = 2 +argCount (ForAllTy (Anon _) _ ) = 2 argCount (ForAllTy _ t) = argCount t +argCount (CastTy t _) = argCount t argCount _ = 0 simplify :: Type -> SimpleType +simplify (ForAllTy (Anon t1) t2) = SimpleType funTyConName [simplify t1, simplify t2] simplify (ForAllTy _ t) = simplify t -simplify (FunTy t1 t2) = SimpleType funTyConName [simplify t1, simplify t2] -simplify (AppTy t1 t2) = SimpleType s (ts ++ [simplify t2]) +simplify (AppTy t1 t2) = SimpleType s (ts ++ maybeToList (simplify_maybe t2)) where (SimpleType s ts) = simplify t1 simplify (TyVarTy v) = SimpleType (tyVarName v) [] -simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts) +simplify (TyConApp tc ts) = SimpleType (tyConName tc) + (mapMaybe simplify_maybe ts) simplify (LitTy l) = SimpleTyLit l +simplify (CastTy ty _) = simplify ty +simplify (CoercionTy _) = error "simplify:Coercion" + +simplify_maybe :: Type -> Maybe SimpleType +simplify_maybe (CoercionTy {}) = Nothing +simplify_maybe ty = Just (simplify ty) -- Used for sorting instFam :: FamInst -> ([Int], Name, [SimpleType], Int, SimpleType) @@ -207,9 +228,10 @@ isTypeHidden expInfo = typeHidden TyVarTy {} -> False AppTy t1 t2 -> typeHidden t1 || typeHidden t2 TyConApp tcon args -> nameHidden (getName tcon) || any typeHidden args - FunTy t1 t2 -> typeHidden t1 || typeHidden t2 - ForAllTy _ ty -> typeHidden ty + ForAllTy bndr ty -> typeHidden (binderType bndr) || typeHidden ty LitTy _ -> False + CastTy ty _ -> typeHidden ty + CoercionTy {} -> False nameHidden :: Name -> Bool nameHidden = isNameHidden expInfo diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 9ef3d1b1..c41946f5 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -21,6 +21,9 @@ import Haddock.GhcUtils import Haddock.Utils import Haddock.Convert import Haddock.Interface.LexParseRn +import Haddock.Backends.Hyperlinker.Types +import Haddock.Backends.Hyperlinker.Ast as Hyperlinker +import Haddock.Backends.Hyperlinker.Parser as Hyperlinker import qualified Data.Map as M import Data.Map (Map) @@ -45,7 +48,9 @@ import Bag import RdrName import TcRnTypes import FastString (concatFS) +import BasicTypes ( StringLiteral(..) ) import qualified Outputable as O +import HsDecls ( gadtDeclDetails,getConDetails ) -- | Use a 'TypecheckedModule' to produce an 'Interface'. -- To do this, we need access to already processed modules in the topological @@ -122,6 +127,8 @@ createInterface tm flags modMap instIfaceMap = do mkAliasMap dflags $ tm_renamed_source tm modWarn = moduleWarning dflags gre warnings + tokenizedSrc <- mkMaybeTokenizedSrc flags tm + return $! Interface { ifaceMod = mdl , ifaceOrigFilename = msHsFilePath ms @@ -145,6 +152,7 @@ createInterface tm flags modMap instIfaceMap = do , ifaceFamInstances = fam_instances , ifaceHaddockCoverage = coverage , ifaceWarningMap = warningMap + , ifaceTokenizedSrc = tokenizedSrc } mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName @@ -157,21 +165,21 @@ mkAliasMap dflags mRenamedSource = alias <- ideclAs impDecl return $ (lookupModuleDyn dflags - (fmap Module.fsToPackageKey $ - ideclPkgQual impDecl) + (fmap Module.fsToUnitId $ + fmap sl_fs $ ideclPkgQual impDecl) (case ideclName impDecl of SrcLoc.L _ name -> name), alias)) impDecls -- similar to GHC.lookupModule lookupModuleDyn :: - DynFlags -> Maybe PackageKey -> ModuleName -> Module + DynFlags -> Maybe UnitId -> ModuleName -> Module lookupModuleDyn _ (Just pkgId) mdlName = Module.mkModule pkgId mdlName lookupModuleDyn dflags Nothing mdlName = case Packages.lookupModuleInAllPackages dflags mdlName of (m,_):_ -> m - [] -> Module.mkModule Module.mainPackageKey mdlName + [] -> Module.mkModule Module.mainUnitId mdlName ------------------------------------------------------------------------------- @@ -194,8 +202,8 @@ moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name parseWarning dflags gre w = force $ case w of - DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map unLoc msg) - WarningTxt _ msg -> format "Warning: " (concatFS $ map unLoc msg) + 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 @@ -328,30 +336,30 @@ subordinates instMap decl = case decl of 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 dd = constrs ++ fields where cons = map unL $ (dd_cons dd) constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty) - | c <- cons, cname <- con_names c ] - fields = [ (unL n, maybeToList $ fmap unL doc, M.empty) - | RecCon flds <- map con_details cons + | c <- cons, cname <- getConNames c ] + fields = [ (selectorFieldOcc n, maybeToList $ fmap unL doc, M.empty) + | RecCon flds <- map getConDetails cons , L _ (ConDeclField ns _ doc) <- (unLoc flds) - , n <- ns ] + , L _ n <- ns ] -- | Extract function argument docs from inside types. typeDocs :: HsDecl Name -> Map Int HsDocString typeDocs d = let docs = go 0 in case d of - SigD (TypeSig _ ty _) -> docs (unLoc ty) - SigD (PatSynSig _ _ req prov ty) -> - let allTys = ty : concat [ unLoc req, unLoc prov ] - in F.foldMap (docs . unLoc) allTys - ForD (ForeignImport _ ty _ _) -> docs (unLoc ty) + SigD (TypeSig _ ty) -> docs (unLoc (hsSigWcType ty)) + SigD (PatSynSig _ ty) -> docs (unLoc (hsSigType ty)) + ForD (ForeignImport _ ty _ _) -> docs (unLoc (hsSigType ty)) TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty) _ -> M.empty where - go n (HsForAllTy _ _ _ _ ty) = go n (unLoc ty) + go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty) + go n (HsQualTy { hst_body = ty }) = go n (unLoc ty) go n (HsFunTy (L _ (HsDocTy _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty go n (HsFunTy _ ty) = go (n+1) (unLoc ty) go n (HsDocTy _ (L _ doc)) = M.singleton n doc @@ -394,7 +402,7 @@ ungroup group_ = mkDecls (typesigs . hs_valds) SigD group_ ++ mkDecls (valbinds . hs_valds) ValD group_ where - typesigs (ValBindsOut _ sigs) = filter isVanillaLSig sigs + typesigs (ValBindsOut _ sigs) = filter isUserLSig sigs typesigs _ = error "expected ValBindsOut" valbinds (ValBindsOut binds _) = concatMap bagToList . snd . unzip $ binds @@ -426,7 +434,7 @@ filterDecls = filter (isHandled . unL . fst) isHandled (ForD (ForeignImport {})) = True isHandled (TyClD {}) = True isHandled (InstD {}) = True - isHandled (SigD d) = isVanillaLSig (reL d) + isHandled (SigD d) = isUserLSig (reL d) isHandled (ValD _) = True -- we keep doc declarations to be able to get at named docs isHandled (DocD _) = True @@ -439,7 +447,7 @@ filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x | x@(L loc d, doc) <- decls ] where filterClass (TyClD c) = - TyClD $ c { tcdSigs = filter (liftA2 (||) isVanillaLSig isMinimalLSig) $ tcdSigs c } + TyClD $ c { tcdSigs = filter (liftA2 (||) isUserLSig isMinimalLSig) $ tcdSigs c } filterClass _ = error "expected TyClD" @@ -498,7 +506,7 @@ mkExportItems lookupExport (IEVar (L _ x)) = declWith x lookupExport (IEThingAbs (L _ t)) = declWith t lookupExport (IEThingAll (L _ t)) = declWith t - lookupExport (IEThingWith (L _ t) _) = declWith t + lookupExport (IEThingWith (L _ t) _ _ _) = declWith t lookupExport (IEModuleContents (L _ m)) = moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices lookupExport (IEGroup lev docStr) = return $ @@ -517,7 +525,7 @@ mkExportItems case findDecl t of ([L l (ValD _)], (doc, _)) -> do -- Top-level binding without type signature - export <- hiValExportItem dflags t doc (l `elem` splices) $ M.lookup t fixMap + export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap return [export] (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds -> let declNames = getMainDeclBinder (unL decl) @@ -553,7 +561,7 @@ mkExportItems L loc (TyClD cl@ClassDecl{}) -> do mdef <- liftGhcToErrMsgGhc $ minimalDef t - let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . fmap noLoc) mdef + let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . noLoc . fmap noLoc) mdef return [ mkExportDecl t (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ] @@ -620,13 +628,19 @@ hiDecl dflags t = do O.text "-- Please report this on Haddock issue tracker!" bugWarn = O.showSDoc dflags . warnLine -hiValExportItem :: DynFlags -> Name -> DocForDecl Name -> Bool -> Maybe Fixity -> ErrMsgGhc (ExportItem Name) -hiValExportItem dflags name doc splice fixity = do +-- | This function is called for top-level bindings without type signatures. +-- It gets the type signature from GHC and that means it's not going to +-- 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) +hiValExportItem dflags name nLoc doc splice fixity = do mayDecl <- hiDecl dflags name case mayDecl of Nothing -> return (ExportNoDecl name []) - Just decl -> return (ExportDecl decl doc [] [] fixities splice) + Just decl -> return (ExportDecl (fixSpan decl) doc [] [] fixities splice) where + fixSpan (L l t) = L (SrcLoc.combineSrcSpans l nLoc) t fixities = case fixity of Just f -> [(name, f)] Nothing -> [] @@ -689,8 +703,8 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa "documentation for exported module: " ++ pretty dflags expMod] return [] where - m = mkModule packageKey expMod - packageKey = modulePackageKey thisMod + m = mkModule unitId expMod + unitId = moduleUnitId thisMod -- Note [1]: @@ -724,8 +738,8 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap expandSig = foldr f [] where f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name] - f (L l (SigD (TypeSig names t nwcs))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t nwcs)) : acc) xs names - f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names + f (L l (SigD (TypeSig names t))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t)) : acc) xs names + f (L l (SigD (ClassOpSig b names t))) xs = foldr (\n acc -> L l (SigD (ClassOpSig b [n] t)) : acc) xs names f x xs = x : xs mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name)) @@ -737,7 +751,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap | 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 doc (l `elem` splices) $ M.lookup name fixMap) + 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 = @@ -745,7 +759,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices)) mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do mdef <- liftGhcToErrMsgGhc $ minimalDef name - let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . fmap noLoc) mdef + let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . 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 @@ -769,64 +783,49 @@ extractDecl name mdl decl case unLoc decl of TyClD d@ClassDecl {} -> let matches = [ sig | sig <- tcdSigs d, name `elem` sigName sig, - isVanillaLSig sig ] -- TODO: document fixity + isTypeLSig sig ] -- TODO: document fixity in case matches of - [s0] -> let (n, tyvar_names) = (tcdName d, getTyVars d) - L pos sig = extractClassDecl n tyvar_names s0 + [s0] -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d) + L pos sig = addClassContext n tyvar_names s0 in L pos (SigD sig) _ -> error "internal: extractDecl (ClassDecl)" TyClD d@DataDecl {} -> - let (n, tyvar_names) = (tcdName d, map toTypeNoLoc $ getTyVars d) - in SigD <$> extractRecSel name mdl n tyvar_names (dd_cons (tcdDataDefn d)) + let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d)) + in SigD <$> extractRecSel name mdl n tyvar_tys (dd_cons (tcdDataDefn d)) InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n - , dfid_pats = HsWB { hswb_cts = tys } + , dfid_pats = HsIB { hsib_body = tys } , dfid_defn = defn }) -> SigD <$> extractRecSel name mdl 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) + -- , 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 - , n == name + , selectorFieldOcc n == name ] in case matches of [d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0) _ -> error "internal: extractDecl (ClsInstD)" _ -> error "internal: extractDecl" - where - getTyVars = hsLTyVarLocNames . tyClDeclTyVars - - -toTypeNoLoc :: Located Name -> LHsType Name -toTypeNoLoc = noLoc . HsTyVar . unLoc - - -extractClassDecl :: Name -> [Located Name] -> LSig Name -> LSig Name -extractClassDecl c tvs0 (L pos (TypeSig lname ltype _)) = case ltype of - L _ (HsForAllTy expl _ tvs (L _ preds) ty) -> - L pos (TypeSig lname (noLoc (HsForAllTy expl Nothing tvs (lctxt preds) ty)) []) - _ -> L pos (TypeSig lname (noLoc (HsForAllTy Implicit Nothing emptyHsQTvs (lctxt []) ltype)) []) - where - lctxt = noLoc . ctxt - ctxt preds = nlHsTyConApp c (map toTypeNoLoc tvs0) : preds -extractClassDecl _ _ _ = error "extractClassDecl: unexpected decl" - extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name] -> LSig Name extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm mdl t tvs (L _ con : rest) = - case con_details con of - RecCon (L _ fields) | ((n,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> - L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))) []) + case getConDetails con of + RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> + L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty))))) _ -> extractRecSel nm mdl t tvs rest where - matching_fields flds = [ (n,f) | f@(L _ (ConDeclField ns _ _)) <- flds, n <- ns, unLoc n == nm ] + matching_fields :: [LConDeclField Name] -> [(SrcSpan, LConDeclField Name)] + matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds + , L l n <- ns, selectorFieldOcc n == nm ] data_ty - | ResTyGADT _ ty <- con_res con = ty - | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs - + -- | ResTyGADT _ ty <- con_res con = ty + | ConDeclGADT{} <- con = hsib_body $ con_type con + | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar (noLoc t))) tvs -- | Keep export items with docs. pruneExportItems :: [ExportItem Name] -> [ExportItem Name] @@ -855,6 +854,30 @@ seqList :: [a] -> () seqList [] = () seqList (x : xs) = x `seq` seqList xs +mkMaybeTokenizedSrc :: [Flag] -> TypecheckedModule + -> ErrMsgGhc (Maybe [RichToken]) +mkMaybeTokenizedSrc flags tm + | Flag_HyperlinkedSource `elem` flags = case renamedSource tm of + Just src -> do + tokens <- liftGhcToErrMsgGhc . liftIO $ mkTokenizedSrc summary src + return $ Just tokens + Nothing -> do + liftErrMsg . tell . pure $ concat + [ "Warning: Cannot hyperlink module \"" + , moduleNameString . ms_mod_name $ summary + , "\" because renamed source is not available" + ] + return Nothing + | otherwise = return Nothing + where + summary = pm_mod_summary . tm_parsed_module $ tm + +mkTokenizedSrc :: ModSummary -> RenamedSource -> IO [RichToken] +mkTokenizedSrc ms src = + Hyperlinker.enrich src . Hyperlinker.parse <$> rawSrc + where + rawSrc = readFile $ msHsFilePath ms + -- | Find a stand-alone documentation comment by its name. findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString) findNamedDoc name = search diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index ac823da3..3c14498c 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -18,20 +18,20 @@ module Haddock.Interface.LexParseRn , processModuleHeader ) where -import Control.Applicative import Data.IntSet (toList) import Data.List import Documentation.Haddock.Doc (metaDocConcat) -import DynFlags (ExtensionFlag(..), languageExtensions) +import DynFlags (languageExtensions) +import qualified GHC.LanguageExtensions as LangExt import FastString import GHC import Haddock.Interface.ParseModuleHeader import Haddock.Parser import Haddock.Types import Name -import RdrHsSyn ( setRdrNameSpace ) import Outputable ( showPpr ) import RdrName +import RnEnv (dataTcOccs) processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> Maybe (MDoc Name) @@ -65,7 +65,7 @@ processModuleHeader dflags gre safety mayStr = do doc' = overDoc (rename dflags gre) doc return (hmi', Just doc') - let flags :: [ExtensionFlag] + 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) return (hmi { hmi_safety = Just $ showPpr dflags safety @@ -75,7 +75,13 @@ processModuleHeader dflags gre safety mayStr = do where failure = (emptyHaddockModInfo, Nothing) - +-- | Takes a 'GlobalRdrEnv' which (hopefully) contains all the +-- definitions and a parsed comment and we attempt to make sense of +-- where the identifiers in the comment point to. We're in effect +-- trying to convert 'RdrName's to 'Name's, with some guesswork and +-- 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 dflags gre = rn where @@ -83,19 +89,36 @@ rename dflags gre = rn DocAppend a b -> DocAppend (rn a) (rn b) DocParagraph doc -> DocParagraph (rn doc) DocIdentifier x -> do - let choices = dataTcOccs' x + -- Generate the choices for the possible kind of thing this + -- is. + let choices = dataTcOccs x + -- Try to look up all the names in the GlobalRdrEnv that match + -- the names. let names = concatMap (\c -> map gre_name (lookupGRE_RdrName c gre)) choices + case names of + -- We found no names in the env so we start guessing. [] -> case choices of [] -> DocMonospaced (DocString (showPpr dflags x)) - [a] -> outOfScope dflags a - a:b:_ | isRdrTc a -> outOfScope dflags a - | otherwise -> outOfScope dflags b + -- 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 + -- to type constructors as we're much more likely to + -- actually want anchors to regular definitions than + -- 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 + + -- There is only one name in the environment that matches so + -- use it. [a] -> DocIdentifier a - a:b:_ | isTyConName a -> DocIdentifier a | otherwise -> DocIdentifier b - -- If an id can refer to multiple things, we give precedence to type - -- constructors. + -- 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 DocWarning doc -> DocWarning (rn doc) DocEmphasis doc -> DocEmphasis (rn doc) @@ -116,21 +139,14 @@ rename dflags gre = rn DocString str -> DocString str DocHeader (Header l t) -> DocHeader $ Header l (rn t) -dataTcOccs' :: RdrName -> [RdrName] --- If the input is a data constructor, return both it and a type --- constructor. This is useful when we aren't sure which we are --- looking at. --- --- We use this definition instead of the GHC's to provide proper linking to --- functions accross modules. See ticket #253 on Haddock Trac. -dataTcOccs' rdr_name - | isDataOcc occ = [rdr_name, rdr_name_tc] - | otherwise = [rdr_name] - where - occ = rdrNameOcc rdr_name - rdr_name_tc = setRdrNameSpace rdr_name tcName - - +-- | Wrap an identifier that's out of scope (i.e. wasn't found in +-- 'GlobalReaderEnv' during 'rename') in an appropriate doc. Currently +-- we simply monospace the identifier in most cases except when the +-- identifier is qualified: if the identifier is qualified then we can +-- still try to guess and generate anchors accross modules but the +-- users shouldn't rely on this doing the right thing. See tickets +-- #253 and #375 on the confusion this causes depending on which +-- default we pick in 'rename'. outOfScope :: DynFlags -> RdrName -> Doc a outOfScope dflags x = case x of diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs index d92e8b2a..e7d2a085 100644 --- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs +++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs @@ -11,7 +11,6 @@ ----------------------------------------------------------------------------- module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where -import Control.Applicative ((<$>)) import Control.Monad (mplus) import Data.Char import DynFlags diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 56e5b07f..2478ce23 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RecordWildCards #-} ---------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.Rename @@ -13,7 +13,7 @@ module Haddock.Interface.Rename (renameInterface) where -import Data.Traversable (traverse, Traversable) +import Data.Traversable (mapM) import Haddock.GhcUtils import Haddock.Types @@ -21,14 +21,11 @@ import Haddock.Types import Bag (emptyBag) import GHC hiding (NoLink) import Name -import NameSet -import Coercion import Control.Applicative import Control.Monad hiding (mapM) import Data.List import qualified Data.Map as Map hiding ( Map ) -import Data.Traversable (mapM) import Prelude hiding (mapM) @@ -94,13 +91,13 @@ newtype RnM a = instance Monad RnM where (>>=) = thenRn - return = returnRn + return = pure instance Functor RnM where fmap f x = do a <- x; return (f a) instance Applicative RnM where - pure = return + pure = returnRn (<*>) = ap returnRn :: a -> RnM a @@ -173,22 +170,51 @@ renameFnArgsDoc = mapM renameDoc renameLType :: LHsType Name -> RnM (LHsType DocName) renameLType = mapM renameType +renameLSigType :: LHsSigType Name -> RnM (LHsSigType DocName) +renameLSigType = renameImplicit renameLType + +renameLSigWcType :: LHsSigWcType Name -> RnM (LHsSigWcType DocName) +renameLSigWcType = renameImplicit (renameWc renameLType) + renameLKind :: LHsKind Name -> RnM (LHsKind DocName) renameLKind = renameLType renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName)) renameMaybeLKind = traverse renameLKind +renameFamilyResultSig :: LFamilyResultSig Name -> RnM (LFamilyResultSig DocName) +renameFamilyResultSig (L loc NoSig) + = return (L loc NoSig) +renameFamilyResultSig (L loc (KindSig ki)) + = do { ki' <- renameLKind ki + ; return (L loc (KindSig ki')) } +renameFamilyResultSig (L loc (TyVarSig bndr)) + = do { bndr' <- renameLTyVarBndr bndr + ; return (L loc (TyVarSig bndr')) } + +renameInjectivityAnn :: LInjectivityAnn Name -> RnM (LInjectivityAnn DocName) +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 = traverse renameInjectivityAnn renameType :: HsType Name -> RnM (HsType DocName) renameType t = case t of - HsForAllTy expl extra tyvars lcontext ltype -> do - tyvars' <- renameLTyVarBndrs tyvars + HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do + tyvars' <- mapM renameLTyVarBndr tyvars + ltype' <- renameLType ltype + return (HsForAllTy { hst_bndrs = tyvars', hst_body = ltype' }) + + HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do lcontext' <- renameLContext lcontext ltype' <- renameLType ltype - return (HsForAllTy expl extra tyvars' lcontext' ltype') + return (HsQualTy { hst_ctxt = lcontext', hst_body = ltype' }) - HsTyVar n -> return . HsTyVar =<< rename n + HsTyVar (L l n) -> return . HsTyVar . L l =<< rename n HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype HsAppTy a b -> do @@ -208,11 +234,11 @@ renameType t = case t of HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts - HsOpTy a (w, L loc op) b -> do + HsOpTy a (L loc op) b -> do op' <- rename op a' <- renameLType a b' <- renameLType b - return (HsOpTy a' (w, L loc op') b') + return (HsOpTy a' (L loc op') b') HsParTy ty -> return . HsParTy =<< renameLType ty @@ -228,25 +254,24 @@ renameType t = case t of HsTyLit x -> return (HsTyLit x) - HsWrapTy a b -> HsWrapTy a <$> renameType b HsRecTy a -> HsRecTy <$> mapM renameConDeclFieldField a HsCoreTy a -> pure (HsCoreTy a) HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b HsSpliceTy _ _ -> error "renameType: HsSpliceTy" - HsWildcardTy -> pure HsWildcardTy - HsNamedWildcardTy a -> HsNamedWildcardTy <$> rename a + HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a + HsAppsTy _ -> error "renameType: HsAppsTy" -renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName) -renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs }) +renameLHsQTyVars :: LHsQTyVars Name -> RnM (LHsQTyVars DocName) +renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs }) = do { tvs' <- mapM renameLTyVarBndr tvs - ; return (HsQTvs { hsq_kvs = error "haddock:renameLTyVarBndrs", hsq_tvs = tvs' }) } + ; return (HsQTvs { hsq_implicit = error "haddock:renameLHsQTyVars", hsq_explicit = tvs' }) } -- This is rather bogus, but I'm not sure what else to do renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName) -renameLTyVarBndr (L loc (UserTyVar n)) +renameLTyVarBndr (L loc (UserTyVar (L l n))) = do { n' <- rename n - ; return (L loc (UserTyVar n')) } + ; return (L loc (UserTyVar (L l n'))) } renameLTyVarBndr (L loc (KindedTyVar (L lv n) kind)) = do { n' <- rename n ; kind' <- renameLKind kind @@ -257,17 +282,29 @@ renameLContext (L loc context) = do context' <- mapM renameLType context return (L loc context') +renameWildCardInfo :: HsWildCardInfo Name -> RnM (HsWildCardInfo DocName) +renameWildCardInfo (AnonWildCard (L l name)) = AnonWildCard . L l <$> rename name +renameWildCardInfo (NamedWildCard (L l name)) = NamedWildCard . L l <$> rename name + renameInstHead :: InstHead Name -> RnM (InstHead DocName) -renameInstHead (className, k, types, rest) = do - className' <- rename className - k' <- mapM renameType k - types' <- mapM renameType types - rest' <- case rest of - ClassInst cs -> ClassInst <$> mapM renameType cs +renameInstHead InstHead {..} = do + cname <- rename ihdClsName + kinds <- mapM renameType ihdKinds + types <- mapM renameType ihdTypes + itype <- case ihdInstType of + ClassInst { .. } -> ClassInst + <$> mapM renameType clsiCtx + <*> renameLHsQTyVars clsiTyVars + <*> mapM renameSig clsiSigs + <*> mapM renamePseudoFamilyDecl clsiAssocTys TypeInst ts -> TypeInst <$> traverse renameType ts DataInst dd -> DataInst <$> renameTyClD dd - return (className', k', types', rest') - + return InstHead + { ihdClsName = cname + , ihdKinds = kinds + , ihdTypes = types + , ihdInstType = itype + } renameLDecl :: LHsDecl Name -> RnM (LHsDecl DocName) renameLDecl (L loc d) = return . L loc =<< renameDecl d @@ -301,13 +338,13 @@ renameTyClD d = case d of SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdRhs = rhs, tcdFVs = _fvs } -> do lname' <- renameL lname - tyvars' <- renameLTyVarBndrs tyvars + tyvars' <- renameLHsQTyVars tyvars rhs' <- renameLType rhs return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdRhs = rhs', tcdFVs = placeHolderNames }) DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdDataDefn = defn, tcdFVs = _fvs } -> do lname' <- renameL lname - tyvars' <- renameLTyVarBndrs tyvars + tyvars' <- renameLHsQTyVars tyvars defn' <- renameDataDefn defn return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdFVs = placeHolderNames }) @@ -315,7 +352,7 @@ renameTyClD d = case d of , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do lcontext' <- renameLContext lcontext lname' <- renameL lname - ltyvars' <- renameLTyVarBndrs ltyvars + ltyvars' <- renameLHsQTyVars ltyvars lfundeps' <- mapM renameLFunDep lfundeps lsigs' <- mapM renameLSig lsigs ats' <- mapM (renameLThing renameFamilyDecl) ats @@ -335,13 +372,26 @@ renameTyClD d = case d of renameFamilyDecl :: FamilyDecl Name -> RnM (FamilyDecl DocName) renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname - , fdTyVars = ltyvars, fdKindSig = tckind }) = do - info' <- renameFamilyInfo info - lname' <- renameL lname - ltyvars' <- renameLTyVarBndrs ltyvars - tckind' <- renameMaybeLKind tckind + , fdTyVars = ltyvars, fdResultSig = result + , fdInjectivityAnn = injectivity }) = do + info' <- renameFamilyInfo info + lname' <- renameL lname + ltyvars' <- renameLHsQTyVars ltyvars + result' <- renameFamilyResultSig result + injectivity' <- renameMaybeInjectivityAnn injectivity return (FamilyDecl { fdInfo = info', fdLName = lname' - , fdTyVars = ltyvars', fdKindSig = tckind' }) + , fdTyVars = ltyvars', fdResultSig = result' + , fdInjectivityAnn = injectivity' }) + + +renamePseudoFamilyDecl :: PseudoFamilyDecl Name + -> RnM (PseudoFamilyDecl DocName) +renamePseudoFamilyDecl (PseudoFamilyDecl { .. }) = PseudoFamilyDecl + <$> renameFamilyInfo pfdInfo + <*> renameL pfdLName + <*> mapM renameLType pfdTyVars + <*> renameFamilyResultSig pfdKindSig + renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName) renameFamilyInfo DataFamily = return DataFamily @@ -361,17 +411,16 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType , dd_kindSig = k', dd_cons = cons', dd_derivs = Nothing }) renameCon :: ConDecl Name -> RnM (ConDecl DocName) -renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars - , con_cxt = lcontext, con_details = details - , con_res = restype, con_doc = mbldoc }) = do - lnames' <- mapM renameL lnames - ltyvars' <- renameLTyVarBndrs ltyvars - lcontext' <- renameLContext lcontext +renameCon decl@(ConDeclH98 { con_name = lname, con_qvars = ltyvars + , con_cxt = lcontext, con_details = details + , con_doc = mbldoc }) = do + lname' <- renameL lname + ltyvars' <- traverse renameLHsQTyVars ltyvars + lcontext' <- traverse renameLContext lcontext details' <- renameDetails details - restype' <- renameResType restype mbldoc' <- mapM renameLDocHsSyn mbldoc - return (decl { con_names = lnames', con_qvars = ltyvars', con_cxt = lcontext' - , con_details = details', con_res = restype', con_doc = mbldoc' }) + return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext' + , con_details = details', con_doc = mbldoc' }) where renameDetails (RecCon (L l fields)) = do @@ -383,35 +432,47 @@ renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars b' <- renameLType b return (InfixCon a' b') - renameResType (ResTyH98) = return ResTyH98 - renameResType (ResTyGADT l t) = return . ResTyGADT l =<< renameLType t - +renameCon decl@(ConDeclGADT { con_names = lnames + , con_type = lty + , con_doc = mbldoc }) = do + lnames' <- mapM renameL lnames + lty' <- renameLSigType lty + mbldoc' <- mapM renameLDocHsSyn mbldoc + return (decl { con_names = lnames' + , con_type = lty', con_doc = mbldoc' }) renameConDeclFieldField :: LConDeclField Name -> RnM (LConDeclField DocName) renameConDeclFieldField (L l (ConDeclField names t doc)) = do - names' <- mapM renameL names + 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 (L l (FieldOcc lbl sel)) = do + sel' <- rename sel + return $ L l (FieldOcc lbl sel') renameSig :: Sig Name -> RnM (Sig DocName) renameSig sig = case sig of - TypeSig lnames ltype _ -> do + TypeSig lnames ltype -> do lnames' <- mapM renameL lnames - ltype' <- renameLType ltype - return (TypeSig lnames' ltype' PlaceHolder) - PatSynSig lname (flag, qtvs) lreq lprov lty -> do + ltype' <- renameLSigWcType ltype + return (TypeSig lnames' ltype') + ClassOpSig is_default lnames sig_ty -> do + lnames' <- mapM renameL lnames + ltype' <- renameLSigType sig_ty + return (ClassOpSig is_default lnames' ltype') + PatSynSig lname sig_ty -> do lname' <- renameL lname - qtvs' <- renameLTyVarBndrs qtvs - lreq' <- renameLContext lreq - lprov' <- renameLContext lprov - lty' <- renameLType lty - return $ PatSynSig lname' (flag, qtvs') lreq' lprov' lty' + sig_ty' <- renameLSigType sig_ty + return $ PatSynSig lname' sig_ty' FixSig (FixitySig lnames fixity) -> do lnames' <- mapM renameL lnames return $ FixSig (FixitySig lnames' fixity) - MinimalSig src s -> MinimalSig src <$> traverse renameL s + MinimalSig src (L l s) -> do + s' <- traverse renameL s + return $ MinimalSig src (L l s') -- we have filtered out all other kinds of signatures in Interface.Create _ -> error "expected TypeSig" @@ -419,11 +480,11 @@ renameSig sig = case sig of renameForD :: ForeignDecl Name -> RnM (ForeignDecl DocName) renameForD (ForeignImport lname ltype co x) = do lname' <- renameL lname - ltype' <- renameLType ltype + ltype' <- renameLSigType ltype return (ForeignImport lname' ltype' co x) renameForD (ForeignExport lname ltype co x) = do lname' <- renameL lname - ltype' <- renameLType ltype + ltype' <- renameLSigType ltype return (ForeignExport lname' ltype' co x) @@ -442,7 +503,7 @@ renameClsInstD :: ClsInstDecl Name -> RnM (ClsInstDecl DocName) renameClsInstD (ClsInstDecl { cid_overlap_mode = omode , cid_poly_ty =ltype, cid_tyfam_insts = lATs , cid_datafam_insts = lADTs }) = do - ltype' <- renameLType ltype + ltype' <- renameLSigType ltype lATs' <- mapM (mapM renameTyFamInstD) lATs lADTs' <- mapM (mapM renameDataFamInstD) lADTs return (ClsInstDecl { cid_overlap_mode = omode @@ -458,33 +519,48 @@ renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn }) , tfid_fvs = placeHolderNames }) } renameLTyFamInstEqn :: LTyFamInstEqn Name -> RnM (LTyFamInstEqn DocName) -renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats_w_bndrs, tfe_rhs = rhs })) +renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs = rhs })) = do { tc' <- renameL tc - ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs) + ; pats' <- renameImplicit (mapM renameLType) pats ; rhs' <- renameLType rhs ; return (L loc (TyFamEqn { tfe_tycon = tc' - , tfe_pats = HsWB pats' PlaceHolder PlaceHolder PlaceHolder + , tfe_pats = pats' , tfe_rhs = rhs' })) } renameLTyFamDefltEqn :: LTyFamDefltEqn Name -> RnM (LTyFamDefltEqn DocName) renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_rhs = rhs })) - = do { tc' <- renameL tc - ; tvs' <- renameLTyVarBndrs tvs + = do { tc' <- renameL tc + ; tvs' <- renameLHsQTyVars tvs ; rhs' <- renameLType rhs ; return (L loc (TyFamEqn { tfe_tycon = tc' , tfe_pats = tvs' , tfe_rhs = rhs' })) } renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName) -renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats_w_bndrs, dfid_defn = defn }) +renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats, dfid_defn = defn }) = do { tc' <- renameL tc - ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs) + ; pats' <- renameImplicit (mapM renameLType) pats ; defn' <- renameDataDefn defn ; return (DataFamInstDecl { dfid_tycon = tc' - , dfid_pats - = HsWB pats' PlaceHolder PlaceHolder PlaceHolder + , dfid_pats = pats' , dfid_defn = defn', dfid_fvs = placeHolderNames }) } +renameImplicit :: (in_thing -> RnM out_thing) + -> HsImplicitBndrs Name in_thing + -> RnM (HsImplicitBndrs DocName out_thing) +renameImplicit rn_thing (HsIB { hsib_body = thing }) + = do { thing' <- rn_thing thing + ; return (HsIB { hsib_body = thing' + , hsib_vars = PlaceHolder }) } + +renameWc :: (in_thing -> RnM out_thing) + -> HsWildCardBndrs Name in_thing + -> RnM (HsWildCardBndrs DocName out_thing) +renameWc rn_thing (HsWC { hswc_body = thing }) + = do { thing' <- rn_thing thing + ; return (HsWC { hswc_body = thing' + , hswc_wcs = PlaceHolder, hswc_ctx = Nothing }) } + renameExportItem :: ExportItem Name -> RnM (ExportItem DocName) renameExportItem item = case item of ExportModule mdl -> return (ExportModule mdl) @@ -495,10 +571,11 @@ renameExportItem item = case item of decl' <- renameLDecl decl doc' <- renameDocForDecl doc subs' <- mapM renameSub subs - instances' <- forM instances $ \(inst, idoc) -> do + instances' <- forM instances $ \(inst, idoc, L l n) -> do inst' <- renameInstHead inst + n' <- rename n idoc' <- mapM renameDoc idoc - return (inst', idoc') + return (inst', idoc',L l n') fixities' <- forM fixities $ \(name, fixity) -> do name' <- lookupRn name return (name', fixity) @@ -517,12 +594,3 @@ renameSub (n,doc) = do n' <- rename n doc' <- renameDocForDecl doc return (n', doc') - -type instance PostRn DocName NameSet = PlaceHolder -type instance PostRn DocName Fixity = PlaceHolder -type instance PostRn DocName Bool = PlaceHolder -type instance PostRn DocName [Name] = PlaceHolder - -type instance PostTc DocName Kind = PlaceHolder -type instance PostTc DocName Type = PlaceHolder -type instance PostTc DocName Coercion = PlaceHolder diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs new file mode 100644 index 00000000..ab719fe8 --- /dev/null +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -0,0 +1,406 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} + + +module Haddock.Interface.Specialize + ( specializeInstHead + ) where + + +import Haddock.Syb +import Haddock.Types + +import GHC +import Name +import FastString + +import Control.Monad +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State + +import Data.Data +import qualified Data.List as List +import Data.Maybe +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set + + +-- | Instantiate all occurrences of given name with particular type. +specialize :: (Eq name, Typeable name) + => Data a + => name -> HsType name -> a -> a +specialize name details = + everywhere $ mkT step + where + step (HsTyVar (L _ name')) | name == name' = details + step typ = typ + + +-- | Instantiate all occurrences of given names with corresponding types. +-- +-- It is just a convenience function wrapping 'specialize' that supports more +-- that one specialization. +specialize' :: (Eq name, Typeable name) + => Data a + => [(name, HsType name)] -> a -> a +specialize' = flip $ foldr (uncurry specialize) + + +-- | Instantiate given binders with corresponding types. +-- +-- Again, it is just a convenience function around 'specialize'. Note that +-- length of type list should be the same as the number of binders. +specializeTyVarBndrs :: (Eq name, DataId name) + => Data a + => LHsQTyVars name -> [HsType name] + -> a -> a +specializeTyVarBndrs bndrs typs = + specialize' $ zip bndrs' typs + where + bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs + bname (UserTyVar (L _ name)) = name + bname (KindedTyVar (L _ name) _) = name + + +specializePseudoFamilyDecl :: (Eq name, DataId name) + => LHsQTyVars name -> [HsType name] + -> PseudoFamilyDecl name + -> PseudoFamilyDecl name +specializePseudoFamilyDecl bndrs typs decl = + decl { pfdTyVars = map specializeTyVars (pfdTyVars decl) } + where + specializeTyVars = specializeTyVarBndrs bndrs typs + + +specializeSig :: forall name . (Eq name, DataId name, SetName name) + => LHsQTyVars name -> [HsType name] + -> Sig name + -> Sig name +specializeSig bndrs typs (TypeSig lnames typ) = + TypeSig lnames (typ { hsib_body = (hsib_body typ) { hswc_body = noLoc typ'}}) + where + true_type :: HsType name + true_type = unLoc (hswc_body (hsib_body typ)) + typ' :: HsType name + typ' = rename fv . sugar $ specializeTyVarBndrs bndrs typs true_type + fv = foldr Set.union Set.empty . map freeVariables $ typs +specializeSig _ _ sig = sig + + +-- | Make all details of instance head (signatures, associated types) +-- specialized to that particular instance type. +specializeInstHead :: (Eq name, DataId name, SetName name) + => InstHead name -> InstHead name +specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } = + ihd { ihdInstType = instType' } + where + instType' = clsi + { clsiSigs = map specializeSig' clsiSigs + , clsiAssocTys = map specializeFamilyDecl' clsiAssocTys + } + specializeSig' = specializeSig clsiTyVars ihdTypes + specializeFamilyDecl' = specializePseudoFamilyDecl clsiTyVars ihdTypes +specializeInstHead ihd = ihd + + +-- | Make given type use tuple and list literals where appropriate. +-- +-- After applying 'specialize' function some terms may not use idiomatic list +-- 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) + => HsType name -> HsType name +sugar = + everywhere $ mkT step + where + step :: HsType name -> HsType name + step = sugarOperators . sugarTuples . sugarLists + + +sugarLists :: NamedThing name => HsType name -> HsType name +sugarLists (HsAppTy (L _ (HsTyVar (L _ name))) ltyp) + | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp + where + name' = getName name + strName = occNameString . nameOccName $ name' +sugarLists typ = typ + + +sugarTuples :: NamedThing name => HsType name -> HsType name +sugarTuples typ = + aux [] typ + where + aux apps (HsAppTy (L _ ftyp) atyp) = aux (atyp:apps) ftyp + aux apps (HsParTy (L _ typ')) = aux apps typ' + aux apps (HsTyVar (L _ name)) + | isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps + where + name' = getName name + strName = occNameString . nameOccName $ name' + suitable = case parseTupleArity strName of + Just arity -> arity == length apps + Nothing -> False + aux _ _ = typ + + +sugarOperators :: NamedThing 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 + where + name' = getName name +sugarOperators typ = typ + + +-- | Compute arity of given tuple operator. +-- +-- >>> parseTupleArity "(,,)" +-- Just 3 +-- +-- >>> parseTupleArity "(,,,,)" +-- Just 5 +-- +-- >>> parseTupleArity "abc" +-- Nothing +-- +-- >>> parseTupleArity "()" +-- Nothing +parseTupleArity :: String -> Maybe Int +parseTupleArity ('(':commas) = do + n <- parseCommas commas + guard $ n /= 0 + return $ n + 1 + where + parseCommas (',':rest) = (+ 1) <$> parseCommas rest + parseCommas ")" = Just 0 + parseCommas _ = Nothing +parseTupleArity _ = Nothing + + +-- | Haskell AST type representation. +-- +-- This type is used for renaming (more below), essentially the ambiguous (!) +-- version of 'Name'. So, why is this 'FastString' instead of 'OccName'? Well, +-- it was 'OccName' before, but turned out that 'OccName' sometimes also +-- contains namespace information, differentiating visually same types. +-- +-- And 'FastString' is used because it is /visual/ part of 'OccName' - it is +-- not converted to 'String' or alike to avoid new allocations. Additionally, +-- since it is stored mostly in 'Set', fast comparison of 'FastString' is also +-- quite nice. +type NameRep = FastString + +getNameRep :: NamedThing name => name -> NameRep +getNameRep = occNameFS . getOccName + +nameRepString :: NameRep -> String +nameRepString = unpackFS + +stringNameRep :: String -> NameRep +stringNameRep = mkFastString + +setInternalNameRep :: SetName name => NameRep -> name -> name +setInternalNameRep = setInternalOccName . mkVarOccFS + +setInternalOccName :: SetName name => OccName -> name -> name +setInternalOccName occ name = + setName nname' name + where + nname = getName name + nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname) + + +-- | Compute set of free variables of given type. +freeVariables :: forall name. (NamedThing name, DataId name) + => HsType name -> Set NameRep +freeVariables = + everythingWithState Set.empty Set.union query + where + query term ctx = case cast term :: Maybe (HsType name) of + Just (HsForAllTy bndrs _) -> + (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) + _ -> (Set.empty, ctx) + bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) + + +-- | Make given type visually unambiguous. +-- +-- After applying 'specialize' method, some free type variables may become +-- visually ambiguous - for example, having @a -> b@ and specializing @a@ to +-- @(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 + } + + +-- | Renaming monad. +type Rename name = Reader (RenameEnv name) + +-- | Binding generation monad. +type Rebind name = State (RenameEnv name) + +data RenameEnv name = RenameEnv + { rneFV :: Set NameRep + , rneCtx :: Map Name name + } + + +renameType :: SetName name => HsType name -> Rename name (HsType name) +renameType (HsForAllTy bndrs lt) = rebind bndrs $ \bndrs' -> + HsForAllTy + <$> pure bndrs' + <*> renameLType lt +renameType (HsQualTy lctxt lt) = + HsQualTy + <$> located renameContext lctxt + <*> renameLType lt +renameType (HsTyVar name) = HsTyVar <$> located renameName name +renameType (HsAppTy lf la) = HsAppTy <$> renameLType lf <*> renameLType la +renameType (HsFunTy la lr) = HsFunTy <$> renameLType la <*> renameLType lr +renameType (HsListTy lt) = HsListTy <$> renameLType lt +renameType (HsPArrTy lt) = HsPArrTy <$> renameLType lt +renameType (HsTupleTy srt lt) = HsTupleTy srt <$> mapM renameLType lt +renameType (HsOpTy la lop lb) = + HsOpTy <$> renameLType la <*> located renameName lop <*> renameLType lb +renameType (HsParTy lt) = HsParTy <$> renameLType lt +renameType (HsIParamTy ip lt) = HsIParamTy ip <$> renameLType lt +renameType (HsEqTy la lb) = HsEqTy <$> renameLType la <*> renameLType lb +renameType (HsKindSig lt lk) = HsKindSig <$> renameLType lt <*> pure lk +renameType t@(HsSpliceTy _ _) = pure t +renameType (HsDocTy lt doc) = HsDocTy <$> renameLType lt <*> pure doc +renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt +renameType t@(HsRecTy _) = pure t +renameType t@(HsCoreTy _) = pure t +renameType (HsExplicitListTy ph ltys) = + HsExplicitListTy ph <$> renameLTypes ltys +renameType (HsExplicitTupleTy phs ltys) = + HsExplicitTupleTy phs <$> renameLTypes ltys +renameType t@(HsTyLit _) = pure t +renameType (HsWildCardTy wc) = pure (HsWildCardTy wc) +renameType (HsAppsTy _) = error "HsAppsTy: Only used before renaming" + + +renameLType :: SetName name => LHsType name -> Rename name (LHsType name) +renameLType = located renameType + + +renameLTypes :: SetName name => [LHsType name] -> Rename name [LHsType name] +renameLTypes = mapM renameLType + + +renameContext :: SetName name => HsContext name -> Rename name (HsContext name) +renameContext = renameLTypes + +{- +renameLTyOp :: SetName name => LHsTyOp name -> Rename name (LHsTyOp name) +renameLTyOp (wrap, lname) = (,) wrap <$> located renameName lname +-} + + +renameName :: 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 + + +-- | Generate fresh occurrence name, put it into context and return. +freshName :: SetName name => name -> Rebind 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 } + 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 = do + RenameEnv { .. } <- get + return $ Set.union rneFV (ctxElems rneCtx) + where + ctxElems = Set.fromList . map getNameRep . Map.elems + + +findFreshName :: Set NameRep -> NameRep -> NameRep +findFreshName taken = + fromJust . List.find isFresh . alternativeNames + where + isFresh = not . flip Set.member taken + + +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 = + [ stringNameRep $ str ++ show i | i :: Int <- [0..] ] + where + str = nameRepString name + + +located :: Functor f => (a -> f b) -> Located a -> f (Located b) +located f (L loc e) = L loc <$> f e + + +tyVarName :: HsTyVarBndr name -> 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 index e8db3cfb..73185092 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -14,7 +14,7 @@ -- Reading and writing the .haddock interface file ----------------------------------------------------------------------------- module Haddock.InterfaceFile ( - InterfaceFile(..), ifPackageKey, + InterfaceFile(..), ifUnitId, ifModule, readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor, writeInterfaceFile, binaryInterfaceVersion, binaryInterfaceVersionCompatibility ) where @@ -25,7 +25,6 @@ import Haddock.Utils hiding (out) import Control.Monad import Data.Array -import Data.Functor ((<$>)) import Data.IORef import Data.List import qualified Data.Map as Map @@ -52,11 +51,17 @@ data InterfaceFile = InterfaceFile { } -ifPackageKey :: InterfaceFile -> PackageKey -ifPackageKey if_ = +ifModule :: InterfaceFile -> Module +ifModule if_ = case ifInstalledIfaces if_ of [] -> error "empty InterfaceFile" - iface:_ -> modulePackageKey $ instMod iface + iface:_ -> instMod iface + +ifUnitId :: InterfaceFile -> UnitId +ifUnitId if_ = + case ifInstalledIfaces if_ of + [] -> error "empty InterfaceFile" + iface:_ -> moduleUnitId $ instMod iface binaryInterfaceMagic :: Word32 @@ -310,7 +315,7 @@ getSymbolTable bh namecache = do return (namecache', arr) -type OnDiskName = (PackageKey, ModuleName, OccName) +type OnDiskName = (UnitId, ModuleName, OccName) fromOnDiskName @@ -340,7 +345,7 @@ fromOnDiskName _ nc (pid, mod_name, occ) = serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO () serialiseName bh name _ = do let modu = nameModule name - put_ bh (modulePackageKey modu, moduleName modu, nameOccName name) + put_ bh (moduleUnitId modu, moduleName modu, nameOccName name) ------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/ModuleTree.hs b/haddock-api/src/Haddock/ModuleTree.hs index 2f731214..e6cf8201 100644 --- a/haddock-api/src/Haddock/ModuleTree.hs +++ b/haddock-api/src/Haddock/ModuleTree.hs @@ -15,7 +15,7 @@ module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where import Haddock.Types ( MDoc ) import GHC ( Name ) -import Module ( Module, moduleNameString, moduleName, modulePackageKey, packageKeyString ) +import Module ( Module, moduleNameString, moduleName, moduleUnitId, unitIdString ) import DynFlags ( DynFlags ) import Packages ( lookupPackage ) import PackageConfig ( sourcePackageIdString ) @@ -28,10 +28,10 @@ mkModuleTree :: DynFlags -> Bool -> [(Module, Maybe (MDoc Name))] -> [ModuleTree mkModuleTree dflags showPkgs mods = foldr fn [] [ (splitModule mdl, modPkg mdl, modSrcPkg mdl, short) | (mdl, short) <- mods ] where - modPkg mod_ | showPkgs = Just (packageKeyString (modulePackageKey mod_)) + modPkg mod_ | showPkgs = Just (unitIdString (moduleUnitId mod_)) | otherwise = Nothing modSrcPkg mod_ | showPkgs = fmap sourcePackageIdString - (lookupPackage dflags (modulePackageKey mod_)) + (lookupPackage dflags (moduleUnitId mod_)) | otherwise = Nothing fn (mod_,pkg,srcPkg,short) = addToTrees mod_ pkg srcPkg short diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs index e847333e..f84989ef 100644 --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -21,6 +21,7 @@ module Haddock.Options ( optContentsUrl, optIndexUrl, optCssFile, + optSourceCssFile, sourceUrls, wikiUrls, optDumpInterfaceFile, @@ -66,6 +67,8 @@ data Flag | Flag_WikiEntityURL String | Flag_LaTeX | Flag_LaTeXStyle String + | Flag_HyperlinkedSource + | Flag_SourceCss String | Flag_Help | Flag_Verbosity String | Flag_Version @@ -116,6 +119,10 @@ options backwardsCompat = 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 [] ["hyperlinked-source"] (NoArg Flag_HyperlinkedSource) + "generate highlighted and hyperlinked source code (for use with --html)", + Option [] ["source-css"] (ReqArg Flag_SourceCss "FILE") + "use custom CSS file instead of default one in hyperlinked source", Option [] ["source-base"] (ReqArg Flag_SourceBaseURL "URL") "URL for a source code link on the contents\nand index pages", Option ['s'] (if backwardsCompat then ["source", "source-module"] else ["source-module"]) @@ -239,6 +246,8 @@ optIndexUrl flags = optLast [ url | Flag_UseIndex url <- flags ] optCssFile :: [Flag] -> Maybe FilePath optCssFile flags = optLast [ str | Flag_CSS str <- flags ] +optSourceCssFile :: [Flag] -> Maybe FilePath +optSourceCssFile flags = optLast [ str | Flag_SourceCss str <- flags ] sourceUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String, Maybe String) sourceUrls flags = diff --git a/haddock-api/src/Haddock/Syb.hs b/haddock-api/src/Haddock/Syb.hs new file mode 100644 index 00000000..4847e486 --- /dev/null +++ b/haddock-api/src/Haddock/Syb.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE Rank2Types #-} + + +module Haddock.Syb + ( everything, everythingWithState, everywhere + , mkT + , combine + ) where + + +import Data.Data +import Control.Applicative + + +-- | Perform a query on each level of a tree. +-- +-- This is stolen directly from SYB package and copied here to not introduce +-- additional dependencies. +everything :: (r -> r -> r) -> (forall a. Data a => a -> r) + -> (forall a. Data a => a -> r) +everything k f x = foldl k (f x) (gmapQ (everything k f) x) + + +-- | Perform a query with state on each level of a tree. +-- +-- This is the same as 'everything' but allows for stateful computations. In +-- SYB it is called @everythingWithContext@ but I find this name somewhat +-- nicer. +everythingWithState :: s -> (r -> r -> r) + -> (forall a. Data a => a -> s -> (r, s)) + -> (forall a. Data a => a -> r) +everythingWithState s k f x = + let (r, s') = f x s + in foldl k r (gmapQ (everythingWithState s' k f) x) + + +-- | Apply transformation on each level of a tree. +-- +-- Just like 'everything', this is stolen from SYB package. +everywhere :: (forall a. Data a => a -> a) -> (forall a. Data a => a -> a) +everywhere f = f . gmapT (everywhere f) + +-- | Create generic transformation. +-- +-- Another function stolen from SYB package. +mkT :: (Typeable a, Typeable b) => (b -> b) -> (a -> a) +mkT f = case cast f of + Just f' -> f' + Nothing -> id + +-- | Combine two queries into one using alternative combinator. +combine :: Alternative f => (forall a. Data a => a -> f r) + -> (forall a. Data a => a -> f r) + -> (forall a. Data a => a -> f r) +combine f g x = f x <|> g x diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index e93294a0..b837970b 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | @@ -27,16 +27,23 @@ import Control.Arrow hiding ((<+>)) import Control.DeepSeq import Data.Typeable import Data.Map (Map) +import Data.Data (Data) import qualified Data.Map as Map import Documentation.Haddock.Types import BasicTypes (Fixity(..)) + import GHC hiding (NoLink) -import DynFlags (ExtensionFlag, Language) +import DynFlags (Language) +import qualified GHC.LanguageExtensions as LangExt +import Coercion +import NameSet import OccName import Outputable import Control.Applicative (Applicative(..)) import Control.Monad (ap) +import Haddock.Backends.Hyperlinker.Types + ----------------------------------------------------------------------------- -- * Convenient synonyms ----------------------------------------------------------------------------- @@ -50,7 +57,6 @@ type SubMap = Map Name [Name] type DeclMap = Map Name [LHsDecl Name] type InstMap = Map SrcSpan Name type FixMap = Map Name Fixity -type SrcMap = Map PackageKey FilePath type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources @@ -126,6 +132,10 @@ data Interface = Interface -- | Warnings for things defined in this module. , ifaceWarningMap :: !WarningMap + + -- | Tokenized source code of module (avaliable if Haddock is invoked with + -- source generation flag). + , ifaceTokenizedSrc :: !(Maybe [RichToken]) } type WarningMap = Map Name (Doc Name) @@ -267,7 +277,6 @@ unrenameDocForDecl (doc, fnArgsDoc) = -- | Type of environment used to cross-reference identifiers in the syntax. type LinkEnv = Map Name Module - -- | Extends 'Name' with cross-reference information. data DocName = Documented Name Module @@ -277,13 +286,46 @@ data DocName | Undocumented Name -- ^ This thing is not part of the (existing or resulting) -- documentation, as far as Haddock knows. - deriving Eq + 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 + +type instance PostTc DocName Kind = PlaceHolder +type instance PostTc DocName Type = PlaceHolder +type instance PostTc DocName Coercion = PlaceHolder instance NamedThing DocName where getName (Documented name _) = name getName (Undocumented name) = name +-- | Useful for debugging +instance Outputable DocName where + ppr = ppr . getName + +instance OutputableBndr DocName where + pprBndr _ = ppr . getName + pprPrefixOcc = pprPrefixOcc . getName + pprInfixOcc = pprInfixOcc . getName + +class NamedThing name => SetName name where + + setName :: Name -> name -> name + + +instance SetName Name where + + setName name' _ = name' + + +instance SetName DocName where + + setName name' (Documented _ mdl) = Documented name' mdl + setName name' (Undocumented _) = Undocumented name' + + ----------------------------------------------------------------------------- -- * Instances @@ -291,21 +333,83 @@ instance NamedThing DocName where -- | The three types of instances data InstType name - = ClassInst [HsType name] -- ^ Context + = ClassInst + { clsiCtx :: [HsType name] + , clsiTyVars :: LHsQTyVars name + , clsiSigs :: [Sig name] + , clsiAssocTys :: [PseudoFamilyDecl name] + } | TypeInst (Maybe (HsType name)) -- ^ Body (right-hand side) | DataInst (TyClDecl name) -- ^ Data constructors instance OutputableBndr a => Outputable (InstType a) where - ppr (ClassInst a) = text "ClassInst" <+> ppr a + ppr (ClassInst { .. }) = text "ClassInst" + <+> ppr clsiCtx + <+> ppr clsiTyVars + <+> ppr clsiSigs ppr (TypeInst a) = text "TypeInst" <+> ppr a ppr (DataInst a) = text "DataInst" <+> ppr a --- | An instance head that may have documentation. -type DocInstance name = (InstHead name, Maybe (MDoc name)) + +-- | Almost the same as 'FamilyDecl' except for type binders. +-- +-- In order to perform type specialization for class instances, we need to +-- substitute class variables to appropriate type. However, type variables in +-- associated type are specified using 'LHsTyVarBndrs' instead of 'HsType'. +-- This makes type substitution impossible and to overcome this issue, +-- 'PseudoFamilyDecl' type is introduced. +data PseudoFamilyDecl name = PseudoFamilyDecl + { pfdInfo :: FamilyInfo name + , pfdLName :: Located name + , pfdTyVars :: [LHsType name] + , pfdKindSig :: LFamilyResultSig name + } + + +mkPseudoFamilyDecl :: FamilyDecl name -> PseudoFamilyDecl name +mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl + { pfdInfo = fdInfo + , pfdLName = fdLName + , pfdTyVars = [ L loc (mkType bndr) | L loc bndr <- hsq_explicit fdTyVars ] + , pfdKindSig = fdResultSig + } + where + mkType (KindedTyVar (L loc name) lkind) = + HsKindSig tvar lkind + where + tvar = L loc (HsTyVar (L loc name)) + mkType (UserTyVar name) = HsTyVar name + + +-- | An instance head that may have documentation and a source location. +type DocInstance name = (InstHead name, Maybe (MDoc name), Located 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 -type InstHead name = (name, [HsType name], [HsType name], InstType name) +data InstHead name = InstHead + { ihdClsName :: name + , ihdKinds :: [HsType name] + , ihdTypes :: [HsType name] + , ihdInstType :: InstType name + } + + +-- | An instance origin information. +-- +-- This is used primarily in HTML backend to generate unique instance +-- identifiers (for expandable sections). +data InstOrigin name + = OriginClass name + | OriginData name + | OriginFamily name + + +instance NamedThing name => NamedThing (InstOrigin name) where + + getName (OriginClass name) = getName name + getName (OriginData name) = getName name + getName (OriginFamily name) = getName name + ----------------------------------------------------------------------------- -- * Documentation comments @@ -399,7 +503,7 @@ data HaddockModInfo name = HaddockModInfo , hmi_portability :: Maybe String , hmi_safety :: Maybe String , hmi_language :: Maybe Language - , hmi_extensions :: [ExtensionFlag] + , hmi_extensions :: [LangExt.Extension] } @@ -491,11 +595,11 @@ instance Functor ErrMsgM where fmap f (Writer (a, msgs)) = Writer (f a, msgs) instance Applicative ErrMsgM where - pure = return - (<*>) = ap + pure a = Writer (a, []) + (<*>) = ap instance Monad ErrMsgM where - return a = Writer (a, []) + return = pure m >>= k = Writer $ let (a, w) = runWriter m (b, w') = runWriter (k a) @@ -544,10 +648,27 @@ instance Functor ErrMsgGhc where fmap f (WriterGhc x) = WriterGhc (fmap (first f) x) instance Applicative ErrMsgGhc where - pure = return + pure a = WriterGhc (return (a, [])) (<*>) = ap instance Monad ErrMsgGhc where - return a = WriterGhc (return (a, [])) + return = pure m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) -> fmap (second (msgs1 ++)) (runWriterGhc (k a)) + + +----------------------------------------------------------------------------- +-- * 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 PostTc DocName Kind = PlaceHolder +type instance PostTc DocName Type = PlaceHolder +type instance PostTc DocName Coercion = PlaceHolder diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 4fed3a1e..3510d908 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -16,6 +16,7 @@ module Haddock.Utils ( -- * Misc utilities restrictTo, emptyHsQTvs, toDescription, toInstalledDescription, + mkEmptySigWcType, addClassContext, lHsQTyVarsToTypes, -- * Filename utilities moduleHtmlFile, moduleHtmlFile', @@ -63,6 +64,7 @@ import Haddock.GhcUtils import GHC import Name +import HsTypes (selectorFieldOcc) import Control.Monad ( liftM ) import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr ) @@ -123,6 +125,34 @@ toInstalledDescription = fmap mkMeta . hmi_description . instInfo mkMeta :: Doc a -> MDoc a mkMeta x = emptyMetaDoc { _doc = x } +mkEmptySigWcType :: LHsType Name -> LHsSigWcType Name +-- Dubious, because the implicit binders are empty even +-- though the type might have free varaiables +mkEmptySigWcType ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs ty) + +addClassContext :: Name -> LHsQTyVars Name -> LSig Name -> LSig Name +-- 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)))) + -- The mkEmptySigWcType is suspicious + where + go (L loc (HsForAllTy { hst_bndrs = tvs, hst_body = ty })) + = L loc (HsForAllTy { hst_bndrs = tvs, hst_body = go ty }) + go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty })) + = L loc (HsQualTy { hst_ctxt = add_ctxt ctxt, hst_body = ty }) + go (L loc ty) + = L loc (HsQualTy { hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty }) + + extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0) + add_ctxt (L loc preds) = L loc (extra_pred : preds) + +addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine + +lHsQTyVarsToTypes :: LHsQTyVars Name -> [LHsType Name] +lHsQTyVarsToTypes tvs + = [ noLoc (HsTyVar (noLoc (hsLTyVarName tv))) + | tv <- hsQTvExplicit tvs ] + -------------------------------------------------------------------------------- -- * Making abstract declarations -------------------------------------------------------------------------------- @@ -150,19 +180,36 @@ restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons }) restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name] restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] where - keep d | any (\n -> n `elem` names) (map unLoc $ con_names d) = - case con_details d of + keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) = + case getConDetails h98d of PrefixCon _ -> Just d RecCon fields | all field_avail (unL fields) -> Just d - | otherwise -> Just (d { con_details = PrefixCon (field_types (map unL (unL fields))) }) + | otherwise -> Just (h98d { con_details = PrefixCon (field_types (map unL (unL fields))) }) -- if we have *all* the field names available, then -- keep the record declaration. Otherwise degrade to -- a constructor declaration. This isn't quite right, but -- it's the best we can do. InfixCon _ _ -> Just d where - field_avail (L _ (ConDeclField ns _ _)) = all (\n -> unLoc n `elem` names) ns + h98d = h98ConDecl d + h98ConDecl c@ConDeclH98{} = c + h98ConDecl c@ConDeclGADT{} = c' + where + (details,_res_ty,cxt,tvs) = gadtDeclDetails (con_type c) + c' :: ConDecl Name + c' = ConDeclH98 + { con_name = head (con_names c) + , con_qvars = Just $ HsQTvs { hsq_implicit = mempty + , hsq_explicit = tvs } + , con_cxt = Just cxt + , con_details = details + , con_doc = con_doc c + } + + field_avail :: LConDeclField Name -> Bool + field_avail (L _ (ConDeclField fs _ _)) + = all (\f -> selectorFieldOcc (unLoc f) `elem` names) fs field_types flds = [ t | ConDeclField _ t _ <- flds ] keep _ = Nothing @@ -174,11 +221,12 @@ restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) restrictATs :: [Name] -> [LFamilyDecl Name] -> [LFamilyDecl Name] restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ] -emptyHsQTvs :: LHsTyVarBndrs Name +emptyHsQTvs :: LHsQTyVars Name -- This function is here, rather than in HsTypes, because it *renamed*, but -- does not necessarily have all the rigt kind variables. It is used -- in Haddock just for printing, so it doesn't matter -emptyHsQTvs = HsQTvs { hsq_kvs = error "haddock:emptyHsQTvs", hsq_tvs = [] } +emptyHsQTvs = HsQTvs { hsq_implicit = error "haddock:emptyHsQTvs" + , hsq_explicit = [] } -------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Version.hs b/haddock-api/src/Haddock/Version.hs index 2ef3a257..4e9a581a 100644 --- a/haddock-api/src/Haddock/Version.hs +++ b/haddock-api/src/Haddock/Version.hs @@ -9,7 +9,7 @@ -- Stability : experimental -- Portability : portable ----------------------------------------------------------------------------- -module Haddock.Version ( +module Haddock.Version ( projectName, projectVersion, projectUrl ) where |