aboutsummaryrefslogtreecommitdiff
path: root/haddock-api
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api')
-rw-r--r--haddock-api/haddock-api.cabal12
-rw-r--r--haddock-api/resources/html/solarized.css42
-rw-r--r--haddock-api/src/Haddock.hs76
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs15
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker.hs56
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs219
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs387
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs276
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs36
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs98
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs89
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml.hs21
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs34
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs20
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Names.hs28
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Utils.hs7
-rw-r--r--haddock-api/src/Haddock/Convert.hs503
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs268
-rw-r--r--haddock-api/src/Haddock/Interface.hs56
-rw-r--r--haddock-api/src/Haddock/Interface/AttachInstances.hs81
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs71
-rw-r--r--haddock-api/src/Haddock/Interface/Json.hs5
-rw-r--r--haddock-api/src/Haddock/Interface/LexParseRn.hs103
-rw-r--r--haddock-api/src/Haddock/Interface/ParseModuleHeader.hs3
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs112
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs24
-rw-r--r--haddock-api/src/Haddock/InterfaceFile.hs37
-rw-r--r--haddock-api/src/Haddock/Options.hs5
-rw-r--r--haddock-api/src/Haddock/Parser.hs40
-rw-r--r--haddock-api/src/Haddock/Types.hs74
-rw-r--r--haddock-api/src/Haddock/Utils.hs20
-rw-r--r--haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs65
32 files changed, 1765 insertions, 1118 deletions
diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index b4193456..a58b092a 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -44,9 +44,9 @@ library
-- this package typically supports only single major versions
build-depends: base ^>= 4.12.0
, Cabal ^>= 2.4.0
- , ghc ^>= 8.6
+ , ghc ^>= 8.7
, ghc-paths ^>= 0.1.0.9
- , haddock-library ^>= 1.7.0
+ , haddock-library ^>= 1.8.0
, xhtml ^>= 3000.2.2
-- Versions for the dependencies below are transitively pinned by
@@ -59,6 +59,7 @@ library
, directory
, filepath
, ghc-boot
+ , ghc-boot-th
, transformers
hs-source-dirs: src
@@ -97,7 +98,6 @@ library
Haddock.Backends.HaddockDB
Haddock.Backends.Hoogle
Haddock.Backends.Hyperlinker
- Haddock.Backends.Hyperlinker.Ast
Haddock.Backends.Hyperlinker.Parser
Haddock.Backends.Hyperlinker.Renderer
Haddock.Backends.Hyperlinker.Types
@@ -130,7 +130,6 @@ test-suite spec
Haddock
Haddock.Backends.Hoogle
Haddock.Backends.Hyperlinker
- Haddock.Backends.Hyperlinker.Ast
Haddock.Backends.Hyperlinker.Renderer
Haddock.Backends.Hyperlinker.Utils
Haddock.Backends.LaTeX
@@ -169,9 +168,9 @@ test-suite spec
Haddock.Backends.Hyperlinker.Types
build-depends: Cabal ^>= 2.4
- , ghc ^>= 8.6
+ , ghc ^>= 8.7
, ghc-paths ^>= 0.1.0.9
- , haddock-library ^>= 1.7.0
+ , haddock-library ^>= 1.8.0
, xhtml ^>= 3000.2.2
, hspec >= 2.4.4 && < 2.7
, QuickCheck >= 2.11 && < 2.13
@@ -187,6 +186,7 @@ test-suite spec
, directory
, filepath
, ghc-boot
+ , ghc-boot-th
, transformers
build-tool-depends:
diff --git a/haddock-api/resources/html/solarized.css b/haddock-api/resources/html/solarized.css
index e83dc5ec..0146eedd 100644
--- a/haddock-api/resources/html/solarized.css
+++ b/haddock-api/resources/html/solarized.css
@@ -53,3 +53,45 @@ a:link, a:visited {
a:hover, a.hover-highlight {
background-color: #eee8d5;
}
+
+span.annot{
+ position:relative;
+ color:#000;
+ text-decoration:none
+ }
+
+span.annot:hover{z-index:25; background-color:#ff0}
+
+span.annot span.annottext{
+ display: none;
+ border-radius: 5px 5px;
+
+ -moz-border-radius: 5px;
+ -webkit-border-radius: 5px;
+
+ box-shadow: 5px 5px 5px rgba(0, 0, 0, 0.1);
+ -webkit-box-shadow: 5px 5px rgba(0, 0, 0, 0.1);
+ -moz-box-shadow: 5px 5px rgba(0, 0, 0, 0.1);
+
+ position: absolute;
+ left: 1em; top: 2em;
+ z-index: 99;
+ margin-left: 5;
+ background: #FFFFAA;
+ border: 2px solid #FFAD33;
+ padding: 0.8em 1em;
+}
+
+span.annot:hover span.annottext{
+ display:block;
+}
+
+/* This bridges the gap so you can mouse into the tooltip without it disappearing */
+span.annot span.annottext:before{
+ content: "";
+ position: absolute;
+ left: -1em; top: -1em;
+ background: #FFFFFF00;
+ z-index:-1;
+ padding: 2em 2em;
+}
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 4ebdbfb4..412d8391 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -39,8 +39,10 @@ import Haddock.Version
import Haddock.InterfaceFile
import Haddock.Options
import Haddock.Utils
+import Haddock.GhcUtils (modifySessionDynFlags, setOutputDir)
import Control.Monad hiding (forM_)
+import Data.Bifunctor (second)
import Data.Foldable (forM_, foldl')
import Data.Traversable (for)
import Data.List (isPrefixOf)
@@ -66,6 +68,8 @@ import qualified GHC.Paths as GhcPaths
import Paths_haddock_api (getDataDir)
import System.Directory (doesDirectoryExist)
#endif
+import System.Directory (getTemporaryDirectory)
+import System.FilePath ((</>))
import Text.ParserCombinators.ReadP (readP_to_S)
import GHC hiding (verbosity)
@@ -161,16 +165,30 @@ haddockWithGhc ghc args = handleTopExceptions $ do
Just "YES" -> return $ Flag_OptGhc "-dynamic-too" : flags
_ -> return flags
+ -- bypass the interface version check
+ let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags
+
+ -- Create a temporary directory and redirect GHC output there (unless user
+ -- requested otherwise).
+ --
+ -- Output dir needs to be set before calling 'depanal' since 'depanal' uses it
+ -- to compute output file names that are stored in the 'DynFlags' of the
+ -- resulting 'ModSummary's.
+ let withDir | Flag_NoTmpCompDir `elem` flags = id
+ | otherwise = withTempOutputDir
+
unless (Flag_NoWarnings `elem` flags) $ do
hypSrcWarnings flags
forM_ (warnings args) $ \warning -> do
hPutStrLn stderr warning
+ when noChecks $
+ hPutStrLn stderr noCheckWarning
- ghc flags' $ do
+ ghc flags' $ withDir $ do
dflags <- getDynFlags
forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do
- mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)]
+ mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] noChecks
forM_ mIfaceFile $ \(_, ifaceFile) -> do
logOutput dflags (defaultUserStyle dflags) (renderJson (jsonInterfaceFile ifaceFile))
@@ -192,17 +210,30 @@ haddockWithGhc ghc args = handleTopExceptions $ do
throwE "No input file(s)."
-- Get packages supplied with --read-interface.
- packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags)
+ packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) noChecks
-- Render even though there are no input files (usually contents/index).
liftIO $ renderStep dflags flags sinceQual qual packages []
+-- | Run the GHC action using a temporary output directory
+withTempOutputDir :: Ghc a -> Ghc a
+withTempOutputDir action = do
+ tmp <- liftIO getTemporaryDirectory
+ x <- liftIO getProcessID
+ let dir = tmp </> ".haddock-" ++ show x
+ modifySessionDynFlags (setOutputDir dir)
+ withTempDir dir action
+
-- | Create warnings about potential misuse of -optghc
warnings :: [String] -> [String]
warnings = map format . filter (isPrefixOf "-optghc")
where
format arg = concat ["Warning: `", arg, "' means `-o ", drop 2 arg, "', did you mean `-", arg, "'?"]
+-- | Create a warning about bypassing the interface version check
+noCheckWarning :: String
+noCheckWarning = "Warning: `--bypass-interface-version-check' can cause " ++
+ "Haddock to crash when reading Haddock interface files."
withGhc :: [Flag] -> Ghc a -> IO a
withGhc flags action = do
@@ -212,15 +243,17 @@ withGhc flags action = do
let handleSrcErrors action' = flip handleSourceError action' $ \err -> do
printException err
liftIO exitFailure
+ needHieFiles = Flag_HyperlinkedSource `elem` flags
- withGhc' libDir (ghcFlags flags) (\_ -> handleSrcErrors action)
+ withGhc' libDir needHieFiles (ghcFlags flags) (\_ -> handleSrcErrors action)
readPackagesAndProcessModules :: [Flag] -> [String]
-> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv)
readPackagesAndProcessModules flags files = do
-- Get packages supplied with --read-interface.
- packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags)
+ let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags
+ packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags) noChecks
-- Create the interfaces -- this is the core part of Haddock.
let ifaceFiles = map snd packages
@@ -411,13 +444,14 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do
readInterfaceFiles :: MonadIO m
=> NameCacheAccessor m
-> [(DocPaths, FilePath)]
+ -> Bool
-> m [(DocPaths, InterfaceFile)]
-readInterfaceFiles name_cache_accessor pairs = do
+readInterfaceFiles name_cache_accessor pairs bypass_version_check = do
catMaybes `liftM` mapM ({-# SCC readInterfaceFile #-} tryReadIface) pairs
where
-- try to read an interface, warn if we can't
tryReadIface (paths, file) =
- readInterfaceFile name_cache_accessor file >>= \case
+ readInterfaceFile name_cache_accessor file bypass_version_check >>= \case
Left err -> liftIO $ do
putStrLn ("Warning: Cannot read " ++ file ++ ":")
putStrLn (" " ++ err)
@@ -433,14 +467,10 @@ readInterfaceFiles name_cache_accessor pairs = do
-- | Start a GHC session with the -haddock flag set. Also turn off
-- compilation and linking. Then run the given 'Ghc' action.
-withGhc' :: String -> [String] -> (DynFlags -> Ghc a) -> IO a
-withGhc' libDir flags ghcActs = runGhc (Just libDir) $ do
- dynflags <- getSessionDynFlags
- dynflags' <- parseGhcFlags (gopt_set dynflags Opt_Haddock) {
- hscTarget = HscNothing,
- ghcMode = CompManager,
- ghcLink = NoLink
- }
+withGhc' :: String -> Bool -> [String] -> (DynFlags -> Ghc a) -> IO a
+withGhc' libDir needHieFiles flags ghcActs = runGhc (Just libDir) $ do
+ dynflags' <- parseGhcFlags =<< getSessionDynFlags
+
-- We disable pattern match warnings because than can be very
-- expensive to check
let dynflags'' = unsetPatternMatchWarnings $
@@ -468,11 +498,19 @@ withGhc' libDir flags ghcActs = runGhc (Just libDir) $ do
parseGhcFlags dynflags = do
-- TODO: handle warnings?
- let flags' = filterRtsFlags flags
- (dynflags', rest, _) <- parseDynamicFlags dynflags (map noLoc flags')
+ let extra_opts | needHieFiles = [Opt_WriteHie, Opt_Haddock]
+ | otherwise = [Opt_Haddock]
+ dynflags' = (foldl' gopt_set dynflags extra_opts)
+ { hscTarget = HscNothing
+ , ghcMode = CompManager
+ , ghcLink = NoLink
+ }
+ flags' = filterRtsFlags flags
+
+ (dynflags'', rest, _) <- parseDynamicFlags dynflags' (map noLoc flags')
if not (null rest)
then throwE ("Couldn't parse GHC options: " ++ unwords flags')
- else return dynflags'
+ else return dynflags''
unsetPatternMatchWarnings :: DynFlags -> DynFlags
unsetPatternMatchWarnings dflags =
@@ -622,7 +660,7 @@ getPrologue dflags flags =
h <- openFile filename ReadMode
hSetEncoding h utf8
str <- hGetContents h -- semi-closes the handle
- return . Just $! parseParas dflags Nothing str
+ return . Just $! second (fmap rdrName) $ parseParas dflags Nothing str
_ -> throwE "multiple -p/--prologue options"
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 7e2ce2f2..149f4815 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -17,14 +17,14 @@ module Haddock.Backends.Hoogle (
ppHoogle
) where
-import BasicTypes (OverlapFlag(..), OverlapMode(..), SourceText(..))
+import BasicTypes ( OverlapFlag(..), OverlapMode(..), SourceText(..)
+ , PromotionFlag(..) )
import InstEnv (ClsInst(..))
import Documentation.Haddock.Markup
import Haddock.GhcUtils
import Haddock.Types hiding (Version)
import Haddock.Utils hiding (out)
-import HsBinds (emptyLHsBinds)
import GHC
import Outputable
import NameSet
@@ -36,7 +36,6 @@ import Data.Version
import System.Directory
import System.FilePath
-import System.IO
prefix :: [String]
prefix = ["-- Hoogle documentation, generated by Haddock"
@@ -56,10 +55,7 @@ ppHoogle dflags package version synopsis prologue ifaces odir = do
| not (null (versionBranch version)) ] ++
concat [ppModule dflags' i | i <- ifaces, OptHide `notElem` ifaceOptions i]
createDirectoryIfMissing True odir
- h <- openFile (odir </> filename) WriteMode
- hSetEncoding h utf8
- hPutStr h (unlines contents)
- hClose h
+ writeUtf8File (odir </> filename) (unlines contents)
ppModule :: DynFlags -> Interface -> [String]
ppModule dflags iface =
@@ -80,6 +76,7 @@ dropHsDocTy = f
f (HsQualTy x a e) = HsQualTy x a (g e)
f (HsBangTy x a b) = HsBangTy x a (g b)
f (HsAppTy x a b) = HsAppTy x (g a) (g b)
+ f (HsAppKindTy x a b) = HsAppKindTy x (g a) (g b)
f (HsFunTy x a b) = HsFunTy x (g a) (g b)
f (HsListTy x a) = HsListTy x (g a)
f (HsTupleTy x a b) = HsTupleTy x a (map g b)
@@ -338,7 +335,7 @@ markupTag dflags = Markup {
markupString = str,
markupAppend = (++),
markupIdentifier = box (TagInline "a") . str . out dflags,
- markupIdentifierUnchecked = box (TagInline "a") . str . out dflags . snd,
+ markupIdentifierUnchecked = box (TagInline "a") . str . showWrapped (out dflags . snd),
markupModule = box (TagInline "a") . str,
markupWarning = box (TagInline "i"),
markupEmphasis = box (TagInline "i"),
@@ -351,7 +348,7 @@ markupTag dflags = Markup {
markupOrderedList = box (TagL 'o'),
markupDefList = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b),
markupCodeBlock = box TagPre,
- markupHyperlink = \(Hyperlink url mLabel) -> (box (TagInline "a") . str) (fromMaybe url mLabel),
+ markupHyperlink = \(Hyperlink url mLabel) -> box (TagInline "a") (fromMaybe (str url) mLabel),
markupAName = const $ str "",
markupProperty = box TagPre . str,
markupExample = box TagPre . str . unlines . map exampleToString,
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index 248a8a54..5ef7d9bb 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
module Haddock.Backends.Hyperlinker
( ppHyperlinkedSource
, module Haddock.Backends.Hyperlinker.Types
@@ -6,16 +7,26 @@ module Haddock.Backends.Hyperlinker
import Haddock.Types
+import Haddock.Utils (writeUtf8File)
import Haddock.Backends.Hyperlinker.Renderer
+import Haddock.Backends.Hyperlinker.Parser
import Haddock.Backends.Hyperlinker.Types
import Haddock.Backends.Hyperlinker.Utils
-
-import Text.XHtml hiding ((</>))
+import Haddock.Backends.Xhtml.Utils ( renderToString )
import Data.Maybe
import System.Directory
import System.FilePath
+import HieTypes ( HieFile(..), HieASTs(..) )
+import HieBin ( readHieFile )
+import Data.Map as M
+import FastString ( mkFastString )
+import Module ( Module, moduleName )
+import NameCache ( initNameCache )
+import UniqSupply ( mkSplitUniqSupply )
+import SysTools.Info ( getCompilerInfo' )
+
-- | Generate hyperlinked source for given interfaces.
--
@@ -26,10 +37,10 @@ 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
+ -> M.Map Module SrcPath -- ^ Paths to sources
-> [Interface] -- ^ Interfaces for which we create source
-> IO ()
-ppHyperlinkedSource outdir libdir mstyle pretty srcs ifaces = do
+ppHyperlinkedSource outdir libdir mstyle pretty srcs' ifaces = do
createDirectoryIfMissing True srcdir
let cssFile = fromMaybe (defaultCssFile libdir) mstyle
copyFile cssFile $ srcdir </> srcCssFile
@@ -38,17 +49,39 @@ ppHyperlinkedSource outdir libdir mstyle pretty srcs ifaces = do
mapM_ (ppHyperlinkedModuleSource srcdir pretty srcs) ifaces
where
srcdir = outdir </> hypSrcDir
+ srcs = (srcs', M.mapKeys moduleName srcs')
-- | 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 ()
+ppHyperlinkedModuleSource :: FilePath -> Bool -> SrcMaps -> Interface -> IO ()
+ppHyperlinkedModuleSource srcdir pretty srcs iface = case ifaceHieFile iface of
+ Just hfp -> do
+ -- Parse the GHC-produced HIE file
+ u <- mkSplitUniqSupply 'a'
+ HieFile { hie_hs_file = file
+ , hie_asts = HieASTs asts
+ , hie_types = types
+ , hie_hs_src = rawSrc
+ } <- fmap fst (readHieFile (initNameCache u []) hfp)
+ comp <- getCompilerInfo' df
+
+ -- Get the AST and tokens corresponding to the source file we want
+ let mast | M.size asts == 1 = snd <$> M.lookupMin asts
+ | otherwise = M.lookup (mkFastString file) asts
+ tokens = parse comp df file rawSrc
+
+ -- Produce and write out the hyperlinked sources
+ case mast of
+ Just ast ->
+ let fullAst = recoverFullIfaceTypes df types ast
+ in writeUtf8File path . renderToString pretty . render' fullAst $ tokens
+ Nothing
+ | M.size asts == 0 -> return ()
+ | otherwise -> error $ unwords [ "couldn't find ast for"
+ , file, show (M.keys asts) ]
+ Nothing -> return ()
where
+ df = ifaceDynFlags iface
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.
@@ -62,3 +95,4 @@ 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
deleted file mode 100644
index 0ecf7109..00000000
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ /dev/null
@@ -1,219 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeApplications #-}
-
-module Haddock.Backends.Hyperlinker.Ast (enrich) where
-
-
-import qualified Haddock.Syb as Syb
-import Haddock.Backends.Hyperlinker.Types
-
-import qualified GHC
-import qualified SrcLoc
-import qualified Outputable as GHC
-
-import Control.Applicative
-import Control.Monad (guard)
-import Data.Data
-import qualified Data.Map.Strict as Map
-import Data.Maybe
-
-import Prelude hiding (span)
-
-everythingInRenamedSource :: (Alternative f, Data x)
- => (forall a. Data a => a -> f r) -> x -> f r
-everythingInRenamedSource f = Syb.everythingButType @GHC.Name (<|>) f
-
--- | 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 =
- mkDetailsMap (concatMap ($ src)
- [ variables
- , types
- , decls
- , binds
- , imports
- ])
-
-type LTokenDetails = [(GHC.SrcSpan, TokenDetails)]
-
--- | A map containing association between source locations and "details" of
--- this location.
---
-type DetailsMap = Map.Map Position (Span, TokenDetails)
-
-mkDetailsMap :: [(GHC.SrcSpan, TokenDetails)] -> DetailsMap
-mkDetailsMap xs =
- Map.fromListWith select_details [ (start, (span, token_details))
- | (ghc_span, token_details) <- xs
- , GHC.RealSrcSpan span <- [ghc_span]
- , let start = SrcLoc.realSrcSpanStart span
- ]
- where
- -- favour token details which appear earlier in the list
- select_details _new old = old
-
-lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails
-lookupBySpan span details = do
- let pos = SrcLoc.realSrcSpanStart span
- (_, (tok_span, tok_details)) <- Map.lookupLE pos details
- guard (tok_span `SrcLoc.containsSpan` span)
- return tok_details
-
-enrichToken :: Token -> DetailsMap -> Maybe TokenDetails
-enrichToken (Token typ _ spn) dm
- | typ `elem` [TkIdentifier, TkOperator] = lookupBySpan spn dm
-enrichToken _ _ = Nothing
-
--- | Obtain details map for variables ("normally" used identifiers).
-variables :: GHC.RenamedSource -> LTokenDetails
-variables =
- everythingInRenamedSource (var `Syb.combine` rec)
- where
- var term = case cast term of
- (Just ((GHC.L sspan (GHC.HsVar _ name)) :: GHC.LHsExpr GHC.GhcRn)) ->
- pure (sspan, RtkVar (GHC.unLoc name))
- (Just (GHC.L _ (GHC.RecordCon _ (GHC.L sspan name) _))) ->
- pure (sspan, RtkVar name)
- _ -> empty
- rec term = case cast term of
- Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LHsExpr GHC.GhcRn) _) ->
- pure (sspan, RtkVar name)
- _ -> empty
-
--- | Obtain details map for types.
-types :: GHC.RenamedSource -> LTokenDetails
-types = everythingInRenamedSource ty
- where
- ty :: forall a. Data a => a -> [(GHC.SrcSpan, TokenDetails)]
- ty term = case cast term of
- (Just ((GHC.L sspan (GHC.HsTyVar _ _ name)) :: GHC.LHsType GHC.GhcRn)) ->
- pure (sspan, RtkType (GHC.unLoc name))
- (Just ((GHC.L sspan (GHC.HsOpTy _ l name r)) :: GHC.LHsType GHC.GhcRn)) ->
- (sspan, RtkType (GHC.unLoc name)):(ty l ++ ty r)
- _ -> empty
-
--- | Obtain details map for identifier bindings.
---
--- 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 -> LTokenDetails
-binds = everythingInRenamedSource
- (fun `Syb.combine` pat `Syb.combine` tvar)
- where
- fun term = case cast term of
- (Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn)) ->
- pure (sspan, RtkBind name)
- (Just (GHC.PatSynBind _ (GHC.PSB _ (GHC.L sspan name) args _ _))) ->
- pure (sspan, RtkBind name) ++ everythingInRenamedSource patsyn_binds args
- _ -> empty
- patsyn_binds term = case cast term of
- (Just (GHC.L sspan (name :: GHC.Name))) -> pure (sspan, RtkVar name)
- _ -> empty
- pat term = case cast term of
- (Just ((GHC.L sspan (GHC.VarPat _ name)) :: GHC.LPat GHC.GhcRn)) ->
- pure (sspan, RtkBind (GHC.unLoc name))
- (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) ->
- [(sspan, RtkVar name)] ++ everythingInRenamedSource rec recs
- (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.GhcRn) _)) ->
- pure (sspan, RtkVar name)
- _ -> empty
- tvar term = case cast term of
- (Just ((GHC.L sspan (GHC.UserTyVar _ name)) :: GHC.LHsTyVarBndr GHC.GhcRn)) ->
- pure (sspan, RtkBind (GHC.unLoc name))
- (Just (GHC.L _ (GHC.KindedTyVar _ (GHC.L sspan name) _))) ->
- pure (sspan, RtkBind name)
- _ -> empty
-
--- | Obtain details map for top-level declarations.
-decls :: GHC.RenamedSource -> LTokenDetails
-decls (group, _, _, _) = concatMap ($ group)
- [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds
- , everythingInRenamedSource fun . GHC.hs_valds
- , everythingInRenamedSource fix . GHC.hs_fixds
- , everythingInRenamedSource (con `Syb.combine` ins)
- ]
- where
- typ (GHC.L _ t) = case t of
- GHC.DataDecl { tcdLName = name } -> pure . decl $ name
- GHC.SynDecl _ name _ _ _ -> pure . decl $ name
- GHC.FamDecl _ fam -> pure . decl $ GHC.fdLName fam
- GHC.ClassDecl{..} ->
- [decl tcdLName]
- ++ concatMap sig tcdSigs
- ++ concatMap tyfam tcdATs
- GHC.XTyClDecl {} -> GHC.panic "haddock:decls"
- fun term = case cast term of
- (Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn))
- | GHC.isExternalName name -> pure (sspan, RtkDecl name)
- (Just (GHC.PatSynBind _ (GHC.PSB _ (GHC.L sspan name) _ _ _)))
- | GHC.isExternalName name -> pure (sspan, RtkDecl name)
- _ -> empty
- con term = case cast term of
- (Just (cdcl :: GHC.ConDecl GHC.GhcRn)) ->
- map decl (GHC.getConNames cdcl)
- ++ everythingInRenamedSource fld cdcl
- Nothing -> empty
- ins term = case cast term of
- (Just ((GHC.DataFamInstD _ (GHC.DataFamInstDecl eqn))
- :: GHC.InstDecl GHC.GhcRn))
- -> pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn
- (Just (GHC.TyFamInstD _ (GHC.TyFamInstDecl eqn))) ->
- pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn
- _ -> empty
- fld term = case cast term of
- Just (field :: GHC.ConDeclField GHC.GhcRn)
- -> map (decl . fmap GHC.extFieldOcc) $ GHC.cd_fld_names field
- Nothing -> empty
- fix term = case cast term of
- Just ((GHC.FixitySig _ names _) :: GHC.FixitySig GHC.GhcRn)
- -> map (\(GHC.L sspan x) -> (sspan, RtkVar x)) names
- Just ((GHC.XFixitySig {}) :: GHC.FixitySig GHC.GhcRn)
- -> GHC.panic "haddock:decls"
- Nothing -> empty
- tyfam (GHC.L _ (GHC.FamilyDecl{..})) = [decl fdLName]
- tyfam (GHC.L _ (GHC.XFamilyDecl {})) = GHC.panic "haddock:dels"
- sig (GHC.L _ (GHC.TypeSig _ names _)) = map decl names
- sig (GHC.L _ (GHC.PatSynSig _ names _)) = map decl names
- sig (GHC.L _ (GHC.ClassOpSig _ _ names _)) = map decl names
- sig _ = []
- decl (GHC.L sspan name) = (sspan, RtkDecl name)
- tyref (GHC.L sspan name) = (sspan, RtkType name)
-
--- | Obtain details map for import declarations.
---
--- This map also includes type and variable details for items in export and
--- import lists.
-imports :: GHC.RenamedSource -> LTokenDetails
-imports src@(_, imps, _, _) =
- everythingInRenamedSource ie src ++ mapMaybe (imp . GHC.unLoc) imps
- where
- ie term = case cast term of
- (Just ((GHC.IEVar _ v) :: GHC.IE GHC.GhcRn)) -> pure $ var $ GHC.ieLWrappedName v
- (Just (GHC.IEThingAbs _ t)) -> pure $ typ $ GHC.ieLWrappedName t
- (Just (GHC.IEThingAll _ t)) -> pure $ typ $ GHC.ieLWrappedName t
- (Just (GHC.IEThingWith _ t _ vs _fls)) ->
- [typ $ GHC.ieLWrappedName t] ++ map (var . GHC.ieLWrappedName) vs
- (Just (GHC.IEModuleContents _ m)) -> pure $ modu m
- _ -> empty
- typ (GHC.L sspan name) = (sspan, RtkType name)
- var (GHC.L sspan name) = (sspan, RtkVar name)
- modu (GHC.L sspan name) = (sspan, RtkModule name)
- imp idecl
- | not . GHC.ideclImplicit $ idecl = Just (modu (GHC.ideclName idecl))
- | otherwise = Nothing
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index acb2c892..1d5576cc 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -1,213 +1,212 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
module Haddock.Backends.Hyperlinker.Parser (parse) where
-import Data.Either ( isRight, isLeft )
-import Data.List ( foldl', isPrefixOf, isSuffixOf )
-import Data.Maybe ( maybeToList )
-import Data.Char ( isSpace )
-import qualified Text.Read as R
+import Control.Applicative ( Alternative(..) )
+import Data.List ( isPrefixOf, isSuffixOf )
-import GHC ( DynFlags, addSourceToTokens )
-import SrcLoc
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BSC
+
+import GHC.LanguageExtensions.Type
+
+import BasicTypes ( IntegralLit(..) )
+import DynFlags
+import qualified EnumSet as E
+import ErrUtils ( emptyMessages )
import FastString ( mkFastString )
-import StringBuffer ( stringToStringBuffer )
-import Lexer ( Token(..) )
-import qualified Lexer as L
+import Lexer ( P(..), ParseResult(..), PState(..), Token(..)
+ , mkPStatePure, lexer, mkParserFlags' )
+import Outputable ( showSDoc, panic )
+import SrcLoc
+import StringBuffer ( StringBuffer, atEnd )
import Haddock.Backends.Hyperlinker.Types as T
-
+import Haddock.GhcUtils
-- | 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:
---
--- prop> concat . map tkValue . parse = id
---
--- (In reality, this only holds for input not containing '\r', '\t', '\f', '\v',
--- characters, since GHC transforms those into ' ' and '\n')
-parse :: DynFlags -> FilePath -> String -> [T.Token]
-parse dflags fp = ghcToks . processCPP dflags fp . filterCRLF
+-- Result should retain original file layout (including comments,
+-- whitespace, and CPP).
+parse
+ :: CompilerInfo -- ^ Underlying CC compiler (whatever expanded CPP)
+ -> DynFlags -- ^ Flags for this module
+ -> FilePath -- ^ Path to the source of this module
+ -> BS.ByteString -- ^ Raw UTF-8 encoded source of this module
+ -> [T.Token]
+parse comp dflags fpath bs = case unP (go False []) initState of
+ POk _ toks -> reverse toks
+ PFailed _ ss errMsg -> panic $ "Hyperlinker parse error at " ++ show ss ++
+ ": " ++ showSDoc dflags errMsg
where
- -- Remove CRLFs from source
- filterCRLF :: String -> String
- filterCRLF ('\r':'\n':cs) = '\n' : filterCRLF cs
- filterCRLF (c:cs) = c : filterCRLF cs
- filterCRLF [] = []
--- | Parse the source into tokens using the GHC lexer.
+ initState = mkPStatePure pflags buf start
+ buf = stringBufferFromByteString bs
+ start = mkRealSrcLoc (mkFastString fpath) 1 1
+ needPragHack' = needPragHack comp dflags
+ pflags = mkParserFlags' (warningFlags dflags)
+ (extensionFlags dflags)
+ (thisPackage dflags)
+ (safeImportsOn dflags)
+ False -- lex Haddocks as comment tokens
+ True -- produce comment tokens
+ False -- produce position pragmas tokens
+
+ go :: Bool -- ^ are we currently in a pragma?
+ -> [T.Token] -- ^ tokens accumulated so far (in reverse)
+ -> P [T.Token]
+ go inPrag toks = do
+ (b, _) <- getInput
+ if not (atEnd b)
+ then do
+ (newToks, inPrag') <- parseCppLine <|> parsePlainTok inPrag <|> unknownLine
+ go inPrag' (newToks ++ toks)
+ else
+ pure toks
+
+ -- | Like 'Lexer.lexer', but slower, with a better API, and filtering out empty tokens
+ wrappedLexer :: P (RealLocated Lexer.Token)
+ wrappedLexer = Lexer.lexer False andThen
+ where andThen (L (RealSrcSpan s) t)
+ | srcSpanStartLine s /= srcSpanEndLine s ||
+ srcSpanStartCol s /= srcSpanEndCol s
+ = pure (L s t)
+ andThen (L (RealSrcSpan s) ITeof) = pure (L s ITeof)
+ andThen _ = wrappedLexer
+
+ -- | Try to parse a CPP line (can fail)
+ parseCppLine :: P ([T.Token], Bool)
+ parseCppLine = do
+ (b, l) <- getInput
+ case tryCppLine l b of
+ Just (cppBStr, l', b')
+ -> let cppTok = T.Token { tkType = TkCpp
+ , tkValue = cppBStr
+ , tkSpan = mkRealSrcSpan l l' }
+ in setInput (b', l') *> pure ([cppTok], False)
+ _ -> empty
+
+ -- | Try to parse a regular old token (can fail)
+ parsePlainTok :: Bool -> P ([T.Token], Bool) -- return list is only ever 0-2 elements
+ parsePlainTok inPrag = do
+ (bInit, lInit) <- getInput
+ L sp tok <- Lexer.lexer False return
+ (bEnd, _) <- getInput
+ case sp of
+ UnhelpfulSpan _ -> pure ([], False) -- pretend the token never existed
+ RealSrcSpan rsp -> do
+ let typ = if inPrag then TkPragma else classify tok
+ RealSrcLoc lStart = srcSpanStart sp -- safe since @sp@ is real
+ (spaceBStr, bStart) = spanPosition lInit lStart bInit
+ inPragDef = inPragma inPrag tok
+
+ (bEnd', inPrag') <- case tok of
+
+ -- Update internal line + file position if this is a LINE pragma
+ ITline_prag _ -> tryOrElse (bEnd, inPragDef) $ do
+ L _ (ITinteger (IL { il_value = line })) <- wrappedLexer
+ L _ (ITstring _ file) <- wrappedLexer
+ L spF ITclose_prag <- wrappedLexer
+
+ let newLoc = mkRealSrcLoc file (fromIntegral line - 1) (srcSpanEndCol spF)
+ (bEnd'', _) <- getInput
+ setInput (bEnd'', newLoc)
+
+ pure (bEnd'', False)
+
+ -- Update internal column position if this is a COLUMN pragma
+ ITcolumn_prag _ -> tryOrElse (bEnd, inPragDef) $ do
+ L _ (ITinteger (IL { il_value = col })) <- wrappedLexer
+ L spF ITclose_prag <- wrappedLexer
+
+ let newLoc = mkRealSrcLoc (srcSpanFile spF) (srcSpanEndLine spF) (fromIntegral col)
+ (bEnd'', _) <- getInput
+ setInput (bEnd'', newLoc)
+
+ pure (bEnd'', False)
+
+ -- See 'needPragHack'
+ ITclose_prag{}
+ | needPragHack'
+ , '\n' `BSC.elem` spaceBStr
+ -> getInput >>= \(b,p) -> setInput (b,advanceSrcLoc p '\n') >> pure (bEnd, False)
+
+ _ -> pure (bEnd, inPragDef)
+
+ let tokBStr = splitStringBuffer bStart bEnd'
+ plainTok = T.Token { tkType = typ
+ , tkValue = tokBStr
+ , tkSpan = rsp }
+ spaceTok = T.Token { tkType = TkSpace
+ , tkValue = spaceBStr
+ , tkSpan = mkRealSrcSpan lInit lStart }
+
+ pure (plainTok : [ spaceTok | not (BS.null spaceBStr) ], inPrag')
+
+ -- | Parse whatever remains of the line as an unknown token (can't fail)
+ unknownLine :: P ([T.Token], Bool)
+ unknownLine = do
+ (b, l) <- getInput
+ let (unkBStr, l', b') = spanLine l b
+ unkTok = T.Token { tkType = TkUnknown
+ , tkValue = unkBStr
+ , tkSpan = mkRealSrcSpan l l' }
+ setInput (b', l')
+ pure ([unkTok], False)
+
+
+-- | This is really, really, /really/ gross. Problem: consider a Haskell
+-- file that looks like:
--
--- * CPP lines are removed and reinserted as line-comments
--- * top-level file pragmas are parsed as block comments (see the
--- 'ITblockComment' case of 'classify' for more details)
+-- @
+-- {-# LANGUAGE CPP #-}
+-- module SomeMod where
--
-processCPP :: DynFlags -- ^ GHC's flags
- -> FilePath -- ^ source file name (for position information)
- -> String -- ^ source file contents
- -> [(Located L.Token, String)]
-processCPP dflags fpath s = addSrc . go start . splitCPP $ s
- where
- start = mkRealSrcLoc (mkFastString fpath) 1 1
- addSrc = addSourceToTokens start (stringToStringBuffer s)
-
- -- Transform a list of Haskell/CPP lines into a list of tokens
- go :: RealSrcLoc -> [Either String String] -> [Located L.Token]
- go _ [] = []
- go pos ls =
- let (hLinesRight, ls') = span isRight ls
- (cppLinesLeft, rest) = span isLeft ls'
-
- hSrc = concat [ hLine | Right hLine <- hLinesRight ]
- cppSrc = concat [ cppLine | Left cppLine <- cppLinesLeft ]
-
- in case L.lexTokenStream (stringToStringBuffer hSrc) pos dflags of
-
- -- Stuff that fails to lex gets turned into comments
- L.PFailed _ _ss _msg ->
- let (src_pos, failed) = mkToken ITunknown pos hSrc
- (new_pos, cpp) = mkToken ITlineComment src_pos cppSrc
- in failed : cpp : go new_pos rest
-
- -- Successfully lexed
- L.POk ss toks ->
- let (new_pos, cpp) = mkToken ITlineComment (L.loc ss) cppSrc
- in toks ++ [cpp] ++ go new_pos rest
-
- -- Manually make a token from a 'String', advancing the cursor position
- mkToken tok start' str =
- let end = foldl' advanceSrcLoc start' str
- in (end, L (RealSrcSpan $ mkRealSrcSpan start' end) (tok str))
-
-
--- | Split apart the initial file into Haskell source lines ('Left' entries) and
--- CPP lines ('Right' entries).
+-- #define SIX 6
+--
+-- {-# INLINE foo
+-- #-}
+-- foo = 1
+-- @
--
--- All characters in the input are present in the output:
+-- Clang's CPP replaces the @#define SIX 6@ line with an empty line (as it
+-- should), but get confused about @#-}@. I'm guessing it /starts/ by
+-- parsing that as a pre-processor directive and, when it fails to, it just
+-- leaves the line alone. HOWEVER, it still adds an extra newline. =.=
--
--- prop> concat . map (either id id) . splitCPP = id
-splitCPP :: String -> [Either String String]
-splitCPP "" = []
-splitCPP s | isCPPline s = Left l : splitCPP rest
- | otherwise = Right l : splitCPP rest
+-- This function makes sure that the Hyperlinker backend also adds that
+-- extra newline (or else our spans won't line up with GHC's anymore).
+needPragHack :: CompilerInfo -> DynFlags -> Bool
+needPragHack comp dflags = isCcClang && E.member Cpp (extensionFlags dflags)
where
- ~(l, rest) = spanToNewline 0 s
+ isCcClang = case comp of
+ GCC -> False
+ Clang -> True
+ AppleClang -> True
+ AppleClang51 -> True
+ UnknownCC -> False
+-- | Get the input
+getInput :: P (StringBuffer, RealSrcLoc)
+getInput = P $ \p @ PState { buffer = buf, loc = srcLoc } -> POk p (buf, srcLoc)
--- | Heuristic to decide if a line is going to be a CPP line. This should be a
--- cheap operation since it is going to be run on every line being processed.
---
--- Right now it just checks if the first non-whitespace character in the first
--- five characters of the line is a '#':
---
--- >>> isCPPline "#define FOO 1"
--- True
---
--- >>> isCPPline "\t\t #ifdef GHC"
--- True
---
--- >>> isCPPline " #endif"
--- False
---
-isCPPline :: String -> Bool
-isCPPline = isPrefixOf "#" . dropWhile (`elem` " \t") . take 5
+-- | Set the input
+setInput :: (StringBuffer, RealSrcLoc) -> P ()
+setInput (buf, srcLoc) = P $ \p -> POk (p { buffer = buf, loc = srcLoc }) ()
--- | Split a "line" off the front of a string, hopefully without cutting tokens
--- in half. I say "hopefully" because knowing what a token is requires lexing,
--- yet lexing depends on this function.
---
--- All characters in the input are present in the output:
---
--- prop> curry (++) . spanToNewLine 0 = id
-spanToNewline :: Int -- ^ open '{-'
- -> String -- ^ input
- -> (String, String)
-
--- Base case and space characters
-spanToNewline _ "" = ("", "")
-spanToNewline n ('\n':str) | n <= 0 = ("\n", str)
-spanToNewline n ('\n':str) | n <= 0 = ("\n", str)
-spanToNewline n ('\\':'\n':str) =
- let (str', rest) = spanToNewline n str
- in ('\\':'\n':str', rest)
-
--- Block comments
-spanToNewline n ('{':'-':str) =
- let (str', rest) = spanToNewline (n+1) str
- in ('{':'-':str', rest)
-spanToNewline n ('-':'}':str) =
- let (str', rest) = spanToNewline (n-1) str
- in ('-':'}':str', rest)
-
--- When not in a block comment, try to lex a Haskell token
-spanToNewline 0 str@(c:_) | ((lexed, str') : _) <- R.lex str, not (isSpace c) =
- if all (== '-') lexed && length lexed >= 2
- -- A Haskell line comment
- then case span (/= '\n') str' of
- (str'', '\n':rest) -> (lexed ++ str'' ++ "\n", rest)
- (_, _) -> (str, "")
-
- -- An actual Haskell token
- else let (str'', rest) = spanToNewline 0 str'
- in (lexed ++ str'', rest)
-
--- In all other cases, advance one character at a time
-spanToNewline n (c:str) =
- let (str', rest) = spanToNewline n str
- in (c:str', rest)
-
-
--- | Turn a list of GHC's 'L.Token' (and their source 'String') into a list of
--- Haddock's 'T.Token'.
-ghcToks :: [(Located L.Token, String)] -> [T.Token]
-ghcToks = reverse . (\(_,ts,_) -> ts) . foldl' go (start, [], False)
- where
- start = mkRealSrcLoc (mkFastString "lexing") 1 1
-
- go :: (RealSrcLoc, [T.Token], Bool)
- -- ^ current position, tokens accumulated, currently in pragma (or not)
-
- -> (Located L.Token, String)
- -- ^ next token, its content
-
- -> (RealSrcLoc, [T.Token], Bool)
- -- ^ new position, new tokens accumulated, currently in pragma (or not)
-
- go (pos, toks, in_prag) (L l tok, raw) =
- ( next_pos
- , classifiedTok ++ maybeToList white ++ toks
- , inPragma in_prag tok
- )
- where
- (next_pos, white) = mkWhitespace pos l
-
- classifiedTok = [ Token (classify' tok) raw rss
- | RealSrcSpan rss <- [l]
- , not (null raw)
- ]
-
- classify' | in_prag = const TkPragma
- | otherwise = classify
-
-
--- | Find the correct amount of whitespace between tokens.
-mkWhitespace :: RealSrcLoc -> SrcSpan -> (RealSrcLoc, Maybe T.Token)
-mkWhitespace prev spn =
- case spn of
- UnhelpfulSpan _ -> (prev,Nothing)
- RealSrcSpan s | null wsstring -> (end, Nothing)
- | otherwise -> (end, Just (Token TkSpace wsstring wsspan))
- where
- start = realSrcSpanStart s
- end = realSrcSpanEnd s
- wsspan = mkRealSrcSpan prev start
- nls = srcLocLine start - srcLocLine prev
- spaces = if nls == 0 then srcLocCol start - srcLocCol prev
- else srcLocCol start - 1
- wsstring = replicate nls '\n' ++ replicate spaces ' '
+-- | Orphan instance that adds backtracking to 'P'
+instance Alternative P where
+ empty = P $ \_ -> PFailed (const emptyMessages) noSrcSpan "Alterative.empty"
+ P x <|> P y = P $ \s -> case x s of { p@POk{} -> p
+ ; _ -> y s }
+-- | Try a parser. If it fails, backtrack and return the pure value.
+tryOrElse :: a -> P a -> P a
+tryOrElse x p = p <|> pure x
-- | Classify given tokens as appropriate Haskell token type.
-classify :: L.Token -> TokenType
+classify :: Lexer.Token -> TokenType
classify tok =
case tok of
ITas -> TkKeyword
@@ -378,15 +377,11 @@ classify tok =
ITLarrowtail {} -> TkGlyph
ITRarrowtail {} -> TkGlyph
+ ITcomment_line_prag -> TkUnknown
ITunknown {} -> TkUnknown
ITeof -> TkUnknown
- -- Line comments are only supposed to start with '--'. Starting with '#'
- -- means that this was probably a CPP.
- ITlineComment s
- | isCPPline s -> TkCpp
- | otherwise -> TkComment
-
+ ITlineComment {} -> TkComment
ITdocCommentNext {} -> TkComment
ITdocCommentPrev {} -> TkComment
ITdocCommentNamed {} -> TkComment
@@ -403,9 +398,9 @@ classify tok =
| otherwise -> TkComment
-- | Classify given tokens as beginning pragmas (or not).
-inPragma :: Bool -- ^ currently in pragma
- -> L.Token -- ^ current token
- -> Bool -- ^ new information about whether we are in a pragma
+inPragma :: Bool -- ^ currently in pragma
+ -> Lexer.Token -- ^ current token
+ -> Bool -- ^ new information about whether we are in a pragma
inPragma _ ITclose_prag = False
inPragma True _ = True
inPragma False tok =
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index d7ea70a6..a4dcb77b 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -1,4 +1,8 @@
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE BangPatterns #-}
module Haddock.Backends.Hyperlinker.Renderer (render) where
@@ -6,15 +10,19 @@ 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 qualified Data.ByteString as BS
+
+import HieTypes
+import Module ( ModuleName, moduleNameString )
+import Name ( getOccString, isInternalName, Name, nameModule, nameUnique )
+import SrcLoc
+import Unique ( getKey )
+import Encoding ( utf8DecodeByteString )
import System.FilePath.Posix ((</>))
-import Data.List
-import Data.Maybe
import qualified Data.Map as Map
+import qualified Data.Set as Set
import Text.XHtml (Html, HtmlAttr, (!))
import qualified Text.XHtml as Html
@@ -22,22 +30,24 @@ import qualified Text.XHtml as Html
type StyleClass = String
+-- | Produce the HTML corresponding to a hyperlinked Haskell source
+render
+ :: Maybe FilePath -- ^ path to the CSS file
+ -> Maybe FilePath -- ^ path to the JS file
+ -> SrcMaps -- ^ Paths to sources
+ -> HieAST PrintedType -- ^ ASTs from @.hie@ files
+ -> [Token] -- ^ tokens to render
+ -> Html
+render mcss mjs srcs ast tokens = header mcss mjs <> body srcs ast tokens
-render :: Maybe FilePath -> Maybe FilePath -> SrcMap -> [RichToken]
- -> Html
-render mcss mjs srcs tokens = header mcss mjs <> body srcs tokens
-
-body :: SrcMap -> [RichToken] -> Html
-body srcs tokens = Html.body . Html.pre $ hypsrc
+body :: SrcMaps -> HieAST PrintedType -> [Token] -> Html
+body srcs ast tokens = Html.body . Html.pre $ hypsrc
where
- hypsrc = mconcat . map (richToken srcs) $ tokens
-
+ hypsrc = renderWithAst srcs ast 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
+header Nothing Nothing = Html.noHtml
+header mcss mjs = Html.header $ css mcss <> js mjs
where
css Nothing = Html.noHtml
css (Just cssFile) = Html.thelink Html.noHtml !
@@ -51,25 +61,132 @@ header mcss mjs =
, Html.src scriptFile
]
+
+splitTokens :: HieAST PrintedType -> [Token] -> ([Token],[Token],[Token])
+splitTokens ast toks = (before,during,after)
+ where
+ (before,rest) = span leftOf toks
+ (during,after) = span inAst rest
+ leftOf t = realSrcSpanEnd (tkSpan t) <= realSrcSpanStart nodeSp
+ inAst t = nodeSp `containsSpan` tkSpan t
+ nodeSp = nodeSpan ast
+
+-- | Turn a list of tokens into hyperlinked sources, threading in relevant link
+-- information from the 'HieAST'.
+renderWithAst :: SrcMaps -> HieAST PrintedType -> [Token] -> Html
+renderWithAst srcs Node{..} toks = anchored $ case toks of
+
+ [tok] | nodeSpan == tkSpan tok -> richToken srcs nodeInfo tok
+
+ -- NB: the GHC lexer lexes backquoted identifiers and parenthesized operators
+ -- as multiple tokens.
+ --
+ -- * @a `elem` b@ turns into @[a, `, elem, `, b]@ (excluding space tokens)
+ -- * @(+) 1 2@ turns into @[(, +, ), 1, 2]@ (excluding space tokens)
+ --
+ -- However, the HIE ast considers @`elem`@ and @(+)@ to be single nodes. In
+ -- order to make sure these get hyperlinked properly, we intercept these
+ -- special sequences of tokens and merge them into just one identifier or
+ -- operator token.
+ [BacktickTok s1, tok @ Token{ tkType = TkIdentifier }, BacktickTok s2]
+ | realSrcSpanStart s1 == realSrcSpanStart nodeSpan
+ , realSrcSpanEnd s2 == realSrcSpanEnd nodeSpan
+ -> richToken srcs nodeInfo
+ (Token{ tkValue = "`" <> tkValue tok <> "`"
+ , tkType = TkOperator
+ , tkSpan = nodeSpan })
+ [OpenParenTok s1, tok @ Token{ tkType = TkOperator }, CloseParenTok s2]
+ | realSrcSpanStart s1 == realSrcSpanStart nodeSpan
+ , realSrcSpanEnd s2 == realSrcSpanEnd nodeSpan
+ -> richToken srcs nodeInfo
+ (Token{ tkValue = "(" <> tkValue tok <> ")"
+ , tkType = TkOperator
+ , tkSpan = nodeSpan })
+
+ _ -> go nodeChildren toks
+ where
+ go _ [] = mempty
+ go [] xs = foldMap renderToken xs
+ go (cur:rest) xs =
+ foldMap renderToken before <> renderWithAst srcs cur during <> go rest after
+ where
+ (before,during,after) = splitTokens cur xs
+ anchored c = Map.foldrWithKey anchorOne c (nodeIdentifiers nodeInfo)
+ anchorOne n dets c = externalAnchor n d $ internalAnchor n d c
+ where d = identInfo dets
+
+renderToken :: Token -> Html
+renderToken Token{..}
+ | BS.null tkValue = mempty
+ | tkType == TkSpace = renderSpace (srcSpanStartLine tkSpan) tkValue'
+ | otherwise = tokenSpan ! [ multiclass style ]
+ where
+ tkValue' = filterCRLF $ utf8DecodeByteString tkValue
+ style = tokenStyle tkType
+ tokenSpan = Html.thespan (Html.toHtml tkValue')
+
+
-- | Given information about the source position of definitions, render a token
-richToken :: SrcMap -> RichToken -> Html
-richToken srcs (RichToken Token{..} details)
- | tkType == TkSpace = renderSpace (GHC.srcSpanStartLine tkSpan) tkValue
- | otherwise = linked content
+richToken :: SrcMaps -> NodeInfo PrintedType -> Token -> Html
+richToken srcs details Token{..}
+ | tkType == TkSpace = renderSpace (srcSpanStartLine tkSpan) tkValue'
+ | otherwise = annotate details $ linked content
where
+ tkValue' = filterCRLF $ utf8DecodeByteString tkValue
content = tokenSpan ! [ multiclass style ]
- tokenSpan = Html.thespan (Html.toHtml tkValue)
- style = tokenStyle tkType ++ maybe [] richTokenStyle details
+ tokenSpan = Html.thespan (Html.toHtml tkValue')
+ style = tokenStyle tkType ++ concatMap (richTokenStyle (null (nodeType details))) contexts
+
+ contexts = concatMap (Set.elems . identInfo) . Map.elems . nodeIdentifiers $ details
+
+ -- pick an arbitary identifier to hyperlink with
+ identDet = Map.lookupMin . nodeIdentifiers $ details
-- If we have name information, we can make links
- linked = case details of
- Just d -> externalAnchor d . internalAnchor d . hyperlink srcs d
+ linked = case identDet of
+ Just (n,_) -> hyperlink srcs n
Nothing -> id
-richTokenStyle :: TokenDetails -> [StyleClass]
-richTokenStyle (RtkVar _) = ["hs-var"]
-richTokenStyle (RtkType _) = ["hs-type"]
-richTokenStyle _ = []
+-- | Remove CRLFs from source
+filterCRLF :: String -> String
+filterCRLF ('\r':'\n':cs) = '\n' : filterCRLF cs
+filterCRLF (c:cs) = c : filterCRLF cs
+filterCRLF [] = []
+
+annotate :: NodeInfo PrintedType -> Html -> Html
+annotate ni content =
+ Html.thespan (annot <> content) ! [ Html.theclass "annot" ]
+ where
+ annot
+ | not (null annotation) =
+ Html.thespan (Html.toHtml annotation) ! [ Html.theclass "annottext" ]
+ | otherwise = mempty
+ annotation = typ ++ identTyps
+ typ = unlines (nodeType ni)
+ typedIdents = [ (n,t) | (n, identType -> Just t) <- Map.toList $ nodeIdentifiers ni ]
+ identTyps
+ | length typedIdents > 1 || null (nodeType ni)
+ = concatMap (\(n,t) -> printName n ++ " :: " ++ t ++ "\n") typedIdents
+ | otherwise = ""
+
+ printName :: Either ModuleName Name -> String
+ printName = either moduleNameString getOccString
+
+richTokenStyle
+ :: Bool -- ^ are we lacking a type annotation?
+ -> ContextInfo -- ^ in what context did this token show up?
+ -> [StyleClass]
+richTokenStyle True Use = ["hs-type"]
+richTokenStyle False Use = ["hs-var"]
+richTokenStyle _ RecField{} = ["hs-var"]
+richTokenStyle _ PatternBind{} = ["hs-var"]
+richTokenStyle _ MatchBind{} = ["hs-var"]
+richTokenStyle _ TyVarBind{} = ["hs-type"]
+richTokenStyle _ ValBind{} = ["hs-var"]
+richTokenStyle _ TyDecl = ["hs-type"]
+richTokenStyle _ ClassTyDecl{} = ["hs-type"]
+richTokenStyle _ Decl{} = ["hs-var"]
+richTokenStyle _ IEThing{} = [] -- could be either a value or type
tokenStyle :: TokenType -> [StyleClass]
tokenStyle TkIdentifier = ["hs-identifier"]
@@ -87,61 +204,70 @@ tokenStyle TkPragma = ["hs-pragma"]
tokenStyle TkUnknown = []
multiclass :: [StyleClass] -> HtmlAttr
-multiclass = Html.theclass . intercalate " "
+multiclass = Html.theclass . unwords
+
+externalAnchor :: Identifier -> Set.Set ContextInfo -> Html -> Html
+externalAnchor (Right name) contexts content
+ | not (isInternalName name)
+ , any isBinding contexts
+ = Html.thespan content ! [ Html.identifier $ externalAnchorIdent name ]
+externalAnchor _ _ content = content
-externalAnchor :: TokenDetails -> Html -> Html
-externalAnchor (RtkDecl name) content =
- Html.anchor content ! [ Html.name $ externalAnchorIdent name ]
-externalAnchor _ content = content
+isBinding :: ContextInfo -> Bool
+isBinding (ValBind RegularBind _ _) = True
+isBinding PatternBind{} = True
+isBinding Decl{} = True
+isBinding (RecField RecFieldDecl _) = True
+isBinding TyVarBind{} = True
+isBinding ClassTyDecl{} = True
+isBinding _ = False
-internalAnchor :: TokenDetails -> Html -> Html
-internalAnchor (RtkBind name) content =
- Html.anchor content ! [ Html.name $ internalAnchorIdent name ]
-internalAnchor _ content = content
+internalAnchor :: Identifier -> Set.Set ContextInfo -> Html -> Html
+internalAnchor (Right name) contexts content
+ | isInternalName name
+ , any isBinding contexts
+ = Html.thespan content ! [ Html.identifier $ internalAnchorIdent name ]
+internalAnchor _ _ content = content
-externalAnchorIdent :: GHC.Name -> String
+externalAnchorIdent :: 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
+internalAnchorIdent :: Name -> String
+internalAnchorIdent = ("local-" ++) . show . getKey . nameUnique
+
+-- | Generate the HTML hyperlink for an identifier
+hyperlink :: SrcMaps -> Identifier -> Html -> Html
+hyperlink (srcs, srcs') ident = case ident of
+ Right name | isInternalName name -> internalHyperlink name
+ | otherwise -> externalNameHyperlink name
+ Left name -> externalModHyperlink name
+
where
- mdl = GHC.nameModule name
+ internalHyperlink name content =
+ Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ]
+
+ externalNameHyperlink 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 $ spliceURL Nothing (Just mdl) (Just name) Nothing (".." </> path) ]
+ Nothing -> content
+ where
+ mdl = nameModule name
-externalModHyperlink :: SrcMap -> GHC.ModuleName -> Html -> Html
-externalModHyperlink srcs name content =
- let srcs' = Map.mapKeys GHC.moduleName srcs in
- case Map.lookup name srcs' of
- Just SrcLocal -> Html.anchor content !
- [ Html.href $ hypSrcModuleUrl' name ]
- Just (SrcExternal path) -> Html.anchor content !
- [ Html.href $ path </> hypSrcModuleUrl' name ]
- Nothing -> content
+ externalModHyperlink moduleName content =
+ case Map.lookup moduleName srcs' of
+ Just SrcLocal -> Html.anchor content !
+ [ Html.href $ hypSrcModuleUrl' moduleName ]
+ Just (SrcExternal path) -> Html.anchor content !
+ [ Html.href $ spliceURL' Nothing (Just moduleName) Nothing Nothing (".." </> path) ]
+ Nothing -> content
renderSpace :: Int -> String -> Html
-renderSpace _ [] = Html.noHtml
-renderSpace line ('\n':rest) = mconcat
- [ Html.thespan . Html.toHtml $ "\n"
+renderSpace !_ "" = Html.noHtml
+renderSpace !line ('\n':rest) = mconcat
+ [ Html.thespan (Html.toHtml '\n')
, lineAnchor (line + 1)
, renderSpace (line + 1) rest
]
@@ -151,4 +277,4 @@ renderSpace line space =
lineAnchor :: Int -> Html
-lineAnchor line = Html.anchor Html.noHtml ! [ Html.name $ hypSrcLineUrl line ]
+lineAnchor line = Html.thespan Html.noHtml ! [ Html.identifier $ hypSrcLineUrl line ]
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
index e377471e..50916937 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
@@ -1,17 +1,24 @@
+{-# LANGUAGE PatternSynonyms, OverloadedStrings #-}
module Haddock.Backends.Hyperlinker.Types where
-
import qualified GHC
+import Data.ByteString ( ByteString )
+
import Data.Map (Map)
data Token = Token
{ tkType :: TokenType
- , tkValue :: String
+ , tkValue :: ByteString -- ^ UTF-8 encoded
, tkSpan :: {-# UNPACK #-} !Span
}
deriving (Show)
+pattern BacktickTok, OpenParenTok, CloseParenTok :: Span -> Token
+pattern BacktickTok sp = Token TkSpecial "`" sp
+pattern OpenParenTok sp = Token TkSpecial "(" sp
+pattern CloseParenTok sp = Token TkSpecial ")" sp
+
type Position = GHC.RealSrcLoc
type Span = GHC.RealSrcSpan
@@ -31,29 +38,6 @@ data TokenType
| 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
@@ -63,5 +47,5 @@ data SrcPath
| SrcLocal
-- | Mapping from modules to cross-package source paths.
-type SrcMap = Map GHC.Module SrcPath
+type SrcMaps = (Map GHC.Module SrcPath, Map GHC.ModuleName SrcPath)
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
index 9de4a03d..4e8b88d2 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
module Haddock.Backends.Hyperlinker.Utils
( hypSrcDir, hypSrcModuleFile, hypSrcModuleFile'
, hypSrcModuleUrl, hypSrcModuleUrl'
@@ -6,21 +7,35 @@ module Haddock.Backends.Hyperlinker.Utils
, hypSrcModuleNameUrl, hypSrcModuleLineUrl
, hypSrcModuleUrlFormat
, hypSrcModuleNameUrlFormat, hypSrcModuleLineUrlFormat
- ) where
+ , spliceURL, spliceURL'
+ -- * HIE file processing
+ , PrintedType
+ , recoverFullIfaceTypes
+ ) where
+import Haddock.Utils
import Haddock.Backends.Xhtml.Utils
import GHC
-import FastString
-import System.FilePath.Posix ((</>))
+import HieTypes ( HieAST(..), HieType(..), HieArgs(..), TypeIndex, HieTypeFlat )
+import IfaceType
+import Name ( getOccFS, getOccString )
+import Outputable ( showSDoc )
+import Var ( VarBndr(..) )
+
+import System.FilePath.Posix ((</>), (<.>))
+import qualified Data.Array as A
+
+{-# INLINE hypSrcDir #-}
hypSrcDir :: FilePath
hypSrcDir = "src"
+{-# INLINE hypSrcModuleFile #-}
hypSrcModuleFile :: Module -> FilePath
-hypSrcModuleFile = hypSrcModuleFile' . moduleName
+hypSrcModuleFile m = moduleNameString (moduleName m) <.> "html"
hypSrcModuleFile' :: ModuleName -> FilePath
hypSrcModuleFile' mdl = spliceURL'
@@ -32,20 +47,19 @@ hypSrcModuleUrl = hypSrcModuleFile
hypSrcModuleUrl' :: ModuleName -> String
hypSrcModuleUrl' = hypSrcModuleFile'
+{-# INLINE hypSrcNameUrl #-}
hypSrcNameUrl :: Name -> String
-hypSrcNameUrl name = spliceURL
- Nothing Nothing (Just name) Nothing nameFormat
+hypSrcNameUrl = escapeStr . getOccString
+{-# INLINE hypSrcLineUrl #-}
hypSrcLineUrl :: Int -> String
-hypSrcLineUrl line = spliceURL
- Nothing Nothing Nothing (Just spn) lineFormat
- where
- loc = mkSrcLoc nilFS line 1
- spn = mkSrcSpan loc loc
+hypSrcLineUrl line = "line-" ++ show line
+{-# INLINE hypSrcModuleNameUrl #-}
hypSrcModuleNameUrl :: Module -> Name -> String
hypSrcModuleNameUrl mdl name = hypSrcModuleUrl mdl ++ "#" ++ hypSrcNameUrl name
+{-# INLINE hypSrcModuleLineUrl #-}
hypSrcModuleLineUrl :: Module -> Int -> String
hypSrcModuleLineUrl mdl line = hypSrcModuleUrl mdl ++ "#" ++ hypSrcLineUrl line
@@ -66,3 +80,65 @@ nameFormat = "%{NAME}"
lineFormat :: String
lineFormat = "line-%{LINE}"
+
+
+-- * HIE file procesddsing
+
+-- This belongs in GHC's HieUtils...
+
+-- | Pretty-printed type, ready to be turned into HTML by @xhtml@
+type PrintedType = String
+
+-- | Expand the flattened HIE AST into one where the types printed out and
+-- ready for end-users to look at.
+--
+-- Using just primitives found in GHC's HIE utilities, we could write this as
+-- follows:
+--
+-- > 'recoverFullIfaceTypes' dflags hieTypes hieAst
+-- > = 'fmap' (\ti -> 'showSDoc' df .
+-- > 'pprIfaceType' $
+-- > 'recoverFullType' ti hieTypes)
+-- > hieAst
+--
+-- However, this is very inefficient (both in time and space) because the
+-- mutliple calls to 'recoverFullType' don't share intermediate results. This
+-- function fixes that.
+recoverFullIfaceTypes
+ :: DynFlags
+ -> A.Array TypeIndex HieTypeFlat -- ^ flat types
+ -> HieAST TypeIndex -- ^ flattened AST
+ -> HieAST PrintedType -- ^ full AST
+recoverFullIfaceTypes df flattened ast = fmap (printed A.!) ast
+ where
+
+ -- Splitting this out into its own array is also important: we don't want
+ -- to pretty print the same type many times
+ printed :: A.Array TypeIndex PrintedType
+ printed = fmap (showSDoc df . pprIfaceType) unflattened
+
+ -- The recursion in 'unflattened' is crucial - it's what gives us sharing
+ -- between the IfaceType's produced
+ unflattened :: A.Array TypeIndex IfaceType
+ unflattened = fmap (\flatTy -> go (fmap (unflattened A.!) flatTy)) flattened
+
+ -- Unfold an 'HieType' whose subterms have already been unfolded
+ go :: HieType IfaceType -> IfaceType
+ go (HTyVarTy n) = IfaceTyVar (getOccFS n)
+ go (HAppTy a b) = IfaceAppTy a (hieToIfaceArgs b)
+ go (HLitTy l) = IfaceLitTy l
+ go (HForAllTy ((n,k),af) t) = let b = (getOccFS n, k)
+ in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t
+ go (HFunTy a b) = IfaceFunTy a b
+ go (HQualTy con b) = IfaceDFunTy con b
+ go (HCastTy a) = a
+ go HCoercionTy = IfaceTyVar "<coercion type>"
+ go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs)
+
+ -- This isn't fully faithful - we can't produce the 'Inferred' case
+ hieToIfaceArgs :: HieArgs IfaceType -> IfaceAppArgs
+ hieToIfaceArgs (HieArgs args) = go' args
+ where
+ go' [] = IA_Nil
+ go' ((True ,x):xs) = IA_Arg x Required $ go' xs
+ go' ((False,x):xs) = IA_Arg x Specified $ go' xs
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index a84e7e45..119bbc01 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -1,5 +1,7 @@
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
+
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Backends.LaTeX
@@ -22,6 +24,7 @@ import Haddock.GhcUtils
import Pretty hiding (Doc, quote)
import qualified Pretty
+import BasicTypes ( PromotionFlag(..) )
import GHC
import OccName
import Name ( nameOccName )
@@ -135,7 +138,7 @@ ppLaTeXTop doctitle packageStr odir prologue maybe_style ifaces = do
filename = odir </> (fromMaybe "haddock" packageStr <.> "tex")
- writeFile filename (show tex)
+ writeUtf8File filename (show tex)
ppLaTeXModule :: String -> FilePath -> Interface -> IO ()
@@ -168,7 +171,7 @@ ppLaTeXModule _title odir iface = do
body = processExports exports
--
- writeFile (odir </> moduleLaTeXFile mdl) (fullRender PageMode 80 1 txtPrinter "" tex)
+ writeUtf8File (odir </> moduleLaTeXFile mdl) (fullRender PageMode 80 1 txtPrinter "" tex)
-- | Prints out an entry in a module export list.
exportListItem :: ExportItem DocNameI -> LaTeX
@@ -342,7 +345,7 @@ ppFamDecl doc instances decl unicode =
ppFamDeclEqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n
, feqn_rhs = rhs
, feqn_pats = ts } })
- = hsep [ ppAppNameTypes n (map unLoc ts) unicode
+ = hsep [ ppAppNameTypeArgs n ts unicode
, equals
, ppType unicode (unLoc rhs)
]
@@ -908,6 +911,11 @@ ppAppDocNameTyVarBndrs unicode n vs =
ppAppNameTypes :: DocName -> [HsType DocNameI] -> Bool -> LaTeX
ppAppNameTypes n ts unicode = ppTypeApp n ts ppDocName (ppParendType unicode)
+ppAppNameTypeArgs :: DocName -> [LHsTypeArg DocNameI] -> Bool -> LaTeX
+ppAppNameTypeArgs n args@(HsValArg _:HsValArg _:_) unicode
+ = ppTypeApp n args ppDocName (ppLHsTypeArg unicode)
+ppAppNameTypeArgs n args unicode
+ = ppDocName n <+> hsep (map (ppLHsTypeArg unicode) args)
-- | Print an application of a DocName and a list of Names
ppAppDocNameNames :: Bool -> DocName -> [Name] -> LaTeX
@@ -926,7 +934,6 @@ ppTypeApp n (t1:t2:rest) ppDN ppT
ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts)
-
-------------------------------------------------------------------------------
-- * Contexts
-------------------------------------------------------------------------------
@@ -956,7 +963,7 @@ ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode
pp_hs_context :: [HsType DocNameI] -> Bool -> LaTeX
pp_hs_context [] _ = empty
-pp_hs_context [p] unicode = ppType unicode p
+pp_hs_context [p] unicode = ppCtxType unicode p
pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt)
@@ -977,7 +984,7 @@ tupleParens _ = parenList
sumParens :: [LaTeX] -> LaTeX
-sumParens = ubxparens . hsep . punctuate (text " | ")
+sumParens = ubxparens . hsep . punctuate (text " |")
-------------------------------------------------------------------------------
@@ -991,11 +998,17 @@ ppLType unicode y = ppType unicode (unLoc y)
ppLParendType unicode y = ppParendType unicode (unLoc y)
ppLFunLhType unicode y = ppFunLhType unicode (unLoc y)
-
-ppType, ppParendType, ppFunLhType :: Bool -> HsType DocNameI -> LaTeX
+ppType, ppParendType, ppFunLhType, ppCtxType :: Bool -> HsType DocNameI -> LaTeX
ppType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode
ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode
ppFunLhType unicode ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode
+ppCtxType unicode ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode
+
+ppLHsTypeArg :: Bool -> LHsTypeArg DocNameI -> LaTeX
+ppLHsTypeArg unicode (HsValArg ty) = ppLParendType unicode ty
+ppLHsTypeArg unicode (HsTypeArg ki) = atSign unicode <>
+ ppLParendType unicode ki
+ppLHsTypeArg _ (HsArgPar _) = text ""
ppHsTyVarBndr :: Bool -> HsTyVarBndr DocNameI -> LaTeX
ppHsTyVarBndr _ (UserTyVar _ (L _ name)) = ppDocName name
@@ -1034,27 +1047,30 @@ ppr_mono_ty (HsFunTy _ ty1 ty2) u
ppr_mono_ty (HsBangTy _ b ty) u = ppBang b <> ppLParendType u ty
ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name
-ppr_mono_ty (HsTyVar _ Promoted (L _ name)) _ = char '\'' <> ppDocName name
+ppr_mono_ty (HsTyVar _ IsPromoted (L _ name)) _ = char '\'' <> ppDocName name
ppr_mono_ty (HsTupleTy _ con tys) u = tupleParens con (map (ppLType u) tys)
ppr_mono_ty (HsSumTy _ tys) u = sumParens (map (ppLType u) tys)
-ppr_mono_ty (HsKindSig _ ty kind) u = parens (ppr_mono_lty ty u <+> dcolon u <+> ppLKind u kind)
+ppr_mono_ty (HsKindSig _ ty kind) u = ppr_mono_lty ty u <+> dcolon u <+> ppLKind u kind
ppr_mono_ty (HsListTy _ ty) u = brackets (ppr_mono_lty ty u)
-ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty ty u)
+ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u
ppr_mono_ty (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy"
ppr_mono_ty (HsRecTy {}) _ = text "{..}"
ppr_mono_ty (XHsType (NHsCoreTy {})) _ = error "ppr_mono_ty HsCoreTy"
-ppr_mono_ty (HsExplicitListTy _ Promoted tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys
+ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys
ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys
ppr_mono_ty (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys
ppr_mono_ty (HsAppTy _ fun_ty arg_ty) unicode
= hsep [ppr_mono_lty fun_ty unicode, ppr_mono_lty arg_ty unicode]
+ppr_mono_ty (HsAppKindTy _ fun_ty arg_ki) unicode
+ = hsep [ppr_mono_lty fun_ty unicode, atSign unicode <> ppr_mono_lty arg_ki unicode]
+
ppr_mono_ty (HsOpTy _ ty1 op ty2) unicode
= ppr_mono_lty ty1 unicode <+> ppr_op <+> ppr_mono_lty ty2 unicode
where
- ppr_op = if not (isSymOcc occName) then char '`' <> ppLDocName op <> char '`' else ppLDocName op
- occName = nameOccName . getName . unLoc $ op
+ ppr_op | isSymOcc (getOccName op) = ppLDocName op
+ | otherwise = char '`' <> ppLDocName op <> char '`'
ppr_mono_ty (HsParTy _ ty) unicode
= parens (ppr_mono_lty ty unicode)
@@ -1063,7 +1079,7 @@ ppr_mono_ty (HsParTy _ ty) unicode
ppr_mono_ty (HsDocTy _ ty _) unicode
= ppr_mono_lty ty unicode
-ppr_mono_ty (HsWildCardTy (AnonWildCard _)) _ = text "\\_"
+ppr_mono_ty (HsWildCardTy _) _ = text "\\_"
ppr_mono_ty (HsTyLit _ t) u = ppr_tylit t u
ppr_mono_ty (HsStarTy _ isUni) unicode = starSymbol (isUni || unicode)
@@ -1083,16 +1099,13 @@ ppr_tylit (HsStrTy _ s) _ = text (show s)
ppBinder :: OccName -> LaTeX
ppBinder n
- | isInfixName n = parens $ ppOccName n
- | otherwise = ppOccName n
+ | isSymOcc n = parens $ ppOccName n
+ | otherwise = ppOccName n
ppBinderInfix :: OccName -> LaTeX
ppBinderInfix n
- | isInfixName n = ppOccName n
- | otherwise = cat [ char '`', ppOccName n, char '`' ]
-
-isInfixName :: OccName -> Bool
-isInfixName n = isVarSym n || isConSym n
+ | isSymOcc n = ppOccName n
+ | otherwise = cat [ char '`', ppOccName n, char '`' ]
ppSymName :: Name -> LaTeX
ppSymName name
@@ -1100,22 +1113,21 @@ ppSymName name
| otherwise = ppName name
-ppVerbOccName :: OccName -> LaTeX
-ppVerbOccName = text . latexFilter . occNameString
+ppVerbOccName :: Wrap OccName -> LaTeX
+ppVerbOccName = text . latexFilter . showWrapped occNameString
ppIPName :: HsIPName -> LaTeX
-ppIPName ip = text $ unpackFS $ hsIPNameFS ip
+ppIPName = text . ('?':) . unpackFS . hsIPNameFS
ppOccName :: OccName -> LaTeX
ppOccName = text . occNameString
-
-ppVerbDocName :: DocName -> LaTeX
-ppVerbDocName = ppVerbOccName . nameOccName . getName
+ppVerbDocName :: Wrap DocName -> LaTeX
+ppVerbDocName = text . latexFilter . showWrapped (occNameString . nameOccName . getName)
-ppVerbRdrName :: RdrName -> LaTeX
-ppVerbRdrName = ppVerbOccName . rdrNameOcc
+ppVerbRdrName :: Wrap RdrName -> LaTeX
+ppVerbRdrName = text . latexFilter . showWrapped (occNameString . rdrNameOcc)
ppDocName :: DocName -> LaTeX
@@ -1176,7 +1188,7 @@ parLatexMarkup ppId = Markup {
markupString = \s v -> text (fixString v s),
markupAppend = \l r v -> l v <> r v,
markupIdentifier = markupId ppId,
- markupIdentifierUnchecked = markupId (ppVerbOccName . snd),
+ markupIdentifierUnchecked = markupId (ppVerbOccName . fmap snd),
markupModule = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl),
markupWarning = \p v -> emph (p v),
markupEmphasis = \p v -> emph (p v),
@@ -1189,7 +1201,7 @@ parLatexMarkup ppId = Markup {
markupOrderedList = \p v -> enumeratedList (map ($v) p) $$ text "",
markupDefList = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l),
markupCodeBlock = \p _ -> quote (verb (p Verb)) $$ text "",
- markupHyperlink = \l _ -> markupLink l,
+ markupHyperlink = \(Hyperlink u l) p -> markupLink u (fmap ($p) l),
markupAName = \_ _ -> empty,
markupProperty = \p _ -> quote $ verb $ text p,
markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e,
@@ -1209,8 +1221,8 @@ parLatexMarkup ppId = Markup {
fixString Verb s = s
fixString Mono s = latexMonoFilter s
- markupLink (Hyperlink url mLabel) = case mLabel of
- Just label -> text "\\href" <> braces (text url) <> braces (text label)
+ markupLink url mLabel = case mLabel of
+ Just label -> text "\\href" <> braces (text url) <> braces label
Nothing -> text "\\url" <> braces (text url)
-- Is there a better way of doing this? Just a space is an aribtrary choice.
@@ -1233,11 +1245,11 @@ parLatexMarkup ppId = Markup {
where theid = ppId_ id
-latexMarkup :: DocMarkup DocName (StringContext -> LaTeX)
+latexMarkup :: DocMarkup (Wrap DocName) (StringContext -> LaTeX)
latexMarkup = parLatexMarkup ppVerbDocName
-rdrLatexMarkup :: DocMarkup RdrName (StringContext -> LaTeX)
+rdrLatexMarkup :: DocMarkup (Wrap RdrName) (StringContext -> LaTeX)
rdrLatexMarkup = parLatexMarkup ppVerbRdrName
@@ -1322,12 +1334,13 @@ quote :: LaTeX -> LaTeX
quote doc = text "\\begin{quote}" $$ doc $$ text "\\end{quote}"
-dcolon, arrow, darrow, forallSymbol, starSymbol :: Bool -> LaTeX
+dcolon, arrow, darrow, forallSymbol, starSymbol, atSign :: Bool -> LaTeX
dcolon unicode = text (if unicode then "∷" else "::")
arrow unicode = text (if unicode then "→" else "->")
darrow unicode = text (if unicode then "⇒" else "=>")
forallSymbol unicode = text (if unicode then "∀" else "forall")
starSymbol unicode = text (if unicode then "★" else "*")
+atSign unicode = text (if unicode then "@" else "@")
dot :: LaTeX
dot = char '.'
@@ -1342,7 +1355,7 @@ ubxParenList = ubxparens . hsep . punctuate comma
ubxparens :: LaTeX -> LaTeX
-ubxparens h = text "(#" <> h <> text "#)"
+ubxparens h = text "(#" <+> h <+> text "#)"
nl :: LaTeX
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 46d94b37..9add4cae 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -39,7 +39,7 @@ import Haddock.GhcUtils
import Control.Monad ( when, unless )
import qualified Data.ByteString.Builder as Builder
import Data.Char ( toUpper, isSpace )
-import Data.List ( sortBy, isPrefixOf, intercalate, intersperse )
+import Data.List ( sortBy, isPrefixOf, intersperse )
import Data.Maybe
import System.Directory
import System.FilePath hiding ( (</>) )
@@ -293,7 +293,7 @@ ppHtmlContents dflags odir doctitle _maybe_package
ppModuleTree pkg qual tree
]
createDirectoryIfMissing True odir
- writeFile (joinPath [odir, contentsHtmlFile]) (renderToString debug html)
+ writeUtf8File (joinPath [odir, contentsHtmlFile]) (renderToString debug html)
ppPrologue :: Maybe Package -> Qualification -> String -> Maybe (MDoc GHC.RdrName) -> Html
@@ -388,7 +388,7 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces = d
| Just item_html <- processExport True links_info unicode pkg qual item
= [ Object
[ "display_html" .= String (showHtmlFragment item_html)
- , "name" .= String (intercalate " " (map nameString names))
+ , "name" .= String (unwords (map getOccString names))
, "module" .= String (moduleString mdl)
, "link" .= String (fromMaybe "" (listToMaybe (map (nameLink mdl) names)))
]
@@ -397,18 +397,15 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces = d
where
names = exportName item ++ exportSubs item
- exportSubs :: ExportItem name -> [IdP name]
+ exportSubs :: ExportItem DocNameI -> [IdP DocNameI]
exportSubs ExportDecl { expItemSubDocs } = map fst expItemSubDocs
exportSubs _ = []
- exportName :: ExportItem name -> [IdP name]
+ exportName :: ExportItem DocNameI -> [IdP DocNameI]
exportName ExportDecl { expItemDecl } = getMainDeclBinder (unLoc expItemDecl)
exportName ExportNoDecl { expItemName } = [expItemName]
exportName _ = []
- nameString :: NamedThing name => name -> String
- nameString = occNameString . nameOccName . getName
-
nameLink :: NamedThing name => Module -> name -> String
nameLink mdl = moduleNameUrl' (moduleName mdl) . nameOccName . getName
@@ -436,9 +433,9 @@ ppHtmlIndex odir doctitle _maybe_package themes
mapM_ (do_sub_index index) initialChars
-- Let's add a single large index as well for those who don't know exactly what they're looking for:
let mergedhtml = indexPage False Nothing index
- writeFile (joinPath [odir, subIndexHtmlFile merged_name]) (renderToString debug mergedhtml)
+ writeUtf8File (joinPath [odir, subIndexHtmlFile merged_name]) (renderToString debug mergedhtml)
- writeFile (joinPath [odir, indexHtmlFile]) (renderToString debug html)
+ writeUtf8File (joinPath [odir, indexHtmlFile]) (renderToString debug html)
where
indexPage showLetters ch items =
@@ -479,7 +476,7 @@ ppHtmlIndex odir doctitle _maybe_package themes
do_sub_index this_ix c
= unless (null index_part) $
- writeFile (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html)
+ writeUtf8File (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html)
where
html = indexPage True (Just c) index_part
index_part = [(n,stuff) | (n,stuff) <- this_ix, toUpper (head n) == c]
@@ -573,7 +570,7 @@ ppHtmlModule odir doctitle themes
]
createDirectoryIfMissing True odir
- writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html)
+ writeUtf8File (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html)
signatureDocURL :: String
signatureDocURL = "https://wiki.haskell.org/Module_signature"
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index bc6e2c2b..f2cab635 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -1,6 +1,8 @@
{-# LANGUAGE TransformListComp #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE TypeFamilies #-}
+
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Backends.Html.Decl
@@ -32,6 +34,7 @@ import qualified Data.Map as Map
import Data.Maybe
import Text.XHtml hiding ( name, title, p, quote )
+import BasicTypes (PromotionFlag(..), isPromoted)
import GHC hiding (LexicalFixity(..))
import GHC.Exts
import Name
@@ -297,7 +300,7 @@ ppFamDecl summary associated links instances fixities loc doc decl splice unicod
ppFamDeclEqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n
, feqn_rhs = rhs
, feqn_pats = ts } })
- = ( ppAppNameTypes n (map unLoc ts) unicode qual
+ = ( ppAppNameTypeArgs n ts unicode qual
<+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs)
, Nothing
, []
@@ -400,6 +403,11 @@ ppAppNameTypes :: DocName -> [HsType DocNameI] -> Unicode -> Qualification -> Ht
ppAppNameTypes n ts unicode qual =
ppTypeApp n ts (\p -> ppDocName qual p True) (ppParendType unicode qual HideEmptyContexts)
+ppAppNameTypeArgs :: DocName -> [LHsTypeArg DocNameI] -> Unicode -> Qualification -> Html
+ppAppNameTypeArgs n args@(HsValArg _:HsValArg _:_) u q
+ = ppTypeApp n args (\p -> ppDocName q p True) (ppLHsTypeArg u q HideEmptyContexts)
+ppAppNameTypeArgs n args u q
+ = (ppDocName q Prefix True n) <+> hsep (map (ppLHsTypeArg u q HideEmptyContexts) args)
-- | General printing of type applications
ppTypeApp :: DocName -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html
@@ -412,7 +420,6 @@ ppTypeApp n (t1:t2:rest) ppDN ppT
ppTypeApp n ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT ts)
-
-------------------------------------------------------------------------------
-- * Contexts
-------------------------------------------------------------------------------
@@ -678,7 +685,7 @@ instanceId origin no orphan ihd = concat $
[ "o:" | orphan ] ++
[ qual origin
, ":" ++ getOccString origin
- , ":" ++ (occNameString . getOccName . ihdClsName) ihd
+ , ":" ++ getOccString (ihdClsName ihd)
, ":" ++ show no
]
where
@@ -1083,6 +1090,11 @@ ppType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_TOP
ppParendType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_CON ty) unicode qual emptyCtxts
ppFunLhType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode qual emptyCtxts
+ppLHsTypeArg :: Unicode -> Qualification -> HideEmptyContexts -> LHsTypeArg DocNameI -> Html
+ppLHsTypeArg unicode qual emptyCtxts (HsValArg ty) = ppLParendType unicode qual emptyCtxts ty
+ppLHsTypeArg unicode qual emptyCtxts (HsTypeArg ki) = atSign unicode <>
+ ppLParendType unicode qual emptyCtxts ki
+ppLHsTypeArg _ _ _ (HsArgPar _) = toHtml ""
ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocNameI -> Html
ppHsTyVarBndr _ qual (UserTyVar _ (L _ name)) =
ppDocName qual Raw False name
@@ -1143,8 +1155,9 @@ ppr_mono_ty (HsTyVar _ _ (L _ name)) True _ _
ppr_mono_ty (HsBangTy _ b ty) u q _ =
ppBang b +++ ppLParendType u q HideEmptyContexts ty
-ppr_mono_ty (HsTyVar _ _ (L _ name)) _ q _ =
- ppDocName q Prefix True name
+ppr_mono_ty (HsTyVar _ prom (L _ name)) _ q _
+ | isPromoted prom = promoQuote (ppDocName q Prefix True name)
+ | otherwise = ppDocName q Prefix True name
ppr_mono_ty (HsStarTy _ isUni) u _ _ =
toHtml (if u || isUni then "★" else "*")
ppr_mono_ty (HsFunTy _ ty1 ty2) u q e =
@@ -1156,7 +1169,7 @@ ppr_mono_ty (HsTupleTy _ con tys) u q _ =
ppr_mono_ty (HsSumTy _ tys) u q _ =
sumParens (map (ppLType u q HideEmptyContexts) tys)
ppr_mono_ty (HsKindSig _ ty kind) u q e =
- parens (ppr_mono_lty ty u q e <+> dcolon u <+> ppLKind u q kind)
+ ppr_mono_lty ty u q e <+> dcolon u <+> ppLKind u q kind
ppr_mono_ty (HsListTy _ ty) u q _ = brackets (ppr_mono_lty ty u q HideEmptyContexts)
ppr_mono_ty (HsIParamTy _ (L _ n) ty) u q _ =
ppIPName n <+> dcolon u <+> ppr_mono_lty ty u q HideEmptyContexts
@@ -1166,7 +1179,7 @@ ppr_mono_ty (HsRecTy {}) _ _ _ = toHtml "{..}"
-- placeholder in the signature, which is followed by the field
-- declarations.
ppr_mono_ty (XHsType (NHsCoreTy {})) _ _ _ = error "ppr_mono_ty HsCoreTy"
-ppr_mono_ty (HsExplicitListTy _ Promoted tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
+ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
ppr_mono_ty (HsExplicitTupleTy _ tys) u q _ = promoQuote $ parenList $ map (ppLType u q HideEmptyContexts) tys
@@ -1174,6 +1187,10 @@ ppr_mono_ty (HsAppTy _ fun_ty arg_ty) unicode qual _
= hsep [ ppr_mono_lty fun_ty unicode qual HideEmptyContexts
, ppr_mono_lty arg_ty unicode qual HideEmptyContexts ]
+ppr_mono_ty (HsAppKindTy _ fun_ty arg_ki) unicode qual _
+ = hsep [ppr_mono_lty fun_ty unicode qual HideEmptyContexts
+ , atSign unicode <> ppr_mono_lty arg_ki unicode qual HideEmptyContexts]
+
ppr_mono_ty (HsOpTy _ ty1 op ty2) unicode qual _
= ppr_mono_lty ty1 unicode qual HideEmptyContexts <+> ppr_op <+> ppr_mono_lty ty2 unicode qual HideEmptyContexts
where
@@ -1191,10 +1208,9 @@ ppr_mono_ty (HsParTy _ ty) unicode qual emptyCtxts
ppr_mono_ty (HsDocTy _ ty _) unicode qual emptyCtxts
= ppr_mono_lty ty unicode qual emptyCtxts
-ppr_mono_ty (HsWildCardTy (AnonWildCard _)) _ _ _ = char '_'
+ppr_mono_ty (HsWildCardTy _) _ _ _ = char '_'
ppr_mono_ty (HsTyLit _ n) _ _ _ = ppr_tylit n
ppr_tylit :: HsTyLit -> Html
ppr_tylit (HsNumTy _ n) = toHtml (show n)
ppr_tylit (HsStrTy _ s) = toHtml (show s)
-
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
index 38aa7b7e..1901cf05 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -62,8 +62,8 @@ parHtmlMarkup qual insertAnchors ppId = Markup {
markupHyperlink = \(Hyperlink url mLabel)
-> if insertAnchors
then anchor ! [href url]
- << fromMaybe url mLabel
- else toHtml $ fromMaybe url mLabel,
+ << fromMaybe (toHtml url) mLabel
+ else fromMaybe (toHtml url) mLabel,
markupAName = \aname
-> if insertAnchors
then namedAnchor aname << ""
@@ -171,12 +171,12 @@ flatten x = [x]
-- extract/append the underlying 'Doc' and convert it to 'Html'. For
-- 'CollapsingHeader', we attach extra info to the generated 'Html'
-- that allows us to expand/collapse the content.
-hackMarkup :: DocMarkup id Html -> Maybe Package -> Hack (ModuleName, OccName) id -> Html
+hackMarkup :: DocMarkup id Html -> Maybe Package -> Hack (Wrap (ModuleName, OccName)) id -> Html
hackMarkup fmt' currPkg h' =
let (html, ms) = hackMarkup' fmt' h'
in html +++ renderMeta fmt' currPkg (metaConcat ms)
where
- hackMarkup' :: DocMarkup id Html -> Hack (ModuleName, OccName) id
+ hackMarkup' :: DocMarkup id Html -> Hack (Wrap (ModuleName, OccName)) id
-> (Html, [Meta])
hackMarkup' fmt h = case h of
UntouchedDoc d -> (markup fmt $ _doc d, [_meta d])
@@ -206,7 +206,7 @@ renderMeta _ _ _ = noHtml
-- | Goes through 'hackMarkup' to generate the 'Html' rather than
-- skipping straight to 'markup': this allows us to employ XHtml
-- specific hacks to the tree first.
-markupHacked :: DocMarkup id Html
+markupHacked :: DocMarkup (Wrap id) Html
-> Maybe Package -- this package
-> Maybe String
-> MDoc id
@@ -220,7 +220,7 @@ docToHtml :: Maybe String -- ^ Name of the thing this doc is for. See
-> Maybe Package -- ^ Current package
-> Qualification -> MDoc DocName -> Html
docToHtml n pkg qual = markupHacked fmt pkg n . cleanup
- where fmt = parHtmlMarkup qual True (ppDocName qual Raw)
+ where fmt = parHtmlMarkup qual True (ppWrappedDocName qual Raw)
-- | Same as 'docToHtml' but it doesn't insert the 'anchor' element
-- in links. This is used to generate the Contents box elements.
@@ -228,16 +228,16 @@ docToHtmlNoAnchors :: Maybe String -- ^ See 'toHack'
-> Maybe Package -- ^ Current package
-> Qualification -> MDoc DocName -> Html
docToHtmlNoAnchors n pkg qual = markupHacked fmt pkg n . cleanup
- where fmt = parHtmlMarkup qual False (ppDocName qual Raw)
+ where fmt = parHtmlMarkup qual False (ppWrappedDocName qual Raw)
origDocToHtml :: Maybe Package -> Qualification -> MDoc Name -> Html
origDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup
- where fmt = parHtmlMarkup qual True (const $ ppName Raw)
+ where fmt = parHtmlMarkup qual True (const (ppWrappedName Raw))
rdrDocToHtml :: Maybe Package -> Qualification -> MDoc RdrName -> Html
rdrDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup
- where fmt = parHtmlMarkup qual True (const ppRdrName)
+ where fmt = parHtmlMarkup qual True (const (ppRdrName . unwrap))
docElement :: (Html -> Html) -> Html -> Html
@@ -273,7 +273,7 @@ cleanup = overDoc (markup fmtUnParagraphLists)
unParagraph (DocParagraph d) = d
unParagraph doc = doc
- fmtUnParagraphLists :: DocMarkup a (Doc a)
+ fmtUnParagraphLists :: DocMarkup (Wrap a) (Doc a)
fmtUnParagraphLists = idMarkup {
markupUnorderedList = DocUnorderedList . map unParagraph,
markupOrderedList = DocOrderedList . map unParagraph
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
index 574045e0..6a047747 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
@@ -13,7 +13,8 @@
module Haddock.Backends.Xhtml.Names (
ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink,
ppBinder, ppBinderInfix, ppBinder',
- ppModule, ppModuleRef, ppIPName, linkId, Notation(..)
+ ppModule, ppModuleRef, ppIPName, linkId, Notation(..),
+ ppWrappedDocName, ppWrappedName,
) where
@@ -24,7 +25,7 @@ import Haddock.Utils
import Text.XHtml hiding ( name, p, quote )
import qualified Data.Map as M
-import qualified Data.List as List
+import Data.List ( stripPrefix )
import GHC hiding (LexicalFixity(..))
import Name
@@ -49,9 +50,11 @@ ppIPName :: HsIPName -> Html
ppIPName = toHtml . ('?':) . unpackFS . hsIPNameFS
-ppUncheckedLink :: Qualification -> (ModuleName, OccName) -> Html
-ppUncheckedLink _ (mdl, occ) = linkIdOcc' mdl (Just occ) << ppOccName occ -- TODO: apply ppQualifyName
-
+ppUncheckedLink :: Qualification -> Wrap (ModuleName, OccName) -> Html
+ppUncheckedLink _ x = linkIdOcc' mdl (Just occ) << occHtml
+ where
+ (mdl, occ) = unwrap x
+ occHtml = toHtml (showWrapped (occNameString . snd) x) -- TODO: apply ppQualifyName
-- The Bool indicates if it is to be rendered in infix notation
ppLDocName :: Qualification -> Notation -> Located DocName -> Html
@@ -68,6 +71,19 @@ ppDocName qual notation insertAnchors docName =
ppQualifyName qual notation name (nameModule name)
| otherwise -> ppName notation name
+
+ppWrappedDocName :: Qualification -> Notation -> Bool -> Wrap DocName -> Html
+ppWrappedDocName qual notation insertAnchors docName = case docName of
+ Unadorned n -> ppDocName qual notation insertAnchors n
+ Parenthesized n -> ppDocName qual Prefix insertAnchors n
+ Backticked n -> ppDocName qual Infix insertAnchors n
+
+ppWrappedName :: Notation -> Wrap Name -> Html
+ppWrappedName notation docName = case docName of
+ Unadorned n -> ppName notation n
+ Parenthesized n -> ppName Prefix n
+ Backticked n -> ppName Infix n
+
-- | Render a name depending on the selected qualification mode
ppQualifyName :: Qualification -> Notation -> Name -> Module -> Html
ppQualifyName qual notation name mdl =
@@ -79,7 +95,7 @@ ppQualifyName qual notation name mdl =
then ppName notation name
else ppFullQualName notation mdl name
RelativeQual localmdl ->
- case List.stripPrefix (moduleString localmdl) (moduleString mdl) of
+ case stripPrefix (moduleString localmdl) (moduleString mdl) of
-- local, A.x -> x
Just [] -> ppName notation name
-- sub-module, A.B.x -> B.x
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
index 7fbaec6d..c3acb6df 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
@@ -22,6 +22,7 @@ module Haddock.Backends.Xhtml.Utils (
braces, brackets, pabrackets, parens, parenList, ubxParenList, ubxSumList,
arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote, promoQuote,
+ atSign,
hsep, vcat,
@@ -183,15 +184,15 @@ ubxSumList = ubxparens . hsep . punctuate (toHtml " | ")
ubxparens :: Html -> Html
-ubxparens h = toHtml "(#" +++ h +++ toHtml "#)"
+ubxparens h = toHtml "(#" <+> h <+> toHtml "#)"
-dcolon, arrow, darrow, forallSymbol :: Bool -> Html
+dcolon, arrow, darrow, forallSymbol, atSign :: Bool -> Html
dcolon unicode = toHtml (if unicode then "∷" else "::")
arrow unicode = toHtml (if unicode then "→" else "->")
darrow unicode = toHtml (if unicode then "⇒" else "=>")
forallSymbol unicode = if unicode then toHtml "∀" else keyword "forall"
-
+atSign unicode = toHtml (if unicode then "@" else "@")
dot :: Html
dot = toHtml "."
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 7735ed0d..d22efc9a 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -12,12 +12,16 @@
-- Conversion between TyThing and HsDecl. This functionality may be moved into
-- GHC at some point.
-----------------------------------------------------------------------------
-module Haddock.Convert where
--- Some other functions turned out to be useful for converting
--- instance heads, which aren't TyThings, so just export everything.
+module Haddock.Convert (
+ tyThingToLHsDecl,
+ synifyInstHead,
+ synifyFamInst,
+ PrintRuntimeReps(..),
+) where
import Bag ( emptyBag )
-import BasicTypes ( TupleSort(..), SourceText(..), LexicalFixity(..) )
+import BasicTypes ( TupleSort(..), SourceText(..), LexicalFixity(..)
+ , PromotionFlag(..), DefMethSpec(..) )
import Class
import CoAxiom
import ConLike
@@ -36,9 +40,10 @@ import TyCon
import Type
import TyCoRep
import TysPrim ( alphaTyVars )
-import TysWiredIn ( listTyConName, liftedTypeKindTyConName, unitTy )
-import PrelNames ( hasKey, eqTyConKey, eqTyConName, ipClassKey
- , tYPETyConKey, liftedRepDataConKey )
+import TysWiredIn ( eqTyConName, listTyConName, liftedTypeKindTyConName
+ , unitTy, promotedNilDataCon, promotedConsDataCon )
+import PrelNames ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey
+ , liftedRepDataConKey )
import Unique ( getUnique )
import Util ( chkAppend, compareLength, dropList, filterByList, filterOut
, splitAtList )
@@ -47,12 +52,22 @@ import VarSet
import Haddock.Types
import Haddock.Interface.Specialize
+import Haddock.GhcUtils ( orderedFVs, defaultRuntimeRepVars )
+import Data.Maybe ( catMaybes, maybeToList )
+-- | Whether or not to default 'RuntimeRep' variables to 'LiftedRep'. Check
+-- out Note [Defaulting RuntimeRep variables] in IfaceType.hs for the
+-- motivation.
+data PrintRuntimeReps = ShowRuntimeRep | HideRuntimeRep deriving Show
+
-- the main function here! yay!
-tyThingToLHsDecl :: TyThing -> Either ErrMsg ([ErrMsg], (HsDecl GhcRn))
-tyThingToLHsDecl t = case t of
+tyThingToLHsDecl
+ :: PrintRuntimeReps
+ -> TyThing
+ -> Either ErrMsg ([ErrMsg], (HsDecl GhcRn))
+tyThingToLHsDecl prr t = case t of
-- ids (functions and zero-argument a.k.a. CAFs) get a type signature.
-- Including built-in functions like seq.
-- foreign-imported functions could be represented with ForD
@@ -61,40 +76,60 @@ tyThingToLHsDecl t = case t of
-- in a future code version we could turn idVarDetails = foreign-call
-- into a ForD instead of a SigD if we wanted. Haddock doesn't
-- need to care.
- AnId i -> allOK $ SigD noExt (synifyIdSig ImplicitizeForAll i)
+ AnId i -> allOK $ SigD noExt (synifyIdSig prr ImplicitizeForAll [] i)
-- type-constructors (e.g. Maybe) are complicated, put the definition
-- later in the file (also it's used for class associated-types too.)
ATyCon tc
| Just cl <- tyConClass_maybe tc -- classes are just a little tedious
- -> let extractFamilyDecl :: TyClDecl a -> Either ErrMsg (LFamilyDecl a)
- extractFamilyDecl (FamDecl _ d) = return $ noLoc d
+ -> let extractFamilyDecl :: TyClDecl a -> Either ErrMsg (FamilyDecl a)
+ extractFamilyDecl (FamDecl _ d) = return d
extractFamilyDecl _ =
Left "tyThingToLHsDecl: impossible associated tycon"
- atTyClDecls = [synifyTyCon Nothing at_tc | ATI at_tc _ <- classATItems cl]
- atFamDecls = map extractFamilyDecl (rights atTyClDecls)
- tyClErrors = lefts atTyClDecls
- famDeclErrors = lefts atFamDecls
- in withErrs (tyClErrors ++ famDeclErrors) . TyClD noExt $ ClassDecl
+ extractFamDefDecl :: FamilyDecl GhcRn -> Type -> TyFamDefltEqn GhcRn
+ extractFamDefDecl fd rhs = FamEqn
+ { feqn_ext = noExt
+ , feqn_tycon = fdLName fd
+ , feqn_bndrs = Nothing
+ -- TODO: this must change eventually
+ , feqn_pats = fdTyVars fd
+ , feqn_fixity = fdFixity fd
+ , feqn_rhs = synifyType WithinType [] rhs }
+
+ extractAtItem
+ :: ClassATItem
+ -> Either ErrMsg (LFamilyDecl GhcRn, Maybe (LTyFamDefltEqn GhcRn))
+ extractAtItem (ATI at_tc def) = do
+ tyDecl <- synifyTyCon prr Nothing at_tc
+ famDecl <- extractFamilyDecl tyDecl
+ let defEqnTy = fmap (noLoc . extractFamDefDecl famDecl . fst) def
+ pure (noLoc famDecl, defEqnTy)
+
+ atTyClDecls = map extractAtItem (classATItems cl)
+ (atFamDecls, atDefFamDecls) = unzip (rights atTyClDecls)
+ vs = tyConVisibleTyVars (classTyCon cl)
+
+ in withErrs (lefts atTyClDecls) . TyClD noExt $ ClassDecl
{ tcdCtxt = synifyCtx (classSCTheta cl)
, tcdLName = synifyName cl
- , tcdTyVars = synifyTyVars (tyConVisibleTyVars (classTyCon cl))
- , tcdFixity = Prefix
+ , tcdTyVars = synifyTyVars vs
+ , tcdFixity = synifyFixity cl
, tcdFDs = map (\ (l,r) -> noLoc
(map (noLoc . getName) l, map (noLoc . getName) r) ) $
snd $ classTvsFds cl
, tcdSigs = noLoc (MinimalSig noExt NoSourceText . noLoc . fmap noLoc $ classMinimalDef cl) :
- map (noLoc . synifyTcIdSig DeleteTopLevelQuantification)
- (classMethods cl)
+ [ noLoc tcdSig
+ | clsOp <- classOpItems cl
+ , tcdSig <- synifyTcIdSig vs clsOp ]
, tcdMeths = emptyBag --ignore default method definitions, they don't affect signature
-- class associated-types are a subset of TyCon:
- , tcdATs = rights atFamDecls
- , tcdATDefs = [] --ignore associated type defaults
+ , tcdATs = atFamDecls
+ , tcdATDefs = catMaybes atDefFamDecls
, tcdDocs = [] --we don't have any docs at this point
, tcdCExt = placeHolderNamesTc }
| otherwise
- -> synifyTyCon Nothing tc >>= allOK . TyClD noExt
+ -> synifyTyCon prr Nothing tc >>= allOK . TyClD noExt
-- type-constructors (e.g. Maybe) are complicated, put the definition
-- later in the file (also it's used for class associated-types too.)
@@ -102,7 +137,7 @@ tyThingToLHsDecl t = case t of
-- a data-constructor alone just gets rendered as a function:
AConLike (RealDataCon dc) -> allOK $ SigD noExt (TypeSig noExt [synifyName dc]
- (synifySigWcType ImplicitizeForAll (dataConUserType dc)))
+ (synifySigWcType ImplicitizeForAll [] (dataConUserType dc)))
AConLike (PatSynCon ps) ->
allOK . SigD noExt $ PatSynSig noExt [synifyName ps] (synifyPatSynSigType ps)
@@ -114,16 +149,17 @@ synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn GhcRn
synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
= let name = synifyName tc
args_types_only = filterOutInvisibleTypes tc args
- typats = map (synifyType WithinType) args_types_only
+ typats = map (synifyType WithinType []) args_types_only
annot_typats = zipWith3 annotHsType (mkIsPolyTvs fam_tvs)
args_types_only typats
- hs_rhs = synifyType WithinType rhs
- in HsIB { hsib_ext = HsIBRn { hsib_vars = map tyVarName tkvs
- , hsib_closed = True }
+ hs_rhs = synifyType WithinType [] rhs
+ in HsIB { hsib_ext = map tyVarName tkvs
, hsib_body = FamEqn { feqn_ext = noExt
, feqn_tycon = name
- , feqn_pats = annot_typats
- , feqn_fixity = Prefix
+ , feqn_bndrs = Nothing
+ -- TODO: this must change eventually
+ , feqn_pats = map HsValArg annot_typats
+ , feqn_fixity = synifyFixity name
, feqn_rhs = hs_rhs } }
where
fam_tvs = tyConVisibleTyVars tc
@@ -138,42 +174,51 @@ synifyAxiom ax@(CoAxiom { co_ax_tc = tc })
| Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc
, getUnique ax' == getUnique ax -- without the getUniques, type error
- = synifyTyCon (Just ax) tc >>= return . TyClD noExt
+ = synifyTyCon ShowRuntimeRep (Just ax) tc >>= return . TyClD noExt
| otherwise
= Left "synifyAxiom: closed/open family confusion"
--- | Turn type constructors into type class declarations
-synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> Either ErrMsg (TyClDecl GhcRn)
-synifyTyCon _coax tc
+-- | Turn type constructors into data declarations, type families, or type synonyms
+synifyTyCon
+ :: PrintRuntimeReps
+ -> Maybe (CoAxiom br) -- ^ RHS of type synonym
+ -> TyCon -- ^ type constructor to convert
+ -> Either ErrMsg (TyClDecl GhcRn)
+synifyTyCon prr _coax tc
| isFunTyCon tc || isPrimTyCon tc
= return $
DataDecl { tcdLName = synifyName tc
- , tcdTyVars = -- tyConTyVars doesn't work on fun/prim, but we can make them up:
- let mk_hs_tv realKind fakeTyVar
- = noLoc $ KindedTyVar noExt (noLoc (getName fakeTyVar))
- (synifyKindSig realKind)
- in HsQTvs { hsq_ext =
+ , tcdTyVars = HsQTvs { hsq_ext =
HsQTvsRn { hsq_implicit = [] -- No kind polymorphism
, hsq_dependent = emptyNameSet }
- , hsq_explicit = zipWith mk_hs_tv (fst (splitFunTys (tyConKind tc)))
- alphaTyVars --a, b, c... which are unfortunately all kind *
+ , hsq_explicit = zipWith mk_hs_tv
+ tyVarKinds
+ alphaTyVars --a, b, c... which are unfortunately all kind *
}
- , tcdFixity = Prefix
+ , tcdFixity = synifyFixity tc
, tcdDataDefn = HsDataDefn { dd_ext = noExt
, dd_ND = DataType -- arbitrary lie, they are neither
-- algebraic data nor newtype:
, dd_ctxt = noLoc []
, dd_cType = Nothing
- , dd_kindSig = Just (synifyKindSig (tyConKind tc))
+ , dd_kindSig = synifyDataTyConReturnKind tc
-- we have their kind accurately:
, dd_cons = [] -- No constructors
, dd_derivs = noLoc [] }
, tcdDExt = DataDeclRn False placeHolderNamesTc }
+ where
+ -- tyConTyVars doesn't work on fun/prim, but we can make them up:
+ mk_hs_tv realKind fakeTyVar
+ | isLiftedTypeKind realKind = noLoc $ UserTyVar noExt (noLoc (getName fakeTyVar))
+ | otherwise = noLoc $ KindedTyVar noExt (noLoc (getName fakeTyVar)) (synifyKindSig realKind)
+
+ conKind = defaultType prr (tyConKind tc)
+ tyVarKinds = fst . splitFunTys . snd . splitPiTysInvisible $ conKind
-synifyTyCon _coax tc
+synifyTyCon _prr _coax tc
| Just flav <- famTyConFlav_maybe tc
= case flav of
-- Type families
@@ -197,7 +242,7 @@ synifyTyCon _coax tc
, fdInfo = i
, fdLName = synifyName tc
, fdTyVars = synifyTyVars (tyConVisibleTyVars tc)
- , fdFixity = Prefix
+ , fdFixity = synifyFixity tc
, fdResultSig =
synifyFamilyResultSig resultVar (tyConResKind tc)
, fdInjectivityAnn =
@@ -205,13 +250,13 @@ synifyTyCon _coax tc
(tyConInjectivityInfo tc)
}
-synifyTyCon coax tc
+synifyTyCon _prr coax tc
| Just ty <- synTyConRhs_maybe tc
= return $ SynDecl { tcdSExt = emptyNameSet
, tcdLName = synifyName tc
, tcdTyVars = synifyTyVars (tyConVisibleTyVars tc)
- , tcdFixity = Prefix
- , tcdRhs = synifyType WithinType ty }
+ , tcdFixity = synifyFixity tc
+ , tcdRhs = synifyType WithinType [] ty }
| otherwise =
-- (closed) newtype and data
let
@@ -239,7 +284,7 @@ synifyTyCon coax tc
-- That seems like an acceptable compromise (they'll just be documented
-- in prefix position), since, otherwise, the logic (at best) gets much more
-- complicated. (would use dataConIsInfix.)
- use_gadt_syntax = any (not . isVanillaDataCon) (tyConDataCons tc)
+ use_gadt_syntax = isGadtSyntaxTyCon tc
consRaw = map (synifyDataCon use_gadt_syntax) (tyConDataCons tc)
cons = rights consRaw
-- "deriving" doesn't affect the signature, no need to specify any.
@@ -253,31 +298,31 @@ synifyTyCon coax tc
, dd_derivs = alg_deriv }
in case lefts consRaw of
[] -> return $
- DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdFixity = Prefix
+ DataDecl { tcdLName = name, tcdTyVars = tyvars
+ , tcdFixity = synifyFixity name
, tcdDataDefn = defn
, tcdDExt = DataDeclRn False placeHolderNamesTc }
dataConErrs -> Left $ unlines dataConErrs
--- In this module, every TyCon being considered has come from an interface
+-- | In this module, every TyCon being considered has come from an interface
-- file. This means that when considering a data type constructor such as:
--
--- data Foo (w :: *) (m :: * -> *) (a :: *)
+-- > data Foo (w :: *) (m :: * -> *) (a :: *)
--
-- Then its tyConKind will be (* -> (* -> *) -> * -> *). But beware! We are
-- also rendering the type variables of Foo, so if we synify the tyConKind of
-- Foo in full, we will end up displaying this in Haddock:
--
--- data Foo (w :: *) (m :: * -> *) (a :: *)
--- :: * -> (* -> *) -> * -> *
+-- > data Foo (w :: *) (m :: * -> *) (a :: *)
+-- > :: * -> (* -> *) -> * -> *
--
--- Which is entirely wrong (#548). We only want to display the *return* kind,
+-- Which is entirely wrong (#548). We only want to display the /return/ kind,
-- which this function obtains.
synifyDataTyConReturnKind :: TyCon -> Maybe (LHsKind GhcRn)
synifyDataTyConReturnKind tc
- = case splitFunTys (dropForAlls (tyConKind tc)) of
- (_, ret_kind)
- | isLiftedTypeKind ret_kind -> Nothing -- Don't bother displaying :: *
- | otherwise -> Just (synifyKindSig ret_kind)
+ | isLiftedTypeKind ret_kind = Nothing -- Don't bother displaying :: *
+ | otherwise = Just (synifyKindSig ret_kind)
+ where ret_kind = tyConResKind tc
synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity
-> Maybe (LInjectivityAnn GhcRn)
@@ -288,8 +333,9 @@ synifyInjectivityAnn (Just lhs) tvs (Injective inj) =
in Just $ noLoc $ InjectivityAnn (noLoc lhs) rhs
synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn
-synifyFamilyResultSig Nothing kind =
- noLoc $ KindSig noExt (synifyKindSig kind)
+synifyFamilyResultSig Nothing kind
+ | isLiftedTypeKind kind = noLoc $ NoSig noExt
+ | otherwise = noLoc $ KindSig noExt (synifyKindSig kind)
synifyFamilyResultSig (Just name) kind =
noLoc $ TyVarSig noExt (noLoc $ KindedTyVar noExt (noLoc name) (synifyKindSig kind))
@@ -307,14 +353,16 @@ synifyDataCon use_gadt_syntax dc =
use_named_field_syntax = not (null field_tys)
name = synifyName dc
-- con_qvars means a different thing depending on gadt-syntax
- (univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc
+ (_univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc
+ user_tvs = dataConUserTyVars dc -- Used for GADT data constructors
-- skip any EqTheta, use 'orig'inal syntax
- ctx = synifyCtx theta
+ ctx | null theta = Nothing
+ | otherwise = Just $ synifyCtx theta
linear_tys =
zipWith (\ty bang ->
- let tySyn = synifyType WithinType ty
+ let tySyn = synifyType WithinType [] ty
in case bang of
(HsSrcBang _ NoSrcUnpack NoSrcStrict) -> tySyn
bang' -> noLoc $ HsBangTy noExt bang' tySyn)
@@ -338,33 +386,55 @@ synifyDataCon use_gadt_syntax dc =
then return $ noLoc $
ConDeclGADT { con_g_ext = noExt
, con_names = [name]
- , con_forall = noLoc True
- , con_qvars = synifyTyVars (univ_tvs ++ ex_tvs)
- , con_mb_cxt = Just ctx
- , con_args = hat
- , con_res_ty = synifyType WithinType res_ty
- , con_doc = Nothing }
+ , con_forall = noLoc $ not $ null user_tvs
+ , con_qvars = synifyTyVars user_tvs
+ , con_mb_cxt = ctx
+ , con_args = hat
+ , con_res_ty = synifyType WithinType [] res_ty
+ , con_doc = Nothing }
else return $ noLoc $
ConDeclH98 { con_ext = noExt
, con_name = name
- , con_forall = noLoc True
+ , con_forall = noLoc False
, con_ex_tvs = map synifyTyVar ex_tvs
- , con_mb_cxt = Just ctx
+ , con_mb_cxt = ctx
, con_args = hat
, con_doc = Nothing }
synifyName :: NamedThing n => n -> Located Name
synifyName n = L (srcLocSpan (getSrcLoc n)) (getName n)
-
-synifyIdSig :: SynifyTypeState -> Id -> Sig GhcRn
-synifyIdSig s i = TypeSig noExt [synifyName i] (synifySigWcType s (varType i))
-
-synifyTcIdSig :: SynifyTypeState -> Id -> Sig GhcRn
-synifyTcIdSig s i = ClassOpSig noExt False [synifyName i] (synifySigType s (varType i))
+-- | Guess the fixity of a something with a name. This isn't quite right, since
+-- a user can always declare an infix name in prefix form or a prefix name in
+-- infix form. Unfortunately, that is not something we can usually reconstruct.
+synifyFixity :: NamedThing n => n -> LexicalFixity
+synifyFixity n | isSymOcc (getOccName n) = Infix
+ | otherwise = Prefix
+
+synifyIdSig
+ :: PrintRuntimeReps -- ^ are we printing tyvars of kind 'RuntimeRep'?
+ -> SynifyTypeState -- ^ what to do with a 'forall'
+ -> [TyVar] -- ^ free variables in the type to convert
+ -> Id -- ^ the 'Id' from which to get the type signature
+ -> Sig GhcRn
+synifyIdSig prr s vs i = TypeSig noExt [synifyName i] (synifySigWcType s vs t)
+ where
+ t = defaultType prr (varType i)
+
+-- | Turn a 'ClassOpItem' into a list of signatures. The list returned is going
+-- to contain the synified 'ClassOpSig' as well (when appropriate) a default
+-- 'ClassOpSig'.
+synifyTcIdSig :: [TyVar] -> ClassOpItem -> [Sig GhcRn]
+synifyTcIdSig vs (i, dm) =
+ [ ClassOpSig noExt False [synifyName i] (mainSig (varType i)) ] ++
+ [ ClassOpSig noExt True [noLoc dn] (defSig dt)
+ | Just (dn, GenericDM dt) <- [dm] ]
+ where
+ mainSig t = synifySigType DeleteTopLevelQuantification vs t
+ defSig t = synifySigType ImplicitizeForAll vs t
synifyCtx :: [PredType] -> LHsContext GhcRn
-synifyCtx = noLoc . map (synifyType WithinType)
+synifyCtx = noLoc . map (synifyType WithinType [])
synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn
@@ -373,13 +443,20 @@ synifyTyVars ktvs = HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = []
, hsq_explicit = map synifyTyVar ktvs }
synifyTyVar :: TyVar -> LHsTyVarBndr GhcRn
-synifyTyVar tv
- | isLiftedTypeKind kind = noLoc (UserTyVar noExt (noLoc name))
- | otherwise = noLoc (KindedTyVar noExt (noLoc name) (synifyKindSig kind))
+synifyTyVar = synifyTyVar' emptyVarSet
+
+-- | Like 'synifyTyVar', but accepts a set of variables for which to omit kind
+-- signatures (even if they don't have the lifted type kind).
+synifyTyVar' :: VarSet -> TyVar -> LHsTyVarBndr GhcRn
+synifyTyVar' no_kinds tv
+ | isLiftedTypeKind kind || tv `elemVarSet` no_kinds
+ = noLoc (UserTyVar noExt (noLoc name))
+ | otherwise = noLoc (KindedTyVar noExt (noLoc name) (synifyKindSig kind))
where
kind = tyVarKind tv
name = getName tv
+
-- | Annotate (with HsKingSig) a type if the first parameter is True
-- and if the type contains a free variable.
-- This is used to synify type patterns for poly-kinded tyvars in
@@ -391,7 +468,7 @@ annotHsType _ _ hs_ty@(L _ (HsKindSig {})) = hs_ty
annotHsType True ty hs_ty
| not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty
= let ki = typeKind ty
- hs_ki = synifyType WithinType ki
+ hs_ki = synifyType WithinType [] ki
in noLoc (HsKindSig noExt hs_ty hs_ki)
annotHsType _ _ hs_ty = hs_ty
@@ -414,7 +491,8 @@ data SynifyTypeState
-- quite understand what's going on.
| ImplicitizeForAll
-- ^ beginning of a function definition, in which, to make it look
- -- less ugly, those rank-1 foralls are made implicit.
+ -- less ugly, those rank-1 foralls (without kind annotations) are made
+ -- implicit.
| DeleteTopLevelQuantification
-- ^ because in class methods the context is added to the type
-- (e.g. adding @forall a. Num a =>@ to @(+) :: a -> a -> a@)
@@ -423,22 +501,33 @@ data SynifyTypeState
-- the defining class gets to quantify all its functions for free!
-synifySigType :: SynifyTypeState -> Type -> LHsSigType GhcRn
+synifySigType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigType GhcRn
-- The empty binders is a bit suspicious;
-- what if the type has free variables?
-synifySigType s ty = mkEmptyImplicitBndrs (synifyType s ty)
+synifySigType s vs ty = mkEmptyImplicitBndrs (synifyType s vs ty)
-synifySigWcType :: SynifyTypeState -> Type -> LHsSigWcType GhcRn
+synifySigWcType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigWcType GhcRn
-- Ditto (see synifySigType)
-synifySigWcType s ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs (synifyType s ty))
+synifySigWcType s vs ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs (synifyType s vs ty))
synifyPatSynSigType :: PatSyn -> LHsSigType GhcRn
-- Ditto (see synifySigType)
synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps)
-synifyType :: SynifyTypeState -> Type -> LHsType GhcRn
-synifyType _ (TyVarTy tv) = noLoc $ HsTyVar noExt NotPromoted $ noLoc (getName tv)
-synifyType _ (TyConApp tc tys)
+-- | Depending on the first argument, try to default all type variables of kind
+-- 'RuntimeRep' to 'LiftedType'.
+defaultType :: PrintRuntimeReps -> Type -> Type
+defaultType ShowRuntimeRep = id
+defaultType HideRuntimeRep = defaultRuntimeRepVars
+
+-- | Convert a core type into an 'HsType'.
+synifyType
+ :: SynifyTypeState -- ^ what to do with a 'forall'
+ -> [TyVar] -- ^ free variables in the type to convert
+ -> Type -- ^ the type to convert
+ -> LHsType GhcRn
+synifyType _ _ (TyVarTy tv) = noLoc $ HsTyVar noExt NotPromoted $ noLoc (getName tv)
+synifyType _ vs (TyConApp tc tys)
= maybe_sig res_ty
where
res_ty :: LHsType GhcRn
@@ -456,39 +545,55 @@ synifyType _ (TyConApp tc tys)
BoxedTuple -> HsBoxedTuple
ConstraintTuple -> HsConstraintTuple
UnboxedTuple -> HsUnboxedTuple)
- (map (synifyType WithinType) vis_tys)
+ (map (synifyType WithinType vs) vis_tys)
+ | isUnboxedSumTyCon tc = noLoc $ HsSumTy noExt (map (synifyType WithinType vs) vis_tys)
+ | Just dc <- isPromotedDataCon_maybe tc
+ , isTupleDataCon dc
+ , dataConSourceArity dc == length vis_tys
+ = noLoc $ HsExplicitTupleTy noExt (map (synifyType WithinType vs) vis_tys)
-- ditto for lists
- | getName tc == listTyConName, [ty] <- tys =
- noLoc $ HsListTy noExt (synifyType WithinType ty)
+ | getName tc == listTyConName, [ty] <- vis_tys =
+ noLoc $ HsListTy noExt (synifyType WithinType vs ty)
+ | tc == promotedNilDataCon, [] <- vis_tys
+ = noLoc $ HsExplicitListTy noExt IsPromoted []
+ | tc == promotedConsDataCon
+ , [ty1, ty2] <- vis_tys
+ = let hTy = synifyType WithinType vs ty1
+ in case synifyType WithinType vs ty2 of
+ tTy | L _ (HsExplicitListTy _ IsPromoted tTy') <- stripKindSig tTy
+ -> noLoc $ HsExplicitListTy noExt IsPromoted (hTy : tTy')
+ | otherwise
+ -> noLoc $ HsOpTy noExt hTy (noLoc $ getName tc) tTy
-- ditto for implicit parameter tycons
| tc `hasKey` ipClassKey
, [name, ty] <- tys
, Just x <- isStrLitTy name
- = noLoc $ HsIParamTy noExt (noLoc $ HsIPName x) (synifyType WithinType ty)
+ = noLoc $ HsIParamTy noExt (noLoc $ HsIPName x) (synifyType WithinType vs ty)
-- and equalities
| tc `hasKey` eqTyConKey
, [ty1, ty2] <- tys
= noLoc $ HsOpTy noExt
- (synifyType WithinType ty1)
+ (synifyType WithinType vs ty1)
(noLoc eqTyConName)
- (synifyType WithinType ty2)
+ (synifyType WithinType vs ty2)
-- and infix type operators
| isSymOcc (nameOccName (getName tc))
, ty1:ty2:tys_rest <- vis_tys
= mk_app_tys (HsOpTy noExt
- (synifyType WithinType ty1)
+ (synifyType WithinType vs ty1)
(noLoc $ getName tc)
- (synifyType WithinType ty2))
+ (synifyType WithinType vs ty2))
tys_rest
-- Most TyCons:
| otherwise
- = mk_app_tys (HsTyVar noExt NotPromoted $ noLoc (getName tc))
+ = mk_app_tys (HsTyVar noExt prom $ noLoc (getName tc))
vis_tys
where
+ prom = if isPromotedDataCon tc then IsPromoted else NotPromoted
mk_app_tys ty_app ty_args =
foldl (\t1 t2 -> noLoc $ HsAppTy noExt t1 t2)
(noLoc ty_app)
- (map (synifyType WithinType) $
+ (map (synifyType WithinType vs) $
filterOut isCoercionTy ty_args)
vis_tys = filterOutInvisibleTypes tc tys
@@ -499,7 +604,7 @@ synifyType _ (TyConApp tc tys)
maybe_sig ty'
| needs_kind_sig
= let full_kind = typeKind (mkTyConApp tc tys)
- full_kind' = synifyType WithinType full_kind
+ full_kind' = synifyType WithinType vs full_kind
in noLoc $ HsKindSig noExt ty' full_kind'
| otherwise = ty'
@@ -517,76 +622,174 @@ synifyType _ (TyConApp tc tys)
in not (subVarSet result_vars dropped_vars)
-synifyType s (AppTy t1 (CoercionTy {})) = synifyType s t1
-synifyType _ (AppTy t1 t2) = let
- s1 = synifyType WithinType t1
- s2 = synifyType WithinType t2
+synifyType s vs (AppTy t1 (CoercionTy {})) = synifyType s vs t1
+synifyType _ vs (AppTy t1 t2) = let
+ s1 = synifyType WithinType vs t1
+ s2 = synifyType WithinType vs t2
in noLoc $ HsAppTy noExt s1 s2
-synifyType _ (FunTy t1 t2) = let
- s1 = synifyType WithinType t1
- s2 = synifyType WithinType t2
- in noLoc $ HsFunTy noExt s1 s2
-synifyType s forallty@(ForAllTy _tv _ty) =
- let (tvs, ctx, tau) = tcSplitSigmaTyPreserveSynonyms forallty
+synifyType s vs funty@(FunTy t1 t2)
+ | isPredTy t1 = synifyForAllType s vs funty
+ | otherwise = let s1 = synifyType WithinType vs t1
+ s2 = synifyType WithinType vs t2
+ in noLoc $ HsFunTy noExt s1 s2
+synifyType s vs forallty@(ForAllTy _tv _ty) = synifyForAllType s vs forallty
+
+synifyType _ _ (LitTy t) = noLoc $ HsTyLit noExt $ synifyTyLit t
+synifyType s vs (CastTy t _) = synifyType s vs t
+synifyType _ _ (CoercionTy {}) = error "synifyType:Coercion"
+
+-- | Process a 'Type' which starts with a forall or a constraint into
+-- an 'HsType'
+synifyForAllType
+ :: SynifyTypeState -- ^ what to do with the 'forall'
+ -> [TyVar] -- ^ free variables in the type to convert
+ -> Type -- ^ the forall type to convert
+ -> LHsType GhcRn
+synifyForAllType s vs ty =
+ let (tvs, ctx, tau) = tcSplitSigmaTyPreserveSynonyms ty
sPhi = HsQualTy { hst_ctxt = synifyCtx ctx
- , hst_xqual = noExt
- , hst_body = synifyType WithinType tau }
+ , hst_xqual = noExt
+ , hst_body = synifyType WithinType (tvs' ++ vs) tau }
+
+ sTy = HsForAllTy { hst_bndrs = sTvs
+ , hst_xforall = noExt
+ , hst_body = noLoc sPhi }
+
+ sTvs = map synifyTyVar tvs
+
+ -- Figure out what the type variable order would be inferred in the
+ -- absence of an explicit forall
+ tvs' = orderedFVs (mkVarSet vs) (ctx ++ [tau])
+
in case s of
- DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau
- WithinType -> noLoc $ HsForAllTy { hst_bndrs = map synifyTyVar tvs
- , hst_xforall = noExt
- , hst_body = noLoc sPhi }
- ImplicitizeForAll -> noLoc sPhi
+ DeleteTopLevelQuantification -> synifyType ImplicitizeForAll (tvs' ++ vs) tau
+
+ -- Put a forall in if there are any type variables
+ WithinType
+ | not (null tvs) -> noLoc sTy
+ | otherwise -> noLoc sPhi
+
+ ImplicitizeForAll -> implicitForAll [] vs tvs ctx (synifyType WithinType) tau
+
+
+-- | Put a forall in if there are any type variables which require
+-- explicit kind annotations or if the inferred type variable order
+-- would be different.
+implicitForAll
+ :: [TyCon] -- ^ type constructors that determine their args kinds
+ -> [TyVar] -- ^ free variables in the type to convert
+ -> [TyVar] -- ^ type variable binders in the forall
+ -> ThetaType -- ^ constraints right after the forall
+ -> ([TyVar] -> Type -> LHsType GhcRn) -- ^ how to convert the inner type
+ -> Type -- ^ inner type
+ -> LHsType GhcRn
+implicitForAll tycons vs tvs ctx synInner tau
+ | any (isHsKindedTyVar . unLoc) sTvs = noLoc sTy
+ | tvs' /= tvs = noLoc sTy
+ | otherwise = noLoc sPhi
+ where
+ sRho = synInner (tvs' ++ vs) tau
+ sPhi | null ctx = unLoc sRho
+ | otherwise
+ = HsQualTy { hst_ctxt = synifyCtx ctx
+ , hst_xqual = noExt
+ , hst_body = synInner (tvs' ++ vs) tau }
+ sTy = HsForAllTy { hst_bndrs = sTvs
+ , hst_xforall = noExt
+ , hst_body = noLoc sPhi }
+
+ no_kinds_needed = noKindTyVars tycons tau
+ sTvs = map (synifyTyVar' no_kinds_needed) tvs
+
+ -- Figure out what the type variable order would be inferred in the
+ -- absence of an explicit forall
+ tvs' = orderedFVs (mkVarSet vs) (ctx ++ [tau])
+
-synifyType _ (LitTy t) = noLoc $ HsTyLit noExt $ synifyTyLit t
-synifyType s (CastTy t _) = synifyType s t
-synifyType _ (CoercionTy {}) = error "synifyType:Coercion"
+
+-- | Find the set of type variables whose kind signatures can be properly
+-- inferred just from their uses in the type signature. This means the type
+-- variable to has at least one fully applied use @f x1 x2 ... xn@ where:
+--
+-- * @f@ has a function kind where the arguments have the same kinds
+-- as @x1 x2 ... xn@.
+--
+-- * @f@ has a function kind whose final return has lifted type kind
+--
+noKindTyVars
+ :: [TyCon] -- ^ type constructors that determine their args kinds
+ -> Type -- ^ type to inspect
+ -> VarSet -- ^ set of variables whose kinds can be inferred from uses in the type
+noKindTyVars _ (TyVarTy var)
+ | isLiftedTypeKind (tyVarKind var) = unitVarSet var
+noKindTyVars ts ty
+ | (f, xs) <- splitAppTys ty
+ , not (null xs)
+ = let args = map (noKindTyVars ts) xs
+ func = case f of
+ TyVarTy var | (xsKinds, outKind) <- splitFunTys (tyVarKind var)
+ , xsKinds `eqTypes` map typeKind xs
+ , isLiftedTypeKind outKind
+ -> unitVarSet var
+ TyConApp t ks | t `elem` ts
+ , all noFreeVarsOfType ks
+ -> mkVarSet [ v | TyVarTy v <- xs ]
+ _ -> noKindTyVars ts f
+ in unionVarSets (func : args)
+noKindTyVars ts (ForAllTy _ t) = noKindTyVars ts t
+noKindTyVars ts (FunTy t1 t2) = noKindTyVars ts t1 `unionVarSet` noKindTyVars ts t2
+noKindTyVars ts (CastTy t _) = noKindTyVars ts t
+noKindTyVars _ _ = emptyVarSet
synifyPatSynType :: PatSyn -> LHsType GhcRn
-synifyPatSynType ps = let
- (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSig ps
- req_theta' | null req_theta && not (null prov_theta && null ex_tvs) = [unitTy]
- -- HACK: a HsQualTy with theta = [unitTy] will be printed as "() =>",
- -- i.e., an explicit empty context, which is what we need. This is not
- -- possible by taking theta = [], as that will print no context at all
- | otherwise = req_theta
- sForAll [] s = s
- sForAll tvs s = HsForAllTy { hst_bndrs = map synifyTyVar tvs
- , hst_xforall = noExt
- , hst_body = noLoc s }
- sQual theta s = HsQualTy { hst_ctxt = synifyCtx theta
- , hst_xqual = noExt
- , hst_body = noLoc s }
- sTau = unLoc $ synifyType WithinType $ mkFunTys arg_tys res_ty
- in noLoc $ sForAll univ_tvs $ sQual req_theta' $ sForAll ex_tvs $ sQual prov_theta sTau
+synifyPatSynType ps =
+ let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSig ps
+ ts = maybeToList (tyConAppTyCon_maybe res_ty)
+
+ -- HACK: a HsQualTy with theta = [unitTy] will be printed as "() =>",
+ -- i.e., an explicit empty context, which is what we need. This is not
+ -- possible by taking theta = [], as that will print no context at all
+ req_theta' | null req_theta
+ , not (null prov_theta && null ex_tvs)
+ = [unitTy]
+ | otherwise = req_theta
+
+ in implicitForAll ts [] (univ_tvs ++ ex_tvs) req_theta'
+ (\vs -> implicitForAll ts vs [] prov_theta (synifyType WithinType))
+ (mkFunTys arg_tys res_ty)
synifyTyLit :: TyLit -> HsTyLit
synifyTyLit (NumTyLit n) = HsNumTy NoSourceText n
synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s
synifyKindSig :: Kind -> LHsKind GhcRn
-synifyKindSig k = synifyType WithinType k
+synifyKindSig k = synifyType WithinType [] k
+
+stripKindSig :: LHsType GhcRn -> LHsType GhcRn
+stripKindSig (L _ (HsKindSig _ t _)) = t
+stripKindSig t = t
synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead GhcRn
-synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead
+synifyInstHead (vs, preds, cls, types) = specializeInstHead $ InstHead
{ ihdClsName = getName cls
, ihdTypes = map unLoc annot_ts
, ihdInstType = ClassInst
- { clsiCtx = map (unLoc . synifyType WithinType) preds
+ { clsiCtx = map (unLoc . synifyType WithinType []) preds
, clsiTyVars = synifyTyVars (tyConVisibleTyVars cls_tycon)
, clsiSigs = map synifyClsIdSig $ classMethods cls
, clsiAssocTys = do
- (Right (FamDecl _ fam)) <- map (synifyTyCon Nothing) $ classATs cls
+ (Right (FamDecl _ fam)) <- map (synifyTyCon HideRuntimeRep Nothing)
+ (classATs cls)
pure $ mkPseudoFamilyDecl fam
}
}
where
cls_tycon = classTyCon cls
ts = filterOutInvisibleTypes cls_tycon types
- ts' = map (synifyType WithinType) ts
+ ts' = map (synifyType WithinType vs) ts
annot_ts = zipWith3 annotHsType is_poly_tvs ts ts'
is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars cls_tycon)
- synifyClsIdSig = synifyIdSig DeleteTopLevelQuantification
+ synifyClsIdSig = synifyIdSig ShowRuntimeRep DeleteTopLevelQuantification vs
-- Convert a family instance, this could be a type family or data family
synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead GhcRn)
@@ -600,9 +803,9 @@ synifyFamInst fi opaque = do
where
ityp SynFamilyInst | opaque = return $ TypeInst Nothing
ityp SynFamilyInst =
- return . TypeInst . Just . unLoc $ synifyType WithinType fam_rhs
+ return . TypeInst . Just . unLoc $ synifyType WithinType [] fam_rhs
ityp (DataFamilyInst c) =
- DataInst <$> synifyTyCon (Just $ famInstAxiom fi) c
+ DataInst <$> synifyTyCon HideRuntimeRep (Just $ famInstAxiom fi) c
fam_tc = famInstTyCon fi
fam_flavor = fi_flavor fi
fam_lhs = fi_tys fi
@@ -622,7 +825,7 @@ synifyFamInst fi opaque = do
= fam_lhs
ts = filterOutInvisibleTypes fam_tc eta_expanded_lhs
- synifyTypes = map (synifyType WithinType)
+ synifyTypes = map (synifyType WithinType [])
ts' = synifyTypes ts
annot_ts = zipWith3 annotHsType is_poly_tvs ts ts'
is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars fam_tc)
@@ -652,8 +855,8 @@ tcSplitSigmaTyPreserveSynonyms ty =
tcSplitForAllTysPreserveSynonyms :: Type -> ([TyVar], Type)
tcSplitForAllTysPreserveSynonyms ty = split ty ty []
where
- split _ (ForAllTy (TvBndr tv _) ty') tvs = split ty' ty' (tv:tvs)
- split orig_ty _ tvs = (reverse tvs, orig_ty)
+ split _ (ForAllTy (Bndr tv _) ty') tvs = split ty' ty' (tv:tvs)
+ split orig_ty _ tvs = (reverse tvs, orig_ty)
-- | See Note [Invariant: Never expand type synonyms]
tcSplitPhiTyPreserveSynonyms :: Type -> (ThetaType, Type)
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index e7d80969..29a52faf 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -1,5 +1,6 @@
-{-# LANGUAGE BangPatterns, FlexibleInstances, ViewPatterns #-}
+{-# LANGUAGE BangPatterns, StandaloneDeriving, FlexibleInstances, ViewPatterns #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK hide #-}
-----------------------------------------------------------------------------
@@ -18,20 +19,34 @@ module Haddock.GhcUtils where
import Control.Arrow
+import Data.Char ( isSpace )
+
import Haddock.Types( DocNameI )
import Exception
-import Outputable
+import FV
+import Outputable ( Outputable, panic, showPpr )
import Name
import NameSet
-import Lexeme
import Module
import HscTypes
import GHC
import Class
import DynFlags
+import SrcLoc ( advanceSrcLoc )
+import Var ( VarBndr(..), TyVarBinder, tyVarKind, updateTyVarKind,
+ isInvisibleArgFlag )
+import VarSet ( VarSet, emptyVarSet )
+import VarEnv ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv )
+import TyCoRep ( Type(..), isRuntimeRepVar )
+import TysWiredIn( liftedRepDataConTyCon )
+
+import StringBuffer ( StringBuffer )
+import qualified StringBuffer as S
-import HsTypes (HsType(..))
+import Data.ByteString ( ByteString )
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Internal as BS
moduleString :: Module -> String
@@ -40,15 +55,8 @@ moduleString = moduleNameString . moduleName
isNameSym :: Name -> Bool
isNameSym = isSymOcc . nameOccName
-
-isVarSym :: OccName -> Bool
-isVarSym = isLexVarSym . occNameFS
-
-isConSym :: OccName -> Bool
-isConSym = isLexConSym . occNameFS
-
-
-getMainDeclBinder :: HsDecl name -> [IdP name]
+getMainDeclBinder :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) =>
+ HsDecl p -> [IdP p]
getMainDeclBinder (TyClD _ d) = [tcdName d]
getMainDeclBinder (ValD _ d) =
case collectHsBindBinders d of
@@ -141,12 +149,6 @@ isValD :: HsDecl a -> Bool
isValD (ValD _ _) = True
isValD _ = False
-
-declATs :: HsDecl a -> [IdP a]
-declATs (TyClD _ d) | isClassDecl d = map (unL . fdLName . unL) $ tcdATs d
-declATs _ = []
-
-
pretty :: Outputable a => DynFlags -> a -> String
pretty = showPpr
@@ -237,6 +239,8 @@ getGADTConTypeG (XConDecl {}) = panic "getGADTConTypeG"
data Precedence
= PREC_TOP -- ^ precedence of 'type' production in GHC's parser
+ | PREC_SIG -- ^ explicit type signature
+
| PREC_CTX -- ^ Used for single contexts, eg. ctx => type
-- (as opposed to (ctx1, ctx2) => type)
@@ -263,12 +267,13 @@ reparenTypePrec = go
go _ (HsBangTy x b ty) = HsBangTy x b (reparenLType ty)
go _ (HsTupleTy x con tys) = HsTupleTy x con (map reparenLType tys)
go _ (HsSumTy x tys) = HsSumTy x (map reparenLType tys)
- go _ (HsKindSig x ty kind) = HsKindSig x (reparenLType ty) (reparenLType kind)
go _ (HsListTy x ty) = HsListTy x (reparenLType ty)
go _ (HsRecTy x flds) = HsRecTy x (map (fmap reparenConDeclField) flds)
go p (HsDocTy x ty d) = HsDocTy x (goL p ty) d
go _ (HsExplicitListTy x p tys) = HsExplicitListTy x p (map reparenLType tys)
go _ (HsExplicitTupleTy x tys) = HsExplicitTupleTy x (map reparenLType tys)
+ go p (HsKindSig x ty kind)
+ = paren p PREC_SIG $ HsKindSig x (goL PREC_SIG ty) (goL PREC_SIG kind)
go p (HsIParamTy x n ty)
= paren p PREC_CTX $ HsIParamTy x n (reparenLType ty)
go p (HsForAllTy x tvs ty)
@@ -279,6 +284,8 @@ reparenTypePrec = go
= paren p PREC_FUN $ HsFunTy x (goL PREC_FUN ty1) (goL PREC_TOP ty2)
go p (HsAppTy x fun_ty arg_ty)
= paren p PREC_CON $ HsAppTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ty)
+ go p (HsAppKindTy x fun_ty arg_ki)
+ = paren p PREC_CON $ HsAppKindTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ki)
go p (HsOpTy x ty1 op ty2)
= paren p PREC_FUN $ HsOpTy x (goL PREC_OP ty1) op (goL PREC_OP ty2)
go p (HsParTy _ t) = unLoc $ goL p t -- pretend the paren doesn't exist - it will be added back if needed
@@ -426,13 +433,230 @@ minimalDef n = do
-------------------------------------------------------------------------------
-setObjectDir, setHiDir, setStubDir, setOutputDir :: String -> DynFlags -> DynFlags
+setObjectDir, setHiDir, setHieDir, setStubDir, setOutputDir :: String -> DynFlags -> DynFlags
setObjectDir f d = d{ objectDir = Just f}
setHiDir f d = d{ hiDir = Just f}
+setHieDir f d = d{ hieDir = Just f}
setStubDir f d = d{ stubDir = Just f
, includePaths = addGlobalInclude (includePaths d) [f] }
-- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file
-- \#included from the .hc file when compiling with -fvia-C.
-setOutputDir f = setObjectDir f . setHiDir f . setStubDir f
+setOutputDir f = setObjectDir f . setHiDir f . setHieDir f . setStubDir f
+
+
+-------------------------------------------------------------------------------
+-- * 'StringBuffer' and 'ByteString'
+-------------------------------------------------------------------------------
+-- We get away with a bunch of these functions because 'StringBuffer' and
+-- 'ByteString' have almost exactly the same structure.
+
+-- | Convert a UTF-8 encoded 'ByteString' into a 'StringBuffer. This really
+-- relies on the internals of both 'ByteString' and 'StringBuffer'.
+--
+-- /O(n)/ (but optimized into a @memcpy@ by @bytestring@ under the hood)
+stringBufferFromByteString :: ByteString -> StringBuffer
+stringBufferFromByteString bs =
+ let BS.PS fp off len = bs <> BS.pack [0,0,0]
+ in S.StringBuffer { S.buf = fp, S.len = len - 3, S.cur = off }
+
+-- | Take the first @n@ /bytes/ of the 'StringBuffer' and put them in a
+-- 'ByteString'.
+--
+-- /O(1)/
+takeStringBuffer :: Int -> StringBuffer -> ByteString
+takeStringBuffer !n !(S.StringBuffer fp _ cur) = BS.PS fp cur n
+
+-- | Return the prefix of the first 'StringBuffer' that /isn't/ in the second
+-- 'StringBuffer'. **The behavior is undefined if the 'StringBuffers' use
+-- separate buffers.**
+--
+-- /O(1)/
+splitStringBuffer :: StringBuffer -> StringBuffer -> ByteString
+splitStringBuffer buf1 buf2 = takeStringBuffer n buf1
+ where n = S.byteDiff buf1 buf2
+
+-- | Split the 'StringBuffer' at the next newline (or the end of the buffer).
+-- Also: initial position is passed in and the updated position is returned.
+--
+-- /O(n)/ (but /O(1)/ space)
+spanLine :: RealSrcLoc -> StringBuffer -> (ByteString, RealSrcLoc, StringBuffer)
+spanLine !loc !buf = go loc buf
+ where
+
+ go !l !b
+ | not (S.atEnd b)
+ = case S.nextChar b of
+ ('\n', b') -> (splitStringBuffer buf b', advanceSrcLoc l '\n', b')
+ (c, b') -> go (advanceSrcLoc l c) b'
+ | otherwise
+ = (splitStringBuffer buf b, advanceSrcLoc l '\n', b)
+-- | Given a start position and a buffer with that start position, split the
+-- buffer at an end position.
+--
+-- /O(n)/ (but /O(1)/ space)
+spanPosition :: RealSrcLoc -- ^ start of buffeer
+ -> RealSrcLoc -- ^ position until which to take
+ -> StringBuffer -- ^ buffer from which to take
+ -> (ByteString, StringBuffer)
+spanPosition !start !end !buf = go start buf
+ where
+
+ go !l !b
+ | l < end
+ , not (S.atEnd b)
+ , (c, b') <- S.nextChar b
+ = go (advanceSrcLoc l c) b'
+ | otherwise
+ = (splitStringBuffer buf b, b)
+
+-- | Try to parse a line of CPP from the from of the buffer. A \"line\" of CPP
+-- consists of
+--
+-- * at most 10 whitespace characters, including at least one newline
+-- * a @#@ character
+-- * keep parsing lines until you find a line not ending in @\\@.
+--
+-- This is chock full of heuristics about what a line of CPP is.
+--
+-- /O(n)/ (but /O(1)/ space)
+tryCppLine :: RealSrcLoc -> StringBuffer -> Maybe (ByteString, RealSrcLoc, StringBuffer)
+tryCppLine !loc !buf = spanSpace (S.prevChar buf '\n' == '\n') loc buf
+ where
+
+ -- Keep consuming space characters until we hit either a @#@ or something
+ -- else. If we hit a @#@, start parsing CPP
+ spanSpace !seenNl !l !b
+ | S.atEnd b
+ = Nothing
+ | otherwise
+ = case S.nextChar b of
+ ('#' , b') | not (S.atEnd b')
+ , ('-', b'') <- S.nextChar b'
+ , ('}', _) <- S.nextChar b''
+ -> Nothing -- Edge case exception for @#-}@
+ | seenNl
+ -> Just (spanCppLine (advanceSrcLoc l '#') b') -- parse CPP
+ | otherwise
+ -> Nothing -- We didn't see a newline, so this can't be CPP!
+
+ (c , b') | isSpace c -> spanSpace (seenNl || c == '\n')
+ (advanceSrcLoc l c) b'
+ | otherwise -> Nothing
+
+ -- Consume a CPP line to its "end" (basically the first line that ends not
+ -- with a @\@ character)
+ spanCppLine !l !b
+ | S.atEnd b
+ = (splitStringBuffer buf b, l, b)
+ | otherwise
+ = case S.nextChar b of
+ ('\\', b') | not (S.atEnd b')
+ , ('\n', b'') <- S.nextChar b'
+ -> spanCppLine (advanceSrcLoc (advanceSrcLoc l '\\') '\n') b''
+
+ ('\n', b') -> (splitStringBuffer buf b', advanceSrcLoc l '\n', b')
+
+ (c , b') -> spanCppLine (advanceSrcLoc l c) b'
+
+-------------------------------------------------------------------------------
+-- * Free variables of a 'Type'
+-------------------------------------------------------------------------------
+
+-- | Get free type variables in a 'Type' in their order of appearance.
+-- See [Ordering of implicit variables].
+orderedFVs
+ :: VarSet -- ^ free variables to ignore
+ -> [Type] -- ^ types to traverse (in order) looking for free variables
+ -> [TyVar] -- ^ free type variables, in the order they appear in
+orderedFVs vs tys =
+ reverse . fst $ tyCoFVsOfTypes' tys (const True) vs ([], emptyVarSet)
+
+
+-- See the "Free variables of types and coercions" section in 'TyCoRep', or
+-- check out Note [Free variables of types]. The functions in this section
+-- don't output type variables in the order they first appear in in the 'Type'.
+--
+-- For example, 'tyCoVarsOfTypeList' reports an incorrect order for the type
+-- of 'const :: a -> b -> a':
+--
+-- >>> import Name
+-- >>> import TyCoRep
+-- >>> import TysPrim
+-- >>> import Var
+-- >>> a = TyVarTy alphaTyVar
+-- >>> b = TyVarTy betaTyVar
+-- >>> constTy = mkFunTys [a, b] a
+-- >>> map (getOccString . tyVarName) (tyCoVarsOfTypeList constTy)
+-- ["b","a"]
+--
+-- However, we want to reuse the very optimized traversal machinery there, so
+-- so we make our own `tyCoFVsOfType'`, `tyCoFVsBndr'`, and `tyCoVarsOfTypes'`.
+-- All these do differently is traverse in a different order and ignore
+-- coercion variables.
+
+-- | Just like 'tyCoFVsOfType', but traverses type variables in reverse order
+-- of appearance.
+tyCoFVsOfType' :: Type -> FV
+tyCoFVsOfType' (TyVarTy v) a b c = (FV.unitFV v `unionFV` tyCoFVsOfType' (tyVarKind v)) a b c
+tyCoFVsOfType' (TyConApp _ tys) a b c = tyCoFVsOfTypes' tys a b c
+tyCoFVsOfType' (LitTy {}) a b c = emptyFV a b c
+tyCoFVsOfType' (AppTy fun arg) a b c = (tyCoFVsOfType' arg `unionFV` tyCoFVsOfType' fun) a b c
+tyCoFVsOfType' (FunTy arg res) a b c = (tyCoFVsOfType' res `unionFV` tyCoFVsOfType' arg) a b c
+tyCoFVsOfType' (ForAllTy bndr ty) a b c = tyCoFVsBndr' bndr (tyCoFVsOfType' ty) a b c
+tyCoFVsOfType' (CastTy ty _) a b c = (tyCoFVsOfType' ty) a b c
+tyCoFVsOfType' (CoercionTy _ ) a b c = emptyFV a b c
+
+-- | Just like 'tyCoFVsOfTypes', but traverses type variables in reverse order
+-- of appearance.
+tyCoFVsOfTypes' :: [Type] -> FV
+tyCoFVsOfTypes' (ty:tys) fv_cand in_scope acc = (tyCoFVsOfTypes' tys `unionFV` tyCoFVsOfType' ty) fv_cand in_scope acc
+tyCoFVsOfTypes' [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc
+
+-- | Just like 'tyCoFVsBndr', but traverses type variables in reverse order of
+-- appearance.
+tyCoFVsBndr' :: TyVarBinder -> FV -> FV
+tyCoFVsBndr' (Bndr tv _) fvs = FV.delFV tv fvs `unionFV` tyCoFVsOfType' (tyVarKind tv)
+
+
+-------------------------------------------------------------------------------
+-- * Defaulting RuntimeRep variables
+-------------------------------------------------------------------------------
+
+-- | Traverses the type, defaulting type variables of kind 'RuntimeRep' to
+-- 'LiftedType'. See 'defaultRuntimeRepVars' in IfaceType.hs the original such
+-- function working over `IfaceType`'s.
+defaultRuntimeRepVars :: Type -> Type
+defaultRuntimeRepVars = go emptyVarEnv
+ where
+ go :: TyVarEnv () -> Type -> Type
+ go subs (ForAllTy (Bndr var flg) ty)
+ | isRuntimeRepVar var
+ , isInvisibleArgFlag flg
+ = let subs' = extendVarEnv subs var ()
+ in go subs' ty
+ | otherwise
+ = ForAllTy (Bndr (updateTyVarKind (go subs) var) flg)
+ (go subs ty)
+
+ go subs (TyVarTy tv)
+ | tv `elemVarEnv` subs
+ = TyConApp liftedRepDataConTyCon []
+ | otherwise
+ = TyVarTy (updateTyVarKind (go subs) tv)
+
+ go subs (TyConApp tc tc_args)
+ = TyConApp tc (map (go subs) tc_args)
+
+ go subs (FunTy arg res)
+ = FunTy (go subs arg) (go subs res)
+
+ go subs (AppTy t u)
+ = AppTy (go subs t) (go subs u)
+
+ go subs (CastTy x co)
+ = CastTy (go subs x) co
+
+ go _ ty@(LitTy {}) = ty
+ go _ ty@(CoercionTy {}) = ty
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index 3d54970b..e7d30fc7 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -43,22 +43,19 @@ import Haddock.Types
import Haddock.Utils
import Control.Monad
+import Control.Exception (evaluate)
import Data.List
import qualified Data.Map as Map
import qualified Data.Set as Set
import Distribution.Verbosity
-import System.Directory
-import System.FilePath
import Text.Printf
import Module (mkModuleSet, emptyModuleSet, unionModuleSet, ModuleSet)
import Digraph
import DynFlags hiding (verbosity)
-import Exception
import GHC hiding (verbosity)
import HscTypes
import FastString (unpackFS)
-import MonadUtils (liftIO)
import TcRnTypes (tcg_rdr_env)
import Name (nameIsFromExternalPackage, nameOccName)
import OccName (isTcOcc)
@@ -92,7 +89,7 @@ processModules verbosity modules flags extIfaces = do
out verbosity verbose "Creating interfaces..."
let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces
, iface <- ifInstalledIfaces ext ]
- (interfaces, ms) <- createIfaces0 verbosity modules flags instIfaceMap
+ (interfaces, ms) <- createIfaces verbosity modules flags instIfaceMap
let exportedNames =
Set.unions $ map (Set.fromList . ifaceExports) $
@@ -125,39 +122,15 @@ processModules verbosity modules flags extIfaces = do
--------------------------------------------------------------------------------
-createIfaces0 :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc ([Interface], ModuleSet)
-createIfaces0 verbosity modules flags instIfaceMap =
- -- Output dir needs to be set before calling depanal since depanal uses it to
- -- compute output file names that are stored in the DynFlags of the
- -- resulting ModSummaries.
- (if useTempDir then withTempOutputDir else id) $ do
- modGraph <- depAnalysis
- createIfaces verbosity flags instIfaceMap modGraph
+createIfaces :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc ([Interface], ModuleSet)
+createIfaces verbosity modules flags instIfaceMap = do
+ -- Ask GHC to tell us what the module graph is
+ targets <- mapM (\filePath -> guessTarget filePath Nothing) modules
+ setTargets targets
+ modGraph <- depanal [] False
- where
- useTempDir :: Bool
- useTempDir = Flag_NoTmpCompDir `notElem` flags
-
-
- withTempOutputDir :: Ghc a -> Ghc a
- withTempOutputDir action = do
- tmp <- liftIO getTemporaryDirectory
- x <- liftIO getProcessID
- let dir = tmp </> ".haddock-" ++ show x
- modifySessionDynFlags (setOutputDir dir)
- withTempDir dir action
-
-
- depAnalysis :: Ghc ModuleGraph
- depAnalysis = do
- targets <- mapM (\f -> guessTarget f Nothing) modules
- setTargets targets
- depanal [] False
-
-
-createIfaces :: Verbosity -> [Flag] -> InstIfaceMap -> ModuleGraph -> Ghc ([Interface], ModuleSet)
-createIfaces verbosity flags instIfaceMap mods = do
- let sortedMods = flattenSCCs $ topSortModuleGraph False mods Nothing
+ -- Visit modules in that order
+ let sortedMods = flattenSCCs $ topSortModuleGraph False modGraph Nothing
out verbosity normal "Haddock coverage:"
(ifaces, _, !ms) <- foldM f ([], Map.empty, emptyModuleSet) sortedMods
return (reverse ifaces, ms)
@@ -271,12 +244,3 @@ buildHomeLinks ifaces = foldl upd Map.empty (reverse ifaces)
keep_old env n = Map.insertWith (\_ old -> old) n mdl env
keep_new env n = Map.insert n mdl env
-
---------------------------------------------------------------------------------
--- * Utils
---------------------------------------------------------------------------------
-
-
-withTempDir :: (ExceptionMonad m) => FilePath -> m a -> m a
-withTempDir dir = gbracket_ (liftIO $ createDirectory dir)
- (liftIO $ removeDirectoryRecursive dir)
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index 2d72d117..dd6c70a5 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, MagicHash, BangPatterns #-}
+{-# LANGUAGE MagicHash, BangPatterns #-}
{-# LANGUAGE TypeFamilies #-}
-----------------------------------------------------------------------------
-- |
@@ -19,6 +19,7 @@ import Haddock.Types
import Haddock.Convert
import Haddock.GhcUtils
+import Control.Applicative ((<|>))
import Control.Arrow hiding ((<+>))
import Data.List
import Data.Ord (comparing)
@@ -31,7 +32,6 @@ import DynFlags
import CoreSyn (isOrphan)
import ErrUtils
import FamInstEnv
-import FastString
import GHC
import InstEnv
import Module ( ModuleSet, moduleSetElts )
@@ -39,13 +39,11 @@ import MonadUtils (liftIO)
import Name
import NameEnv
import Outputable (text, sep, (<+>))
-import PrelNames
import SrcLoc
import TyCon
import TyCoRep
-import TysPrim( funTyCon )
+import TysPrim( funTyConName )
import Var hiding (varName)
-#define FSLIT(x) (mkFastString# (x#))
type ExportedNames = Set.Set Name
type Modules = Set.Set Module
@@ -63,16 +61,24 @@ attachInstances expInfo ifaces instIfaceMap mods = do
ifaceMap = Map.fromList [ (ifaceMod i, i) | i <- ifaces ]
attach index iface = do
- newItems <- mapM (attachToExportItem index expInfo iface ifaceMap instIfaceMap)
+
+ let getInstDoc = findInstDoc iface ifaceMap instIfaceMap
+ getFixity = findFixity iface ifaceMap instIfaceMap
+
+ newItems <- mapM (attachToExportItem index expInfo getInstDoc getFixity)
(ifaceExportItems iface)
- let orphanInstances = attachOrphanInstances expInfo iface ifaceMap instIfaceMap (ifaceInstances iface)
+ let orphanInstances = attachOrphanInstances expInfo getInstDoc (ifaceInstances iface)
return $ iface { ifaceExportItems = newItems
, ifaceOrphanInstances = orphanInstances
}
-attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance GhcRn]
-attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances =
- [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, (L (getSrcSpan n) n), Nothing)
+attachOrphanInstances
+ :: ExportInfo
+ -> (Name -> Maybe (MDoc Name)) -- ^ how to lookup the doc of an instance
+ -> [ClsInst] -- ^ a list of orphan instances
+ -> [DocInstance GhcRn]
+attachOrphanInstances expInfo getInstDoc cls_instances =
+ [ (synifyInstHead i, getInstDoc n, (L (getSrcSpan n) n), Nothing)
| let is = [ (instanceSig i, getName i) | i <- cls_instances, isOrphan (is_orphan i) ]
, (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is
, not $ isInstanceHidden expInfo cls tys
@@ -80,40 +86,40 @@ attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances =
attachToExportItem
- :: NameEnv ([ClsInst], [FamInst])
+ :: NameEnv ([ClsInst], [FamInst]) -- ^ all instances (that we know of)
-> ExportInfo
- -> Interface
- -> IfaceMap
- -> InstIfaceMap
+ -> (Name -> Maybe (MDoc Name)) -- ^ how to lookup the doc of an instance
+ -> (Name -> Maybe Fixity) -- ^ how to lookup a fixity
-> ExportItem GhcRn
-> Ghc (ExportItem GhcRn)
-attachToExportItem index expInfo iface ifaceMap instIfaceMap export =
+attachToExportItem index expInfo getInstDoc getFixity export =
case attachFixities export of
e@ExportDecl { expItemDecl = L eSpan (TyClD _ d) } -> do
insts <-
let mb_instances = lookupNameEnv index (tcdName d)
cls_instances = maybeToList mb_instances >>= fst
fam_instances = maybeToList mb_instances >>= snd
- fam_insts = [ ( synifyFamInst i opaque
- , doc
- , spanNameE n (synifyFamInst i opaque) (L eSpan (tcdName d))
+ fam_insts = [ ( synFamInst
+ , getInstDoc n
+ , spanNameE n synFamInst (L eSpan (tcdName d))
, nameModule_maybe n
)
| i <- sortBy (comparing instFam) fam_instances
, 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)
+ , let synFamInst = synifyFamInst i opaque
]
- cls_insts = [ ( synifyInstHead i
- , instLookup instDocMap n iface ifaceMap instIfaceMap
- , spanName n (synifyInstHead i) (L eSpan (tcdName d))
+ cls_insts = [ ( synClsInst
+ , getInstDoc n
+ , spanName n synClsInst (L eSpan (tcdName d))
, nameModule_maybe n
)
| let is = [ (instanceSig i, getName i) | i <- cls_instances ]
, (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is
, not $ isInstanceHidden expInfo cls tys
+ , let synClsInst = synifyInstHead i
]
-- fam_insts but with failing type fams filtered out
cleanFamInsts = [ (fi, n, L l r, m) | (Right fi, n, L l (Right r), m) <- fam_insts ]
@@ -133,7 +139,7 @@ attachToExportItem index expInfo iface ifaceMap instIfaceMap export =
nubByName fst $ expItemFixities e ++
[ (n',f) | n <- getMainDeclBinder d
, n' <- n : (map fst subDocs ++ patsyn_names)
- , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap]
+ , f <- maybeToList (getFixity n')
] }
where
patsyn_names = concatMap (getMainDeclBinder . fst) patsyns
@@ -152,16 +158,20 @@ attachToExportItem index expInfo iface ifaceMap instIfaceMap export =
let L l r = spanName s ok linst
in L l (Right r)
+-- | Lookup the doc associated with a certain instance
+findInstDoc :: Interface -> IfaceMap -> InstIfaceMap -> Name -> Maybe (MDoc Name)
+findInstDoc iface ifaceMap instIfaceMap = \name ->
+ (Map.lookup name . ifaceDocMap $ iface) <|>
+ (Map.lookup name . ifaceDocMap =<< Map.lookup (nameModule name) ifaceMap) <|>
+ (Map.lookup name . instDocMap =<< Map.lookup (nameModule name) instIfaceMap)
+
+-- | Lookup the fixity associated with a certain name
+findFixity :: Interface -> IfaceMap -> InstIfaceMap -> Name -> Maybe Fixity
+findFixity iface ifaceMap instIfaceMap = \name ->
+ (Map.lookup name . ifaceFixMap $ iface) <|>
+ (Map.lookup name . ifaceFixMap =<< Map.lookup (nameModule name) ifaceMap) <|>
+ (Map.lookup name . instFixMap =<< Map.lookup (nameModule name) instIfaceMap)
-instLookup :: (InstalledInterface -> Map.Map Name a) -> Name
- -> Interface -> IfaceMap -> InstIfaceMap -> Maybe a
-instLookup f name iface ifaceMap instIfaceMap =
- case Map.lookup name (f $ toInstalledIface iface) of
- res@(Just _) -> res
- Nothing -> do
- let ifaceMaps = Map.union (fmap toInstalledIface ifaceMap) instIfaceMap
- iface' <- Map.lookup (nameModule name) ifaceMaps
- Map.lookup name (f iface')
--------------------------------------------------------------------------------
-- Collecting and sorting instances
@@ -211,13 +221,6 @@ instFam FamInst { fi_fam = n, fi_tys = ts, fi_rhs = t }
= (map argCount ts, n, map simplify ts, argCount t, simplify t)
-funTyConName :: Name
-funTyConName = mkWiredInName gHC_PRIM
- (mkOccNameFS tcName FSLIT("(->)"))
- funTyConKey
- (ATyCon funTyCon) -- Relevant TyCon
- BuiltInSyntax
-
--------------------------------------------------------------------------------
-- Filtering hidden instances
--------------------------------------------------------------------------------
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 146c3cc8..d89efb5a 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -20,27 +20,21 @@
module Haddock.Interface.Create (createInterface) where
import Documentation.Haddock.Doc (metaDocAppend)
-import Documentation.Haddock.Utf8 as Utf8
import Haddock.Types
import Haddock.Options
import Haddock.GhcUtils
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 Data.Bifunctor
import Data.Bitraversable
-import qualified Data.ByteString as BS
import qualified Data.Map as M
import Data.Map (Map)
import Data.List
import Data.Maybe
import Data.Ord
import Control.Applicative
-import Control.Exception (evaluate)
import Control.Monad
import Data.Traversable
@@ -59,9 +53,8 @@ import Bag
import RdrName
import TcRnTypes
import FastString ( unpackFS, fastStringToByteString)
-import BasicTypes ( StringLiteral(..), SourceText(..) )
+import BasicTypes ( StringLiteral(..), SourceText(..), PromotionFlag(..) )
import qualified Outputable as O
-import HsDecls ( getConArgs )
-- | Use a 'TypecheckedModule' to produce an 'Interface'.
@@ -117,7 +110,7 @@ createInterface tm flags modMap instIfaceMap = do
let declsWithDocs = topDecls group_
- exports0 = fmap (reverse . map (first unLoc)) mayExports
+ exports0 = fmap (map (first unLoc)) mayExports
exports
| OptIgnoreExports `elem` opts = Nothing
| otherwise = exports0
@@ -170,8 +163,6 @@ createInterface tm flags modMap instIfaceMap = do
modWarn <- liftErrMsg (moduleWarning dflags gre warnings)
- tokenizedSrc <- mkMaybeTokenizedSrc dflags flags tm
-
return $! Interface {
ifaceMod = mdl
, ifaceIsSig = is_sig
@@ -197,7 +188,8 @@ createInterface tm flags modMap instIfaceMap = do
, ifaceRnOrphanInstances = [] -- Filled in `renameInterface`
, ifaceHaddockCoverage = coverage
, ifaceWarningMap = warningMap
- , ifaceTokenizedSrc = tokenizedSrc
+ , ifaceHieFile = Just $ ml_hie_file $ ms_location ms
+ , ifaceDynFlags = dflags
}
@@ -899,7 +891,7 @@ hiDecl dflags t = do
Nothing -> do
liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t]
return Nothing
- Just x -> case tyThingToLHsDecl x of
+ Just x -> case tyThingToLHsDecl ShowRuntimeRep x of
Left m -> liftErrMsg (tell [bugWarn m]) >> return Nothing
Right (m, t') -> liftErrMsg (tell $ map bugWarn m)
>> return (Just $ noLoc t')
@@ -1077,8 +1069,8 @@ extractDecl declMap name decl
TyClD _ d@DataDecl {} ->
let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d))
in if isDataConName name
- then SigD noExt <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d))
- else SigD noExt <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d))
+ then SigD noExt <$> extractPatternSyn name n (map HsValArg tyvar_tys) (dd_cons (tcdDataDefn d))
+ else SigD noExt <$> extractRecSel name n (map HsValArg tyvar_tys) (dd_cons (tcdDataDefn d))
TyClD _ FamDecl {}
| isValName name
, Just (famInst:_) <- M.lookup name declMap
@@ -1113,10 +1105,11 @@ extractDecl declMap name decl
in case matches of
[d0] -> extractDecl declMap name (noLoc . InstD noExt $ DataFamInstD noExt d0)
_ -> error "internal: extractDecl (ClsInstD)"
- _ -> error "internal: extractDecl"
-
+ _ -> O.pprPanic "extractDecl" $
+ O.text "Unhandled decl for" O.<+> O.ppr name O.<> O.text ":"
+ O.$$ O.nest 4 (O.ppr decl)
-extractPatternSyn :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn
+extractPatternSyn :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn
extractPatternSyn nm t tvs cons =
case filter matches cons of
[] -> error "extractPatternSyn: constructor pattern not found"
@@ -1144,9 +1137,13 @@ extractPatternSyn nm t tvs cons =
data_ty con
| ConDeclGADT{} <- con = con_res_ty con
- | otherwise = foldl' (\x y -> noLoc (HsAppTy noExt x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs
+ | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs
+ where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn
+ mkAppTyArg f (HsValArg ty) = HsAppTy noExt f ty
+ mkAppTyArg f (HsTypeArg ki) = HsAppKindTy noExt f ki
+ mkAppTyArg f (HsArgPar _) = HsParTy noExt f
-extractRecSel :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn]
+extractRecSel :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn]
-> LSig GhcRn
extractRecSel _ _ _ [] = error "extractRecSel: selector not found"
@@ -1162,7 +1159,11 @@ extractRecSel nm t tvs (L _ con : rest) =
data_ty
-- ResTyGADT _ ty <- con_res con = ty
| ConDeclGADT{} <- con = con_res_ty con
- | otherwise = foldl' (\x y -> noLoc (HsAppTy noExt x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs
+ | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs
+ where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn
+ mkAppTyArg f (HsValArg ty) = HsAppTy noExt f ty
+ mkAppTyArg f (HsTypeArg ki) = HsAppKindTy noExt f ki
+ mkAppTyArg f (HsArgPar _) = HsParTy noExt f
-- | Keep export items with docs.
pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn]
@@ -1192,34 +1193,6 @@ seqList :: [a] -> ()
seqList [] = ()
seqList (x : xs) = x `seq` seqList xs
-mkMaybeTokenizedSrc :: DynFlags -> [Flag] -> TypecheckedModule
- -> ErrMsgGhc (Maybe [RichToken])
-mkMaybeTokenizedSrc dflags flags tm
- | Flag_HyperlinkedSource `elem` flags = case renamedSource tm of
- Just src -> do
- tokens <- liftGhcToErrMsgGhc (liftIO (mkTokenizedSrc dflags 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 :: DynFlags -> ModSummary -> RenamedSource -> IO [RichToken]
-mkTokenizedSrc dflags ms src = do
- -- make sure to read the whole file at once otherwise
- -- we run out of file descriptors (see #495)
- rawSrc <- BS.readFile (msHsFilePath ms) >>= evaluate
- let tokens = Hyperlinker.parse dflags filepath (Utf8.decodeUtf8 rawSrc)
- return $ Hyperlinker.enrich src tokens
- where
- filepath = msHsFilePath ms
-
-- | Find a stand-alone documentation comment by its name.
findNamedDoc :: String -> [HsDecl GhcRn] -> ErrMsgM (Maybe HsDocString)
findNamedDoc name = search
diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs
index 636d3e19..a9834fa0 100644
--- a/haddock-api/src/Haddock/Interface/Json.hs
+++ b/haddock-api/src/Haddock/Interface/Json.hs
@@ -62,7 +62,10 @@ jsonMDoc MetaDoc{..} =
]
jsonDoc :: Doc Name -> JsonDoc
-jsonDoc doc = jsonString (show (bimap (moduleNameString . fst) nameStableString doc))
+jsonDoc doc = jsonString (show (bimap showModName showName doc))
+ where
+ showModName = showWrapped (moduleNameString . fst)
+ showName = showWrapped nameStableString
jsonModule :: Module -> JsonDoc
jsonModule = JSString . moduleStableString
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index b6913012..0b40ed3c 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -19,9 +19,9 @@ module Haddock.Interface.LexParseRn
, processModuleHeader
) where
-import Avail
import Control.Arrow
import Control.Monad
+import Data.Functor (($>))
import Data.List
import Data.Ord
import Documentation.Haddock.Doc (metaDocConcat)
@@ -34,8 +34,8 @@ import Haddock.Types
import Name
import Outputable ( showPpr, showSDoc )
import RdrName
+import RdrHsSyn (setRdrNameSpace)
import EnumSet
-import RnEnv (dataTcOccs)
processDocStrings :: DynFlags -> Maybe Package -> GlobalRdrEnv -> [HsDocString]
-> ErrMsgM (Maybe (MDoc Name))
@@ -89,24 +89,38 @@ processModuleHeader dflags pkgName gre safety mayStr = do
-- fallbacks in case we can't locate the identifiers.
--
-- See the comments in the source for implementation commentary.
-rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> ErrMsgM (Doc Name)
+rename :: DynFlags -> GlobalRdrEnv -> Doc NsRdrName -> ErrMsgM (Doc Name)
rename dflags gre = rn
where
rn d = case d of
DocAppend a b -> DocAppend <$> rn a <*> rn b
DocParagraph doc -> DocParagraph <$> rn doc
- DocIdentifier x -> do
+ DocIdentifier i -> do
+ let NsRdrName ns x = unwrap i
+ occ = rdrNameOcc x
+ isValueName = isDataOcc occ || isVarOcc occ
+
+ let valueNsChoices | isValueName = [x]
+ | otherwise = [] -- is this ever possible?
+ typeNsChoices | isValueName = [setRdrNameSpace x tcName]
+ | otherwise = [x]
+
-- Generate the choices for the possible kind of thing this
- -- is.
- let choices = dataTcOccs x
+ -- is. We narrow down the possibilities with the namespace (if
+ -- there is one).
+ let choices = case ns of
+ Value -> valueNsChoices
+ Type -> typeNsChoices
+ None -> valueNsChoices ++ typeNsChoices
-- Lookup any GlobalRdrElts that match the choices.
case concatMap (\c -> lookupGRE_RdrName c gre) choices of
-- We found no names in the env so we start guessing.
[] ->
case choices of
- -- This shouldn't happen as 'dataTcOccs' always returns at least its input.
- [] -> pure (DocMonospaced (DocString (showPpr dflags x)))
+ -- The only way this can happen is if a value namespace was
+ -- specified on something that cannot be a value.
+ [] -> invalidValue dflags i
-- There was nothing in the environment so we need to
-- pick some default from what's available to us. We
@@ -116,14 +130,14 @@ rename dflags gre = rn
-- type constructor names (such as in #253). So now we
-- only get type constructor links if they are actually
-- in scope.
- a:_ -> outOfScope dflags a
+ a:_ -> outOfScope dflags ns (i $> a)
-- There is only one name in the environment that matches so
-- use it.
- [a] -> pure (DocIdentifier (gre_name a))
+ [a] -> pure (DocIdentifier (i $> gre_name a))
-- There are multiple names available.
- gres -> ambiguous dflags x gres
+ gres -> ambiguous dflags i gres
DocWarning doc -> DocWarning <$> rn doc
DocEmphasis doc -> DocEmphasis <$> rn doc
@@ -135,7 +149,7 @@ rename dflags gre = rn
DocCodeBlock doc -> DocCodeBlock <$> rn doc
DocIdentifierUnchecked x -> pure (DocIdentifierUnchecked x)
DocModule str -> pure (DocModule str)
- DocHyperlink l -> pure (DocHyperlink l)
+ DocHyperlink (Hyperlink u l) -> DocHyperlink . Hyperlink u <$> traverse rn l
DocPic str -> pure (DocPic str)
DocMathInline str -> pure (DocMathInline str)
DocMathDisplay str -> pure (DocMathDisplay str)
@@ -155,19 +169,25 @@ rename dflags gre = rn
-- 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 -> ErrMsgM (Doc a)
-outOfScope dflags x =
- case x of
- Unqual occ -> warnAndMonospace occ
- Qual mdl occ -> pure (DocIdentifierUnchecked (mdl, occ))
- Orig _ occ -> warnAndMonospace occ
- Exact name -> warnAndMonospace name -- Shouldn't happen since x is out of scope
+outOfScope :: DynFlags -> Namespace -> Wrap RdrName -> ErrMsgM (Doc a)
+outOfScope dflags ns x =
+ case unwrap x of
+ Unqual occ -> warnAndMonospace (x $> occ)
+ Qual mdl occ -> pure (DocIdentifierUnchecked (x $> (mdl, occ)))
+ Orig _ occ -> warnAndMonospace (x $> occ)
+ Exact name -> warnAndMonospace (x $> name) -- Shouldn't happen since x is out of scope
where
+ prefix = case ns of
+ Value -> "the value "
+ Type -> "the type "
+ None -> ""
+
warnAndMonospace a = do
- tell ["Warning: '" ++ showPpr dflags a ++ "' is out of scope.\n" ++
+ let a' = showWrapped (showPpr dflags) a
+ tell ["Warning: " ++ prefix ++ "'" ++ a' ++ "' is out of scope.\n" ++
" If you qualify the identifier, haddock can try to link it anyway."]
- pure (monospaced a)
- monospaced a = DocMonospaced (DocString (showPpr dflags a))
+ pure (monospaced a')
+ monospaced = DocMonospaced . DocString
-- | Handle ambiguous identifiers.
--
@@ -175,26 +195,39 @@ outOfScope dflags x =
--
-- Emits a warning if the 'GlobalRdrElts's don't belong to the same type or class.
ambiguous :: DynFlags
- -> RdrName
+ -> Wrap NsRdrName
-> [GlobalRdrElt] -- ^ More than one @gre@s sharing the same `RdrName` above.
-> ErrMsgM (Doc Name)
ambiguous dflags x gres = do
- let noChildren = map availName (gresToAvailInfo gres)
- dflt = maximumBy (comparing (isLocalName &&& isTyConName)) noChildren
- msg = "Warning: " ++ x_str ++ " is ambiguous. It is defined\n" ++
- concatMap (\n -> " * " ++ defnLoc n ++ "\n") (map gre_name gres) ++
+ let dflt = maximumBy (comparing (gre_lcl &&& isTyConName . gre_name)) gres
+ msg = "Warning: " ++ showNsRdrName dflags x ++ " is ambiguous. It is defined\n" ++
+ concatMap (\n -> " * " ++ defnLoc n ++ "\n") gres ++
" You may be able to disambiguate the identifier by qualifying it or\n" ++
- " by hiding some imports.\n" ++
- " Defaulting to " ++ x_str ++ " defined " ++ defnLoc dflt
+ " by specifying the type/value namespace explicitly.\n" ++
+ " Defaulting to the one defined " ++ defnLoc dflt
-- TODO: Once we have a syntax for namespace qualification (#667) we may also
-- want to emit a warning when an identifier is a data constructor for a type
-- of the same name, but not the only constructor.
-- For example, for @data D = C | D@, someone may want to reference the @D@
-- constructor.
- when (length noChildren > 1) $ tell [msg]
- pure (DocIdentifier dflt)
+ when (length (gresToAvailInfo gres) > 1) $ tell [msg]
+ pure (DocIdentifier (x $> gre_name dflt))
+ where
+ defnLoc = showSDoc dflags . pprNameDefnLoc . gre_name
+
+-- | Handle value-namespaced names that cannot be for values.
+--
+-- Emits a warning that the value-namespace is invalid on a non-value identifier.
+invalidValue :: DynFlags -> Wrap NsRdrName -> ErrMsgM (Doc a)
+invalidValue dflags x = do
+ tell ["Warning: " ++ showNsRdrName dflags x ++ " cannot be value, yet it is\n" ++
+ " namespaced as such. Did you mean to specify a type namespace\n" ++
+ " instead?"]
+ pure (DocMonospaced (DocString (showNsRdrName dflags x)))
+
+-- | Printable representation of a wrapped and namespaced name
+showNsRdrName :: DynFlags -> Wrap NsRdrName -> String
+showNsRdrName dflags = (\p i -> p ++ "'" ++ i ++ "'") <$> prefix <*> ident
where
- isLocalName (nameSrcLoc -> RealSrcLoc {}) = True
- isLocalName _ = False
- x_str = '\'' : showPpr dflags x ++ "'"
- defnLoc = showSDoc dflags . pprNameDefnLoc
+ ident = showWrapped (showPpr dflags . rdrName)
+ prefix = renderNs . namespace . unwrap
diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
index 050901b6..802ea773 100644
--- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
+++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
@@ -16,7 +16,6 @@ import Data.Char
import DynFlags
import Haddock.Parser
import Haddock.Types
-import RdrName
-- -----------------------------------------------------------------------------
-- Parsing module headers
@@ -24,7 +23,7 @@ import RdrName
-- NB. The headers must be given in the order Module, Description,
-- Copyright, License, Maintainer, Stability, Portability, except that
-- any or all may be omitted.
-parseModuleHeader :: DynFlags -> Maybe Package -> String -> (HaddockModInfo RdrName, MDoc RdrName)
+parseModuleHeader :: DynFlags -> Maybe Package -> String -> (HaddockModInfo NsRdrName, MDoc NsRdrName)
parseModuleHeader dflags pkgName str0 =
let
getKey :: String -> String -> (Maybe String,String)
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 1c976410..88238f04 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.Rename
@@ -23,15 +24,15 @@ import GHC hiding (NoLink)
import Name
import Outputable ( panic )
import RdrName (RdrName(Exact))
-import PrelNames (eqTyCon_RDR)
+import TysWiredIn (eqTyCon_RDR)
import Control.Applicative
+import Control.Arrow ( first )
import Control.Monad hiding (mapM)
import Data.List
import qualified Data.Map as Map hiding ( Map )
import Prelude hiding (mapM)
-
renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface
renameInterface dflags renamingEnv warnings iface =
@@ -92,56 +93,53 @@ renameInterface dflags renamingEnv warnings iface =
--------------------------------------------------------------------------------
-- Monad for renaming
---
--- The monad does two things for us: it passes around the environment for
--- renaming, and it returns a list of names which couldn't be found in
--- the environment.
--------------------------------------------------------------------------------
+-- | The monad does two things for us: it passes around the environment for
+-- renaming, and it returns a list of names which couldn't be found in
+-- the environment.
newtype RnM a =
- RnM { unRn :: (Name -> (Bool, DocName)) -- name lookup function
- -> (a,[Name])
+ RnM { unRn :: (Name -> (Bool, DocName))
+ -- Name lookup function. The 'Bool' indicates that if the name
+ -- was \"found\" in the environment.
+
+ -> (a, [Name] -> [Name])
+ -- Value returned, as well as a difference list of the names not
+ -- found
}
instance Monad RnM where
- (>>=) = thenRn
- return = pure
+ m >>= k = RnM $ \lkp -> let (a, out1) = unRn m lkp
+ (b, out2) = unRn (k a) lkp
+ in (b, out1 . out2)
instance Functor RnM where
- fmap f x = do a <- x; return (f a)
+ fmap f (RnM lkp) = RnM (first f . lkp)
instance Applicative RnM where
- pure = returnRn
- (<*>) = ap
-
-returnRn :: a -> RnM a
-returnRn a = RnM (const (a,[]))
-thenRn :: RnM a -> (a -> RnM b) -> RnM b
-m `thenRn` k = RnM (\lkp -> case unRn m lkp of
- (a,out1) -> case unRn (k a) lkp of
- (b,out2) -> (b,out1++out2))
-
-getLookupRn :: RnM (Name -> (Bool, DocName))
-getLookupRn = RnM (\lkp -> (lkp,[]))
-
-outRn :: Name -> RnM ()
-outRn name = RnM (const ((),[name]))
+ pure a = RnM (const (a, id))
+ mf <*> mx = RnM $ \lkp -> let (f, out1) = unRn mf lkp
+ (x, out2) = unRn mx lkp
+ in (f x, out1 . out2)
+-- | Look up a 'Name' in the renaming environment.
lookupRn :: Name -> RnM DocName
-lookupRn name = do
- lkp <- getLookupRn
+lookupRn name = RnM $ \lkp ->
case lkp name of
- (False,maps_to) -> do outRn name; return maps_to
- (True, maps_to) -> return maps_to
-
-
-runRnFM :: LinkEnv -> RnM a -> (a,[Name])
-runRnFM env rn = unRn rn lkp
+ (False,maps_to) -> (maps_to, (name :))
+ (True, maps_to) -> (maps_to, id)
+
+-- | Run the renamer action using lookup in a 'LinkEnv' as the lookup function.
+-- Returns the renamed value along with a list of `Name`'s that could not be
+-- renamed because they weren't in the environment.
+runRnFM :: LinkEnv -> RnM a -> (a, [Name])
+runRnFM env rn = let (x, dlist) = unRn rn lkp in (x, dlist [])
where
- lkp n = case Map.lookup n env of
- Nothing -> (False, Undocumented n)
- Just mdl -> (True, Documented n mdl)
+ lkp n | isTyVarName n = (True, Undocumented n)
+ | otherwise = case Map.lookup n env of
+ Nothing -> (False, Undocumented n)
+ Just mdl -> (True, Documented n mdl)
--------------------------------------------------------------------------------
@@ -175,8 +173,8 @@ renameLDocHsSyn :: LHsDocString -> RnM LHsDocString
renameLDocHsSyn = return
-renameDoc :: Traversable t => t Name -> RnM (t DocName)
-renameDoc = traverse rename
+renameDoc :: Traversable t => t (Wrap Name) -> RnM (t (Wrap DocName))
+renameDoc = traverse (traverse rename)
renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName)
renameFnArgsDoc = mapM renameDoc
@@ -185,6 +183,13 @@ renameFnArgsDoc = mapM renameDoc
renameLType :: LHsType GhcRn -> RnM (LHsType DocNameI)
renameLType = mapM renameType
+renameLTypeArg :: LHsTypeArg GhcRn -> RnM (LHsTypeArg DocNameI)
+renameLTypeArg (HsValArg ty) = do { ty' <- renameLType ty
+ ; return $ HsValArg ty' }
+renameLTypeArg (HsTypeArg ki) = do { ki' <- renameLKind ki
+ ; return $ HsTypeArg ki' }
+renameLTypeArg (HsArgPar sp) = return $ HsArgPar sp
+
renameLSigType :: LHsSigType GhcRn -> RnM (LHsSigType DocNameI)
renameLSigType = renameImplicit renameLType
@@ -240,6 +245,11 @@ renameType t = case t of
b' <- renameLType b
return (HsAppTy NoExt a' b')
+ HsAppKindTy _ a b -> do
+ a' <- renameLType a
+ b' <- renameLKind b
+ return (HsAppKindTy NoExt a' b')
+
HsFunTy _ a b -> do
a' <- renameLType a
b' <- renameLType b
@@ -276,7 +286,7 @@ renameType t = case t of
HsExplicitListTy i a b -> HsExplicitListTy i a <$> mapM renameLType b
HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b
HsSpliceTy _ s -> renameHsSpliceTy s
- HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a
+ HsWildCardTy a -> pure (HsWildCardTy a)
-- | Rename splices, but _only_ those that turn out to be for types.
-- I think this is actually safe for our possible inputs:
@@ -311,9 +321,6 @@ renameLContext (L loc context) = do
context' <- mapM renameLType context
return (L loc context')
-renameWildCardInfo :: HsWildCardInfo -> RnM HsWildCardInfo
-renameWildCardInfo (AnonWildCard (L l name)) = return (AnonWildCard (L l name))
-
renameInstHead :: InstHead GhcRn -> RnM (InstHead DocNameI)
renameInstHead InstHead {..} = do
cname <- rename ihdClsName
@@ -600,13 +607,16 @@ renameTyFamInstEqn eqn
rename_ty_fam_eqn
:: FamEqn GhcRn (HsTyPats GhcRn) (LHsType GhcRn)
-> RnM (FamEqn DocNameI (HsTyPats DocNameI) (LHsType DocNameI))
- rename_ty_fam_eqn (FamEqn { feqn_tycon = tc, feqn_pats = pats
- , feqn_fixity = fixity, feqn_rhs = rhs })
+ rename_ty_fam_eqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs
+ , feqn_pats = pats, feqn_fixity = fixity
+ , feqn_rhs = rhs })
= do { tc' <- renameL tc
- ; pats' <- mapM renameLType pats
+ ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs
+ ; pats' <- mapM renameLTypeArg pats
; rhs' <- renameLType rhs
; return (FamEqn { feqn_ext = noExt
, feqn_tycon = tc'
+ , feqn_bndrs = bndrs'
, feqn_pats = pats'
, feqn_fixity = fixity
, feqn_rhs = rhs' }) }
@@ -620,6 +630,7 @@ renameLTyFamDefltEqn (L loc (FamEqn { feqn_tycon = tc, feqn_pats = tvs
; rhs' <- renameLType rhs
; return (L loc (FamEqn { feqn_ext = noExt
, feqn_tycon = tc'
+ , feqn_bndrs = Nothing -- this is always Nothing
, feqn_pats = tvs'
, feqn_fixity = fixity
, feqn_rhs = rhs' })) }
@@ -633,13 +644,16 @@ renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })
rename_data_fam_eqn
:: FamEqn GhcRn (HsTyPats GhcRn) (HsDataDefn GhcRn)
-> RnM (FamEqn DocNameI (HsTyPats DocNameI) (HsDataDefn DocNameI))
- rename_data_fam_eqn (FamEqn { feqn_tycon = tc, feqn_pats = pats
- , feqn_fixity = fixity, feqn_rhs = defn })
+ rename_data_fam_eqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs
+ , feqn_pats = pats, feqn_fixity = fixity
+ , feqn_rhs = defn })
= do { tc' <- renameL tc
- ; pats' <- mapM renameLType pats
+ ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs
+ ; pats' <- mapM renameLTypeArg pats
; defn' <- renameDataDefn defn
; return (FamEqn { feqn_ext = noExt
, feqn_tycon = tc'
+ , feqn_bndrs = bndrs'
, feqn_pats = pats'
, feqn_fixity = fixity
, feqn_rhs = defn' }) }
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 30931c26..6fd528af 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -15,6 +15,8 @@ import Haddock.Types
import GHC
import Name
import FastString
+import TysPrim ( funTyConName )
+import TysWiredIn ( listTyConName )
import Control.Monad
import Control.Monad.Trans.State
@@ -47,14 +49,13 @@ specialize specs = go spec_map0
-- one by one, we should avoid infinite loops.
spec_map0 = foldr (\(n,t) acc -> Map.insert n (go acc t) acc) mempty specs
+{-# SPECIALIZE specialize :: [(Name, HsType GhcRn)] -> HsType GhcRn -> HsType GhcRn #-}
-- | 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 :: Data a
- => LHsQTyVars GhcRn -> [HsType GhcRn]
- -> a -> a
+specializeTyVarBndrs :: LHsQTyVars GhcRn -> [HsType GhcRn] -> HsType GhcRn -> HsType GhcRn
specializeTyVarBndrs bndrs typs =
specialize $ zip bndrs' typs
where
@@ -64,11 +65,12 @@ specializeTyVarBndrs bndrs typs =
bname (XTyVarBndr _) = error "haddock:specializeTyVarBndrs"
+
specializePseudoFamilyDecl :: LHsQTyVars GhcRn -> [HsType GhcRn]
-> PseudoFamilyDecl GhcRn
-> PseudoFamilyDecl GhcRn
specializePseudoFamilyDecl bndrs typs decl =
- decl {pfdTyVars = map (specializeTyVarBndrs bndrs typs) (pfdTyVars decl)}
+ decl {pfdTyVars = map (fmap (specializeTyVarBndrs bndrs typs)) (pfdTyVars decl)}
specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn]
-> Sig GhcRn
@@ -110,10 +112,7 @@ sugar = sugarOperators . sugarTuples . sugarLists
sugarLists :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p)
sugarLists (HsAppTy _ (L _ (HsTyVar _ _ (L _ name))) ltyp)
- | isBuiltInSyntax name' && strName == "[]" = HsListTy NoExt ltyp
- where
- name' = getName name
- strName = occNameString . nameOccName $ name'
+ | getName name == listTyConName = HsListTy NoExt ltyp
sugarLists typ = typ
@@ -127,7 +126,7 @@ sugarTuples typ =
| isBuiltInSyntax name' && suitable = HsTupleTy NoExt HsBoxedTuple apps
where
name' = getName name
- strName = occNameString . nameOccName $ name'
+ strName = getOccString name
suitable = case parseTupleArity strName of
Just arity -> arity == length apps
Nothing -> False
@@ -137,7 +136,7 @@ sugarTuples typ =
sugarOperators :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p)
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 NoExt la lb
+ | funTyConName == name' = HsFunTy NoExt la lb
where
name' = getName name
sugarOperators typ = typ
@@ -182,7 +181,7 @@ parseTupleArity _ = Nothing
type NameRep = FastString
getNameRep :: NamedThing name => name -> NameRep
-getNameRep = occNameFS . getOccName
+getNameRep = getOccFS
nameRepString :: NameRep -> String
nameRepString = unpackFS
@@ -256,6 +255,7 @@ renameType (HsQualTy x lctxt lt) =
renameType (HsTyVar x ip name) = HsTyVar x ip <$> located renameName name
renameType t@(HsStarTy _ _) = pure t
renameType (HsAppTy x lf la) = HsAppTy x <$> renameLType lf <*> renameLType la
+renameType (HsAppKindTy x lt lk) = HsAppKindTy x <$> renameLType lt <*> renameLKind lk
renameType (HsFunTy x la lr) = HsFunTy x <$> renameLType la <*> renameLType lr
renameType (HsListTy x lt) = HsListTy x <$> renameLType lt
renameType (HsTupleTy x srt lt) = HsTupleTy x srt <$> mapM renameLType lt
@@ -281,6 +281,8 @@ renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)
renameLType :: LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn)
renameLType = located renameType
+renameLKind :: LHsKind GhcRn -> Rename (IdP GhcRn) (LHsKind GhcRn)
+renameLKind = renameLType
renameLTypes :: [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn]
renameLTypes = mapM renameLType
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index ce6ecc78..7645b1bb 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -82,8 +82,8 @@ binaryInterfaceMagic = 0xD0Cface
-- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion]
--
binaryInterfaceVersion :: Word16
-#if (__GLASGOW_HASKELL__ >= 805) && (__GLASGOW_HASKELL__ < 807)
-binaryInterfaceVersion = 33
+#if (__GLASGOW_HASKELL__ >= 807) && (__GLASGOW_HASKELL__ < 809)
+binaryInterfaceVersion = 35
binaryInterfaceVersionCompatibility :: [Word16]
binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
@@ -190,8 +190,9 @@ readInterfaceFile :: forall m.
MonadIO m
=> NameCacheAccessor m
-> FilePath
+ -> Bool -- ^ Disable version check. Can cause runtime crash.
-> m (Either String InterfaceFile)
-readInterfaceFile (get_name_cache, set_name_cache) filename = do
+readInterfaceFile (get_name_cache, set_name_cache) filename bypass_checks = do
bh0 <- liftIO $ readBinMem filename
magic <- liftIO $ get bh0
@@ -200,7 +201,8 @@ readInterfaceFile (get_name_cache, set_name_cache) filename = do
case () of
_ | magic /= binaryInterfaceMagic -> return . Left $
"Magic number mismatch: couldn't load interface file: " ++ filename
- | version `notElem` binaryInterfaceVersionCompatibility -> return . Left $
+ | not bypass_checks
+ , (version `notElem` binaryInterfaceVersionCompatibility) -> return . Left $
"Interface file is of wrong version: " ++ filename
| otherwise -> with_name_cache $ \update_nc -> do
@@ -432,7 +434,7 @@ instance Binary Example where
result <- get bh
return (Example expression result)
-instance Binary Hyperlink where
+instance Binary a => Binary (Hyperlink a) where
put_ bh (Hyperlink url label) = do
put_ bh url
put_ bh label
@@ -699,3 +701,28 @@ instance Binary DocName where
name <- get bh
return (Undocumented name)
_ -> error "get DocName: Bad h"
+
+instance Binary n => Binary (Wrap n) where
+ put_ bh (Unadorned n) = do
+ putByte bh 0
+ put_ bh n
+ put_ bh (Parenthesized n) = do
+ putByte bh 1
+ put_ bh n
+ put_ bh (Backticked n) = do
+ putByte bh 2
+ put_ bh n
+
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do
+ name <- get bh
+ return (Unadorned name)
+ 1 -> do
+ name <- get bh
+ return (Parenthesized name)
+ 2 -> do
+ name <- get bh
+ return (Backticked name)
+ _ -> error "get Wrap: Bad h"
diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
index bdc98406..e314bbd0 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -84,6 +84,7 @@ data Flag
| Flag_Version
| Flag_CompatibleInterfaceVersions
| Flag_InterfaceVersion
+ | Flag_BypassInterfaceVersonCheck
| Flag_UseContents String
| Flag_GenContents
| Flag_UseIndex String
@@ -175,6 +176,8 @@ options backwardsCompat =
"output compatible interface file versions and exit",
Option [] ["interface-version"] (NoArg Flag_InterfaceVersion)
"output interface file version and exit",
+ Option [] ["bypass-interface-version-check"] (NoArg Flag_BypassInterfaceVersonCheck)
+ "bypass the interface file version check (dangerous)",
Option ['v'] ["verbosity"] (ReqArg Flag_Verbosity "VERBOSITY")
"set verbosity level",
Option [] ["use-contents"] (ReqArg Flag_UseContents "URL")
@@ -186,7 +189,7 @@ options backwardsCompat =
Option [] ["gen-index"] (NoArg Flag_GenIndex)
"generate an HTML index from specified\ninterfaces",
Option [] ["ignore-all-exports"] (NoArg Flag_IgnoreAllExports)
- "behave as if all modules have the\nignore-exports atribute",
+ "behave as if all modules have the\nignore-exports attribute",
Option [] ["hide"] (ReqArg Flag_HideModule "MODULE")
"behave as if MODULE has the hide attribute",
Option [] ["show"] (ReqArg Flag_ShowModule "MODULE")
diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs
index 58500f1b..6d5dc103 100644
--- a/haddock-api/src/Haddock/Parser.hs
+++ b/haddock-api/src/Haddock/Parser.hs
@@ -1,8 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE StandaloneDeriving
- , FlexibleInstances, UndecidableInstances
- , IncoherentInstances #-}
-{-# LANGUAGE LambdaCase #-}
-- |
-- Module : Haddock.Parser
-- Copyright : (c) Mateusz Kowalczyk 2013,
@@ -19,26 +14,33 @@ module Haddock.Parser ( parseParas
) where
import qualified Documentation.Haddock.Parser as P
-import DynFlags (DynFlags)
-import FastString (mkFastString)
import Documentation.Haddock.Types
-import Lexer (mkPState, unP, ParseResult(POk))
-import Parser (parseIdentifier)
-import RdrName (RdrName)
-import SrcLoc (mkRealSrcLoc, unLoc)
-import StringBuffer (stringToStringBuffer)
+import Haddock.Types
-parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod RdrName
+import DynFlags ( DynFlags )
+import FastString ( fsLit )
+import Lexer ( mkPState, unP, ParseResult(POk) )
+import Parser ( parseIdentifier )
+import SrcLoc ( mkRealSrcLoc, GenLocated(..) )
+import StringBuffer ( stringToStringBuffer )
+
+
+parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod (Wrap NsRdrName)
parseParas d p = overDoc (P.overIdentifier (parseIdent d)) . P.parseParas p
-parseString :: DynFlags -> String -> DocH mod RdrName
+parseString :: DynFlags -> String -> DocH mod (Wrap NsRdrName)
parseString d = P.overIdentifier (parseIdent d) . P.parseString
-parseIdent :: DynFlags -> String -> Maybe RdrName
-parseIdent dflags str0 =
- let buffer = stringToStringBuffer str0
- realSrcLc = mkRealSrcLoc (mkFastString "<unknown file>") 0 0
+parseIdent :: DynFlags -> Namespace -> String -> Maybe (Wrap NsRdrName)
+parseIdent dflags ns str0 =
+ let buffer = stringToStringBuffer str1
+ realSrcLc = mkRealSrcLoc (fsLit "<unknown file>") 0 0
pstate = mkPState dflags buffer realSrcLc
+ (wrap,str1) = case str0 of
+ '(' : s@(c : _) | c /= ',', c /= ')' -- rule out tuple names
+ -> (Parenthesized, init s)
+ '`' : s@(_ : _) -> (Backticked, init s)
+ _ -> (Unadorned, str0)
in case unP parseIdentifier pstate of
- POk _ name -> Just (unLoc name)
+ POk _ (L _ name) -> Just (wrap (NsRdrName ns name))
_ -> Nothing
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 6da45a3b..cd4ac1a1 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -1,6 +1,8 @@
{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
+{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
@@ -28,23 +30,19 @@ module Haddock.Types (
import Control.Exception
import Control.Arrow hiding ((<+>))
import Control.DeepSeq
+import Control.Monad (ap)
import Control.Monad.IO.Class (MonadIO(..))
-import Data.Typeable
+import Data.Typeable (Typeable)
import Data.Map (Map)
import Data.Data (Data)
-import qualified Data.Map as Map
import Documentation.Haddock.Types
-import BasicTypes (Fixity(..))
+import BasicTypes (Fixity(..), PromotionFlag(..))
-import GHC hiding (NoLink)
+import GHC
import DynFlags (Language)
import qualified GHC.LanguageExtensions as LangExt
import OccName
-import Outputable
-import Control.Applicative (Applicative(..))
-import Control.Monad (ap)
-
-import Haddock.Backends.Hyperlinker.Types
+import Outputable hiding ((<>))
-----------------------------------------------------------------------------
-- * Convenient synonyms
@@ -143,7 +141,8 @@ data Interface = Interface
-- | Tokenized source code of module (avaliable if Haddock is invoked with
-- source generation flag).
- , ifaceTokenizedSrc :: !(Maybe [RichToken])
+ , ifaceHieFile :: !(Maybe FilePath)
+ , ifaceDynFlags :: !DynFlags
}
type WarningMap = Map Name (Doc Name)
@@ -274,7 +273,7 @@ type DocForDecl name = (Documentation name, FnArgsDoc name)
noDocForDecl :: DocForDecl name
-noDocForDecl = (Documentation Nothing Nothing, Map.empty)
+noDocForDecl = (Documentation Nothing Nothing, mempty)
-----------------------------------------------------------------------------
@@ -285,6 +284,12 @@ noDocForDecl = (Documentation Nothing Nothing, Map.empty)
-- | Type of environment used to cross-reference identifiers in the syntax.
type LinkEnv = Map Name Module
+-- | An 'RdrName' tagged with some type/value namespace information.
+data NsRdrName = NsRdrName
+ { namespace :: !Namespace
+ , rdrName :: !RdrName
+ }
+
-- | Extends 'Name' with cross-reference information.
data DocName
= Documented Name Module
@@ -329,6 +334,26 @@ instance SetName DocName where
setName name' (Documented _ mdl) = Documented name' mdl
setName name' (Undocumented _) = Undocumented name'
+-- | Adds extra "wrapper" information to a name.
+--
+-- This is to work around the fact that most name types in GHC ('Name', 'RdrName',
+-- 'OccName', ...) don't include backticks or parens.
+data Wrap n
+ = Unadorned { unwrap :: n } -- ^ don't do anything to the name
+ | Parenthesized { unwrap :: n } -- ^ add parentheses around the name
+ | Backticked { unwrap :: n } -- ^ add backticks around the name
+ deriving (Show, Functor, Foldable, Traversable)
+
+-- | Useful for debugging
+instance Outputable n => Outputable (Wrap n) where
+ ppr (Unadorned n) = ppr n
+ ppr (Parenthesized n) = hcat [ char '(', ppr n, char ')' ]
+ ppr (Backticked n) = hcat [ char '`', ppr n, char '`' ]
+
+showWrapped :: (a -> String) -> Wrap a -> String
+showWrapped f (Unadorned n) = f n
+showWrapped f (Parenthesized n) = "(" ++ f n ++ ")"
+showWrapped f (Backticked n) = "`" ++ f n ++ "`"
-----------------------------------------------------------------------------
@@ -424,10 +449,10 @@ instance NamedThing name => NamedThing (InstOrigin name) where
type LDoc id = Located (Doc id)
-type Doc id = DocH (ModuleName, OccName) id
-type MDoc id = MetaDoc (ModuleName, OccName) id
+type Doc id = DocH (Wrap (ModuleName, OccName)) (Wrap id)
+type MDoc id = MetaDoc (Wrap (ModuleName, OccName)) (Wrap id)
-type DocMarkup id a = DocMarkupH (ModuleName, OccName) id a
+type DocMarkup id a = DocMarkupH (Wrap (ModuleName, OccName)) id a
instance (NFData a, NFData mod)
=> NFData (DocH mod a) where
@@ -467,7 +492,7 @@ instance NFData ModuleName where rnf x = seq x ()
instance NFData id => NFData (Header id) where
rnf (Header a b) = a `deepseq` b `deepseq` ()
-instance NFData Hyperlink where
+instance NFData id => NFData (Hyperlink id) where
rnf (Hyperlink a b) = a `deepseq` b `deepseq` ()
instance NFData Picture where
@@ -674,6 +699,7 @@ type instance XQualTy DocNameI = NoExt
type instance XTyVar DocNameI = NoExt
type instance XStarTy DocNameI = NoExt
type instance XAppTy DocNameI = NoExt
+type instance XAppKindTy DocNameI = NoExt
type instance XFunTy DocNameI = NoExt
type instance XListTy DocNameI = NoExt
type instance XTupleTy DocNameI = NoExt
@@ -689,7 +715,7 @@ type instance XRecTy DocNameI = NoExt
type instance XExplicitListTy DocNameI = NoExt
type instance XExplicitTupleTy DocNameI = NoExt
type instance XTyLit DocNameI = NoExt
-type instance XWildCardTy DocNameI = HsWildCardInfo
+type instance XWildCardTy DocNameI = NoExt
type instance XXType DocNameI = NewHsTypeX
type instance XUserTyVar DocNameI = NoExt
@@ -742,3 +768,19 @@ type instance XHsWC DocNameI _ = NoExt
type instance XHsQTvs DocNameI = NoExt
type instance XConDeclField DocNameI = NoExt
+type instance XXPat DocNameI = Located (Pat DocNameI)
+
+type instance SrcSpanLess (LPat DocNameI) = Pat DocNameI
+instance HasSrcSpan (LPat DocNameI) where
+ -- NB: The following chooses the behaviour of the outer location
+ -- wrapper replacing the inner ones.
+ composeSrcSpan (L sp p) = if sp == noSrcSpan
+ then p
+ else XPat (L sp (stripSrcSpanPat p))
+ -- NB: The following only returns the top-level location, if any.
+ decomposeSrcSpan (XPat (L sp p)) = L sp (stripSrcSpanPat p)
+ decomposeSrcSpan p = L noSrcSpan p
+
+stripSrcSpanPat :: LPat DocNameI -> Pat DocNameI
+stripSrcSpanPat (XPat (L _ p)) = stripSrcSpanPat p
+stripSrcSpanPat p = p
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index c2cdddf7..dda42cea 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -33,6 +33,7 @@ module Haddock.Utils (
-- * Miscellaneous utilities
getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr,
+ writeUtf8File, withTempDir,
-- * HTML cross reference mapping
html_xrefs_ref, html_xrefs_ref',
@@ -60,9 +61,10 @@ import Documentation.Haddock.Doc (emptyMetaDoc)
import Haddock.Types
import Haddock.GhcUtils
+import BasicTypes ( PromotionFlag(..) )
+import Exception (ExceptionMonad)
import GHC
import Name
-import HsTypes (extFieldOcc)
import Outputable ( panic )
import Control.Monad ( liftM )
@@ -75,7 +77,8 @@ import Data.List ( isSuffixOf )
import Data.Maybe ( mapMaybe )
import System.Environment ( getProgName )
import System.Exit
-import System.IO ( hPutStr, stderr )
+import System.Directory ( createDirectory, removeDirectoryRecursive )
+import System.IO ( hPutStr, hSetEncoding, IOMode(..), stderr, utf8, withFile )
import System.IO.Unsafe ( unsafePerformIO )
import qualified System.FilePath.Posix as HtmlPath
import Distribution.Verbosity
@@ -395,6 +398,19 @@ isAlphaChar c = (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')
isDigitChar c = c >= '0' && c <= '9'
isAlphaNumChar c = isAlphaChar c || isDigitChar c
+-- | Utility to write output to UTF-8 encoded files.
+--
+-- The problem with 'writeFile' is that it picks up its 'TextEncoding' from
+-- 'getLocaleEncoding', and on some platforms (like Windows) this default
+-- encoding isn't enough for the characters we want to write.
+writeUtf8File :: FilePath -> String -> IO ()
+writeUtf8File filepath contents = withFile filepath WriteMode $ \h -> do
+ hSetEncoding h utf8
+ hPutStr h contents
+
+withTempDir :: (ExceptionMonad m) => FilePath -> m a -> m a
+withTempDir dir = gbracket_ (liftIO $ createDirectory dir)
+ (liftIO $ removeDirectoryRecursive dir)
-----------------------------------------------------------------------------
-- * HTML cross references
diff --git a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs
index 4639253c..ff18cb40 100644
--- a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs
+++ b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs
@@ -1,22 +1,29 @@
+{-# LANGUAGE OverloadedStrings #-}
module Haddock.Backends.Hyperlinker.ParserSpec (main, spec) where
-
import Test.Hspec
import Test.QuickCheck
-import qualified GHC
+import GHC ( runGhc, getSessionDynFlags )
+import DynFlags ( CompilerInfo, DynFlags )
+import SysTools.Info ( getCompilerInfo' )
import Control.Monad.IO.Class
+import Data.String ( fromString )
+import Data.ByteString ( ByteString )
+import qualified Data.ByteString as BS
+
import Haddock (getGhcDirs)
import Haddock.Backends.Hyperlinker.Parser
import Haddock.Backends.Hyperlinker.Types
-withDynFlags :: (GHC.DynFlags -> IO ()) -> IO ()
+withDynFlags :: ((DynFlags, CompilerInfo) -> IO ()) -> IO ()
withDynFlags cont = do
libDir <- fmap snd (getGhcDirs [])
- GHC.runGhc (Just libDir) $ do
- dflags <- GHC.getSessionDynFlags
- liftIO $ cont dflags
+ runGhc (Just libDir) $ do
+ dflags <- getSessionDynFlags
+ cinfo <- liftIO $ getCompilerInfo' dflags
+ liftIO $ cont (dflags, cinfo)
main :: IO ()
@@ -53,51 +60,60 @@ instance Arbitrary NoGhcRewrite where
parseSpec :: Spec
parseSpec = around withDynFlags $ do
- it "is total" $ \dflags ->
- property $ \src -> length (parse dflags "" src) `shouldSatisfy` (>= 0)
+ it "is total" $ \(dflags, cinfo) ->
+ property $ \src -> length (parse cinfo dflags "" (fromString src)) `shouldSatisfy` (>= 0)
- it "retains file layout" $ \dflags ->
- property $ \(NoGhcRewrite src) -> concatMap tkValue (parse dflags "" src) == src
+ it "retains file layout" $ \(dflags, cinfo) ->
+ property $ \(NoGhcRewrite src) ->
+ let orig = fromString src
+ lexed = BS.concat (map tkValue (parse cinfo dflags "" orig))
+ in lexed == orig
context "when parsing single-line comments" $ do
- it "should ignore content until the end of line" $ \dflags ->
+ it "should ignore content until the end of line" $ \(dflags, cinfo) ->
shouldParseTo
"-- some very simple comment\nidentifier"
[TkComment, TkSpace, TkIdentifier]
+ cinfo
dflags
- it "should allow endline escaping" $ \dflags ->
+ it "should allow endline escaping" $ \(dflags, cinfo) ->
shouldParseTo
"#define first line\\\nsecond line\\\nand another one"
[TkCpp]
+ cinfo
dflags
context "when parsing multi-line comments" $ do
- it "should support nested comments" $ \dflags ->
+ it "should support nested comments" $ \(dflags, cinfo) ->
shouldParseTo
"{- comment {- nested -} still comment -} {- next comment -}"
[TkComment, TkSpace, TkComment]
+ cinfo
dflags
- it "should distinguish compiler pragma" $ \dflags ->
+ it "should distinguish compiler pragma" $ \(dflags, cinfo) ->
shouldParseTo
"{- comment -}{-# LANGUAGE GADTs #-}{- comment -}"
[TkComment, TkPragma, TkComment]
+ cinfo
dflags
- it "should recognize preprocessor directives" $ \dflags -> do
+ it "should recognize preprocessor directives" $ \(dflags, cinfo) -> do
shouldParseTo
"\n#define foo bar"
- [TkSpace, TkCpp]
+ [TkCpp]
+ cinfo
dflags
shouldParseTo
"x # y"
[TkIdentifier, TkSpace, TkOperator, TkSpace,TkIdentifier]
+ cinfo
dflags
- it "should distinguish basic language constructs" $ \dflags -> do
+ it "should distinguish basic language constructs" $ \(dflags, cinfo) -> do
shouldParseTo
"(* 2) <$> (\"abc\", foo)"
@@ -105,6 +121,7 @@ parseSpec = around withDynFlags $ do
, TkSpace, TkOperator, TkSpace
, TkSpecial, TkString, TkSpecial, TkSpace, TkIdentifier, TkSpecial
]
+ cinfo
dflags
shouldParseTo
@@ -114,6 +131,7 @@ parseSpec = around withDynFlags $ do
, TkIdentifier, TkSpace, TkKeyword, TkSpace
, TkIdentifier, TkSpace, TkOperator, TkSpace, TkIdentifier
]
+ cinfo
dflags
shouldParseTo
@@ -124,9 +142,10 @@ parseSpec = around withDynFlags $ do
, TkSpace, TkKeyword, TkSpace
, TkIdentifier, TkSpace, TkGlyph, TkSpace, TkIdentifier
]
+ cinfo
dflags
- it "should parse do-notation syntax" $ \dflags -> do
+ it "should parse do-notation syntax" $ \(dflags, cinfo) -> do
shouldParseTo
"do { foo <- getLine; putStrLn foo }"
[ TkKeyword, TkSpace, TkSpecial, TkSpace
@@ -134,10 +153,11 @@ parseSpec = around withDynFlags $ do
, TkIdentifier, TkSpecial, TkSpace
, TkIdentifier, TkSpace, TkIdentifier, TkSpace, TkSpecial
]
+ cinfo
dflags
shouldParseTo
- (unlines
+ (fromString $ unlines
[ "do"
, " foo <- getLine"
, " putStrLn foo"
@@ -146,7 +166,10 @@ parseSpec = around withDynFlags $ do
, TkSpace, TkGlyph, TkSpace, TkIdentifier, TkSpace
, TkIdentifier, TkSpace, TkIdentifier, TkSpace
]
+ cinfo
dflags
where
- shouldParseTo :: String -> [TokenType] -> GHC.DynFlags -> Expectation
- shouldParseTo str tokens dflags = map tkType (parse dflags "" str) `shouldBe` tokens
+ shouldParseTo :: ByteString -> [TokenType] -> CompilerInfo -> DynFlags -> Expectation
+ shouldParseTo str tokens cinfo dflags = [ tkType tok
+ | tok <- parse cinfo dflags "" str
+ , not (BS.null (tkValue tok)) ] `shouldBe` tokens