Support generating HIE files

Adds a `-fenable-ide-info` flag which instructs GHC to generate `.hie`
files (see the wiki page:
https://ghc.haskell.org/trac/ghc/wiki/HIEFiles).

This is a rebased version of Zubin Duggal's (@wz1000) GHC changes for
his GSOC project, as posted here:
https://gist.github.com/wz1000/5ed4ddd0d3e96d6bc75e095cef95363d.

Test Plan: ./validate

Reviewers: bgamari, gershomb, nomeata, alanz, sjakobi

Reviewed By: alanz, sjakobi

Subscribers: alanz, hvr, sjakobi, rwbarton, wz1000, carter

Differential Revision: https://phabricator.haskell.org/D5239

1 files changed, 52 insertions, 16 deletions

diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 9b9edf7d21..c2c912451b 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -85,6 +85,7 @@ module HscMain
 import GhcPrelude
 
 import Data.Data hiding (Fixity, TyCon)
+import Data.Maybe       ( fromJust )
 import Id
 import GHCi             ( addSptEntry )
 import GHCi.RemoteTypes ( ForeignHValue )
@@ -167,10 +168,15 @@ import Data.IORef
 import System.FilePath as FilePath
 import System.Directory
 import System.IO (fixIO)
-import qualified Data.Map as Map
+import qualified Data.Map as M
 import qualified Data.Set as S
 import Data.Set (Set)
 
+import HieAst           ( mkHieFile )
+import HieTypes         ( getAsts, hie_asts )
+import HieBin           ( readHieFile, writeHieFile )
+import HieDebug         ( diffFile, validateScopes )
+
 #include "HsVersions.h"
 
 
@@ -379,8 +385,8 @@ hscParse' mod_summary
                       hpm_module    = rdr_module,
                       hpm_src_files = srcs2,
                       hpm_annotations
-                              = (Map.fromListWith (++) $ annotations pst,
-                                 Map.fromList $ ((noSrcSpan,comment_q pst)
+                              = (M.fromListWith (++) $ annotations pst,
+                                 M.fromList $ ((noSrcSpan,comment_q pst)
                                                  :(annotations_comments pst)))
                    }
 
@@ -392,15 +398,41 @@ hscParse' mod_summary
 
 -- -----------------------------------------------------------------------------
 -- | If the renamed source has been kept, extract it. Dump it if requested.
-extract_renamed_stuff :: TcGblEnv -> Hsc (TcGblEnv, RenamedStuff)
-extract_renamed_stuff tc_result = do
+extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff
+extract_renamed_stuff mod_summary tc_result = do
     let rn_info = getRenamedStuff tc_result
 
     dflags <- getDynFlags
     liftIO $ dumpIfSet_dyn dflags Opt_D_dump_rn_ast "Renamer" $
                            showAstData NoBlankSrcSpan rn_info
 
-    return (tc_result, rn_info)
+    -- Create HIE files
+    when (gopt Opt_WriteHie dflags) $ do
+        hieFile <- mkHieFile mod_summary (tcg_binds tc_result)
+                                         (fromJust rn_info)
+        let out_file = ml_hie_file $ ms_location mod_summary
+        liftIO $ writeHieFile out_file hieFile
+
+        -- Validate HIE files
+        when (gopt Opt_ValidateHie dflags) $ do
+            hs_env <- Hsc $ \e w -> return (e, w)
+            liftIO $ do
+              -- Validate Scopes
+              case validateScopes $ getAsts $ hie_asts hieFile of
+                  [] -> putMsg dflags $ text "Got valid scopes"
+                  xs -> do
+                    putMsg dflags $ text "Got invalid scopes"
+                    mapM_ (putMsg dflags) xs
+              -- Roundtrip testing
+              nc <- readIORef $ hsc_NC hs_env
+              (file', _) <- readHieFile nc out_file
+              case diffFile hieFile file' of
+                [] ->
+                  putMsg dflags $ text "Got no roundtrip errors"
+                xs -> do
+                  putMsg dflags $ text "Got roundtrip errors"
+                  mapM_ (putMsg dflags) xs
+    return rn_info
 
 
 -- -----------------------------------------------------------------------------
@@ -408,22 +440,23 @@ extract_renamed_stuff tc_result = do
 hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule
                    -> IO (TcGblEnv, RenamedStuff)
 hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do
-      tc_result <- hscTypecheck True mod_summary (Just rdr_module)
-      extract_renamed_stuff tc_result
+    tc_result <- hsc_typecheck True mod_summary (Just rdr_module)
+    rn_info <- extract_renamed_stuff mod_summary tc_result
+    return (tc_result, rn_info)
 
+-- | Rename and typecheck a module, but don't return the renamed syntax
 hscTypecheck :: Bool -- ^ Keep renamed source?
              -> ModSummary -> Maybe HsParsedModule
              -> Hsc TcGblEnv
 hscTypecheck keep_rn mod_summary mb_rdr_module = do
-    tc_result <- hscTypecheck' keep_rn mod_summary mb_rdr_module
-    _ <- extract_renamed_stuff tc_result
+    tc_result <- hsc_typecheck keep_rn mod_summary mb_rdr_module
+    _ <- extract_renamed_stuff mod_summary tc_result
     return tc_result
 
-
-hscTypecheck' :: Bool -- ^ Keep renamed source?
+hsc_typecheck :: Bool -- ^ Keep renamed source?
               -> ModSummary -> Maybe HsParsedModule
               -> Hsc TcGblEnv
-hscTypecheck' keep_rn mod_summary mb_rdr_module = do
+hsc_typecheck keep_rn mod_summary mb_rdr_module = do
     hsc_env <- getHscEnv
     let hsc_src = ms_hsc_src mod_summary
         dflags = hsc_dflags hsc_env
@@ -433,6 +466,7 @@ hscTypecheck' keep_rn mod_summary mb_rdr_module = do
         inner_mod = canonicalizeHomeModule dflags mod_name
         src_filename  = ms_hspp_file mod_summary
         real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1
+        keep_rn' = gopt Opt_WriteHie dflags || keep_rn
     MASSERT( moduleUnitId outer_mod == thisPackage dflags )
     if hsc_src == HsigFile && not (isHoleModule inner_mod)
         then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod' real_loc
@@ -440,7 +474,7 @@ hscTypecheck' keep_rn mod_summary mb_rdr_module = do
          do hpm <- case mb_rdr_module of
                     Just hpm -> return hpm
                     Nothing -> hscParse' mod_summary
-            tc_result0 <- tcRnModule' mod_summary keep_rn hpm
+            tc_result0 <- tcRnModule' mod_summary keep_rn' hpm
             if hsc_src == HsigFile
                 then do (iface, _, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 Nothing
                         ioMsgMaybe $
@@ -1411,7 +1445,8 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
   where
     no_loc = ModLocation{ ml_hs_file  = Just filename,
                           ml_hi_file  = panic "hscCompileCmmFile: no hi file",
-                          ml_obj_file = panic "hscCompileCmmFile: no obj file" }
+                          ml_obj_file = panic "hscCompileCmmFile: no obj file",
+                          ml_hie_file = panic "hscCompileCmmFile: no hie file"}
 
 -------------------- Stuff for new code gen ---------------------
 
@@ -1591,7 +1626,8 @@ hscDeclsWithLocation hsc_env0 str source linenumber =
     -- We use a basically null location for iNTERACTIVE
     let iNTERACTIVELoc = ModLocation{ ml_hs_file   = Nothing,
                                       ml_hi_file   = panic "hsDeclsWithLocation:ml_hi_file",
-                                      ml_obj_file  = panic "hsDeclsWithLocation:ml_hi_file"}
+                                      ml_obj_file  = panic "hsDeclsWithLocation:ml_obj_file",
+                                      ml_hie_file  = panic "hsDeclsWithLocation:ml_hie_file" }
     ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv
 
     {- Simplify -}