Use .hie files for the Hyperlinker backend

CHANGES.md

@@ -6,6 +6,12 @@
 
  * Support inline markup in markdown-style links (#875)
 
+ * The hyperlinker backend has been re-engineered to use HIE files
+   and display type annotations on expressions (#977)
+
+ * The hyperlinker backend lexer is now more incremental, faster, and
+   more memory efficient (#977)
+
 ## Changes in version 2.22.0
 
  * Make `--package-version` optional for `--hoogle` (#899)

haddock-api/haddock-api.cabal

@@ -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
@@ -187,6 +186,7 @@ test-suite spec
                , directory
                , filepath
                , ghc-boot
+               , ghc-boot-th
                , transformers
 
   build-tool-depends:

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;
+}

haddock-api/src/Haddock.hs

@@ -39,6 +39,7 @@ import Haddock.Version
 import Haddock.InterfaceFile
 import Haddock.Options
 import Haddock.Utils
+import Haddock.GhcUtils (modifySessionDynFlags, setOutputDir)
 
 import Control.Monad hiding (forM_)
 import Data.Foldable (forM_, foldl')
@@ -66,6 +67,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)
@@ -164,14 +167,23 @@ haddockWithGhc ghc args = handleTopExceptions $ do
   -- 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
@@ -202,6 +214,15 @@ haddockWithGhc ghc args = handleTopExceptions $ do
       -- 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")
@@ -221,8 +242,9 @@ 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]
@@ -444,14 +466,10 @@ readInterfaceFiles name_cache_accessor pairs bypass_version_check = 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 $
@@ -482,11 +500,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 =

haddock-api/src/Haddock/Backends/Hyperlinker.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 module Haddock.Backends.Hyperlinker
     ( ppHyperlinkedSource
     , module Haddock.Backends.Hyperlinker.Types
@@ -8,15 +9,24 @@ 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.
 --
@@ -27,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
@@ -39,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 -> writeUtf8File 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.
@@ -63,3 +95,4 @@ highlightScript = "highlight.js"
 -- | Path to default CSS file.
 defaultCssFile :: FilePath -> FilePath
 defaultCssFile libdir = libdir </> "html" </> "solarized.css"
+