Support generating HIE files
[ghc.git] / compiler / backpack / DriverBkp.hs
index 595cb25..e10d6d1 100644 (file)
@@ -18,6 +18,8 @@ module DriverBkp (doBackpack) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 -- In a separate module because it hooks into the parser.
 import BkpSyn
 
@@ -51,6 +53,7 @@ import Util
 
 import qualified GHC.LanguageExtensions as LangExt
 
+import Panic
 import Data.List
 import System.Exit
 import Control.Monad
@@ -63,8 +66,8 @@ import Data.Map (Map)
 import qualified Data.Map as Map
 
 -- | Entry point to compile a Backpack file.
-doBackpack :: FilePath -> Ghc ()
-doBackpack src_filename = do
+doBackpack :: [FilePath] -> Ghc ()
+doBackpack [src_filename] = do
     -- Apply options from file to dflags
     dflags0 <- getDynFlags
     let dflags1 = dflags0
@@ -79,7 +82,7 @@ doBackpack src_filename = do
     buf <- liftIO $ hGetStringBuffer src_filename
     let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great
     case unP parseBackpack (mkPState dflags buf loc) of
-        PFailed span err -> do
+        PFailed span err -> do
             liftIO $ throwOneError (mkPlainErrMsg dflags span err)
         POk _ pkgname_bkp -> do
             -- OK, so we have an LHsUnit PackageName, but we want an
@@ -96,6 +99,8 @@ doBackpack src_filename = do
                                     then compileExe lunit
                                     else compileUnit cid []
                             else typecheckUnit cid insts
+doBackpack _ =
+    throwGhcException (CmdLineError "--backpack can only process a single file")
 
 computeUnitId :: LHsUnit HsComponentId -> (ComponentId, [(ModuleName, Module)])
 computeUnitId (L _ unit) = (cid, [ (r, mkHoleModule r) | r <- reqs ])
@@ -152,6 +157,7 @@ withBkpSession cid insts deps session_type do_this = do
       -- turn on interface writing.  However, if the user also
       -- explicitly passed in `-fno-code`, we DON'T want to write
       -- interfaces unless the user also asked for `-fwrite-interface`.
