aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src
diff options
context:
space:
mode:
authoridontgetoutmuch <dominic@steinitz.org>2015-12-20 21:01:47 +0000
committeridontgetoutmuch <dominic@steinitz.org>2015-12-20 21:01:47 +0000
commit2bdfda1fb2e0de696ca8c6f7a152b2f85a541be9 (patch)
treecc29895f7d69f051cfec172bb0f8c2ef03552789 /haddock-api/src
parent5a57a24c44e06e964c4ea2276c842c722c4e93d9 (diff)
parentfa03f80d76f1511a811a0209ea7a6a8b6c58704f (diff)
Merge pull request #1 from haskell/ghc-head
Ghc head
Diffstat (limited to 'haddock-api/src')
-rw-r--r--haddock-api/src/Haddock.hs115
-rw-r--r--haddock-api/src/Haddock/Backends/HaddockDB.hs18
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs150
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker.hs64
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs185
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs204
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs189
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs85
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs68
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs252
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml.hs7
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs471
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs12
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Layout.hs91
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Names.hs21
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Themes.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Types.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Utils.hs31
-rw-r--r--haddock-api/src/Haddock/Convert.hs278
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs36
-rw-r--r--haddock-api/src/Haddock/Interface/AttachInstances.hs52
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs151
-rw-r--r--haddock-api/src/Haddock/Interface/LexParseRn.hs70
-rw-r--r--haddock-api/src/Haddock/Interface/ParseModuleHeader.hs1
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs236
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs406
-rw-r--r--haddock-api/src/Haddock/InterfaceFile.hs19
-rw-r--r--haddock-api/src/Haddock/ModuleTree.hs6
-rw-r--r--haddock-api/src/Haddock/Options.hs9
-rw-r--r--haddock-api/src/Haddock/Syb.hs55
-rw-r--r--haddock-api/src/Haddock/Types.hs153
-rw-r--r--haddock-api/src/Haddock/Utils.hs60
-rw-r--r--haddock-api/src/Haddock/Version.hs2
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 "-&gt;", 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 '>' = "&gt;"
f '&' = "&amp;"
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