+      -- See Note [-fno-code mode]
       (case session_type of
         -- Make sure to write interfaces when we are type-checking
         -- indefinite packages.
@@ -180,6 +186,8 @@ withBkpSession cid insts deps session_type do_this = do
         outputFile  = if session_type == ExeSession
                         then outputFile dflags
                         else Nothing,
+        -- Clear the import path so we don't accidentally grab anything
+        importPaths = [],
         -- Synthesized the flags
         packageFlags = packageFlags dflags ++ map (\(uid0, rn) ->
           let uid = unwireUnitId dflags (improveUnitId (getPackageConfigMap dflags) $ renameHoleUnitId dflags (listToUFM insts) uid0)
@@ -282,7 +290,8 @@ buildUnit session cid insts lunit = do
         let hi_dir = expectJust (panic "hiDir Backpack") $ hiDir dflags
             export_mod ms = (ms_mod_name ms, ms_mod ms)
             -- Export everything!
-            mods = [ export_mod ms | ms <- mod_graph, ms_hsc_src ms == HsSrcFile ]
+            mods = [ export_mod ms | ms <- mgModSummaries mod_graph
+                                   , ms_hsc_src ms == HsSrcFile ]
 
         -- Compile relevant only
         hsc_env <- getSession
@@ -303,6 +312,7 @@ buildUnit session cid insts lunit = do
             packageName = compat_pn,
             packageVersion = makeVersion [0],
             unitId = toInstalledUnitId (thisPackage dflags),
+            sourceLibName = Nothing,
             componentId = cid,
             instantiatedWith = insts,
             -- Slight inefficiency here haha
@@ -508,9 +518,9 @@ mkBackpackMsg = do
 -- | 'PprStyle' for Backpack messages; here we usually want the module to
 -- be qualified (so we can tell how it was instantiated.) But we try not
 -- to qualify packages so we can use simple names for them.
-backpackStyle :: PprStyle
-backpackStyle =
-    mkUserStyle
+backpackStyle :: DynFlags -> PprStyle
+backpackStyle dflags =
+    mkUserStyle dflags
         (QueryQualify neverQualifyNames
                       alwaysQualifyModules
                       neverQualifyPackages) AllTheWay
@@ -529,7 +539,8 @@ msgUnitId pk = do
     dflags <- getDynFlags
     level <- getBkpLevel
     liftIO . backpackProgressMsg level dflags
-        $ "Instantiating " ++ renderWithStyle dflags (ppr pk) backpackStyle
+        $ "Instantiating " ++ renderWithStyle dflags (ppr pk)
+                                (backpackStyle dflags)
 
 -- | Message when we include a Backpack unit.
 msgInclude :: (Int,Int) -> UnitId -> BkpM ()
@@ -538,7 +549,7 @@ msgInclude (i,n) uid = do
     level <- getBkpLevel
     liftIO . backpackProgressMsg level dflags
         $ showModuleIndex (i, n) ++ "Including " ++
-          renderWithStyle dflags (ppr uid) backpackStyle
+          renderWithStyle dflags (ppr uid) (backpackStyle dflags)
 
 -- ----------------------------------------------------------------------------
 -- Conversion from PackageName to HsComponentId
@@ -652,7 +663,7 @@ hsunitModuleGraph dflags unit = do
             else fmap Just $ summariseRequirement pn mod_name
 
     -- 3. Return the kaboodle
-    return (nodes ++ req_nodes)
+    return $ mkModuleGraph $ nodes ++ req_nodes
 
 summariseRequirement :: PackageName -> ModuleName -> BkpM ModSummary
 summariseRequirement pn mod_name = do
@@ -666,6 +677,7 @@ summariseRequirement pn mod_name = do
     env <- getBkpEnv
     time <- liftIO $ getModificationUTCTime (bkp_filename env)
     hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
+    hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
     let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1)
 
     mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location
@@ -679,6 +691,7 @@ summariseRequirement pn mod_name = do
         ms_hs_date = time,
         ms_obj_date = Nothing,
         ms_iface_date = hi_timestamp,
+        ms_hie_date = hie_timestamp,
         ms_srcimps = [],
         ms_textual_imps = extra_sig_imports,
         ms_parsed_mod = Just (HsParsedModule {
@@ -701,7 +714,7 @@ summariseRequirement pn mod_name = do
 summariseDecl :: PackageName
               -> HscSource
               -> Located ModuleName
-              -> Maybe (Located (HsModule RdrName))
+              -> Maybe (Located (HsModule GhcPs))
               -> BkpM ModSummary
 summariseDecl pn hsc_src (L _ modname) (Just hsmod) = hsModuleToModSummary pn hsc_src modname hsmod
 summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing
@@ -728,7 +741,7 @@ summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing
 hsModuleToModSummary :: PackageName
                      -> HscSource
                      -> ModuleName
-                     -> Located (HsModule RdrName)
+                     -> Located (HsModule GhcPs)
                      -> BkpM ModSummary
 hsModuleToModSummary pn hsc_src modname
                      hsmod = do
@@ -754,12 +767,13 @@ hsModuleToModSummary pn hsc_src modname
                                 HsSrcFile -> "hs")
     -- DANGEROUS: bootifying can POISON the module finder cache
     let location = case hsc_src of
-                        HsBootFile -> addBootSuffixLocn location0
+                        HsBootFile -> addBootSuffixLocnOut location0
                         _ -> location0
     -- This duplicates a pile of logic in GhcMake
     env <- getBkpEnv
     time <- liftIO $ getModificationUTCTime (bkp_filename env)
     hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
+    hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
 
     -- Also copied from 'getImports'
     let (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
@@ -804,7 +818,8 @@ hsModuleToModSummary pn hsc_src modname
                 }),
             ms_hs_date = time,
             ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS
-            ms_iface_date = hi_timestamp
+            ms_iface_date = hi_timestamp,
+            ms_hie_date = hie_timestamp
         }
 
 -- | Create a new, externally provided hashed unit id from