Merge pull request #4804 from commercialhaskell/haitlahcen-binary-mod…

…ule-interface

Parse .hi files instead of .hi-dump files

package.yaml

@@ -66,6 +66,7 @@ dependencies:
 - generic-deriving
 - hackage-security
 - hashable
+- hi-file-parser
 - hpack
 - hpc
 - http-client

src/Stack/Build/Execute.hs

@@ -2199,9 +2199,8 @@ extraBuildOptions :: (HasEnvConfig env, HasRunner env)
                   => WhichCompiler -> BuildOpts -> RIO env [String]
 extraBuildOptions wc bopts = do
     colorOpt <- appropriateGhcColorFlag
-    let ddumpOpts = " -ddump-hi -ddump-to-file"
-        optsFlag = compilerOptionsCabalFlag wc
-        baseOpts = ddumpOpts ++ maybe "" (" " ++) colorOpt
+    let optsFlag = compilerOptionsCabalFlag wc
+        baseOpts = maybe "" (" " ++) colorOpt
     if toCoverage (boptsTestOpts bopts)
       then do
         hpcIndexDir <- toFilePathNoTrailingSep <$> hpcRelativeDir

src/Stack/Package.hs

@@ -27,14 +27,12 @@ module Stack.Package
   ,applyForceCustomBuild
   ) where
 
-import qualified Data.ByteString.Lazy.Char8 as CL8
-import           Data.List (isPrefixOf, unzip)
+import qualified Data.ByteString.Char8 as B8
+import           Data.List (find, isPrefixOf, unzip)
 import           Data.Maybe (maybe)
 import qualified Data.Map.Strict as M
 import qualified Data.Set as S
 import qualified Data.Text as T
-import qualified Data.Text.Lazy as TL
-import qualified Data.Text.Lazy.Encoding as TLE
 import           Distribution.Compiler
 import           Distribution.ModuleName (ModuleName)
 import qualified Distribution.ModuleName as Cabal
@@ -54,6 +52,7 @@ import           Distribution.Types.MungedPackageName
 import qualified Distribution.Types.UnqualComponentName as Cabal
 import qualified Distribution.Verbosity as D
 import           Distribution.Version (mkVersion, orLaterVersion, anyVersion)
+import qualified HiFileParser as Iface
 import           Path as FL
 import           Path.Extra
 import           Path.IO hiding (findFiles)
@@ -1016,7 +1015,7 @@ resolveFilesAndDeps component dirs names0 = do
         let foundFiles = mapMaybe snd resolved
             foundModules = mapMaybe toResolvedModule resolved
             missingModules = mapMaybe toMissingModule resolved
-        pairs <- mapM (getDependencies component) foundFiles
+        pairs <- mapM (getDependencies component dirs) foundFiles
         let doneModules =
                 S.union
                     doneModules0
@@ -1077,8 +1076,8 @@ resolveFilesAndDeps component dirs names0 = do
 
 -- | Get the dependencies of a Haskell module file.
 getDependencies
-    :: NamedComponent -> DotCabalPath -> RIO Ctx (Set ModuleName, [Path Abs File])
-getDependencies component dotCabalPath =
+    :: NamedComponent -> [Path Abs Dir] -> DotCabalPath -> RIO Ctx (Set ModuleName, [Path Abs File])
+getDependencies component dirs dotCabalPath =
     case dotCabalPath of
         DotCabalModulePath resolvedFile -> readResolvedHi resolvedFile
         DotCabalMainPath resolvedFile -> readResolvedHi resolvedFile
@@ -1088,70 +1087,50 @@ getDependencies component dotCabalPath =
     readResolvedHi resolvedFile = do
         dumpHIDir <- componentOutputDir component <$> asks ctxDistDir
         dir <- asks (parent . ctxFile)
-        case stripProperPrefix dir resolvedFile of
+        let sourceDir = fromMaybe dir $ find (`isProperPrefixOf` resolvedFile) dirs
+            stripSourceDir d = stripProperPrefix d resolvedFile
+        case stripSourceDir sourceDir of
             Nothing -> return (S.empty, [])
             Just fileRel -> do
-                let dumpHIPath =
+                let hiPath =
                         FilePath.replaceExtension
                             (toFilePath (dumpHIDir </> fileRel))
-                            ".dump-hi"
-                dumpHIExists <- liftIO $ D.doesFileExist dumpHIPath
+                            ".hi"
+                dumpHIExists <- liftIO $ D.doesFileExist hiPath
                 if dumpHIExists
-                    then parseDumpHI dumpHIPath
+                    then parseHI hiPath
                     else return (S.empty, [])
 
--- | Parse a .dump-hi file into a set of modules and files.
-parseDumpHI
+-- | Parse a .hi file into a set of modules and files.
+parseHI
     :: FilePath -> RIO Ctx (Set ModuleName, [Path Abs File])
-parseDumpHI dumpHIPath = do
-    dir <- asks (parent . ctxFile)
-    dumpHI <- liftIO $ filterDumpHi <$> fmap CL8.lines (CL8.readFile dumpHIPath)
-    let startModuleDeps =
-            dropWhile (not . ("module dependencies:" `CL8.isPrefixOf`)) dumpHI
-        moduleDeps =
-            S.fromList $
-            mapMaybe (D.simpleParse . TL.unpack . TLE.decodeUtf8) $
-            CL8.words $
-            CL8.concat $
-            CL8.dropWhile (/= ' ') (fromMaybe "" $ listToMaybe startModuleDeps) :
-            takeWhile (" " `CL8.isPrefixOf`) (drop 1 startModuleDeps)
-        thDeps =
-            -- The dependent file path is surrounded by quotes but is not escaped.
-            -- It can be an absolute or relative path.
-                  TL.unpack .
-                  -- Starting with GHC 8.4.3, there's a hash following
-                  -- the path. See
-                  -- https://github.com/yesodweb/yesod/issues/1551
-                  TLE.decodeUtf8 .
-                  CL8.takeWhile (/= '\"') <$>
-            mapMaybe (CL8.stripPrefix "addDependentFile \"") dumpHI
-    thDepsResolved <- liftM catMaybes $ forM thDeps $ \x -> do
-        mresolved <- liftIO (forgivingAbsence (resolveFile dir x)) >>= rejectMissingFile
-        when (isNothing mresolved) $
-            prettyWarnL
-                [ flow "addDependentFile path (Template Haskell) listed in"
-                , style File $ fromString dumpHIPath
-                , flow "does not exist:"
-                , style File $ fromString x
-                ]
-        return mresolved
-    return (moduleDeps, thDepsResolved)
-  where
-    -- | Filtering step fixing RAM usage upon a big dump-hi file. See
-    --   https://github.com/commercialhaskell/stack/issues/4027 It is
-    --   an optional step from a functionality stand-point.
-    filterDumpHi dumpHI =
-        let dl x xs = x ++ xs
-            isLineInteresting (acc, moduleDepsStarted) l
-                | moduleDepsStarted && " " `CL8.isPrefixOf` l =
-                    (acc . dl [l], True)
-                | "module dependencies:" `CL8.isPrefixOf` l =
-                    (acc . dl [l], True)
-                | "addDependentFile \"" `CL8.isPrefixOf` l =
-                    (acc . dl [l], False)
-                | otherwise = (acc, False)
-         in fst (foldl' isLineInteresting (dl [], False) dumpHI) []
-
+parseHI hiPath = do
+  dir <- asks (parent . ctxFile)
+  result <- liftIO $ Iface.fromFile hiPath
+  case result of
+    Left msg -> do
+      prettyWarnL
+        [ flow "Failed to decode module interface:"
+        , style File $ fromString hiPath
+        , flow "Decoding failure:"
+        , style Error $ fromString msg
+        ]
+      pure (S.empty, [])
+    Right iface -> do
+      let moduleNames = fmap (fromString . B8.unpack . fst) . Iface.unList . Iface.dmods . Iface.deps
+          resolveFileDependency file = do
+            resolved <- liftIO (forgivingAbsence (resolveFile dir file)) >>= rejectMissingFile
+            when (isNothing resolved) $
+              prettyWarnL
+              [ flow "Dependent file listed in:"
+              , style File $ fromString hiPath
+              , flow "does not exist:"
+              , style File $ fromString file
+              ]
+            pure resolved
+          resolveUsages = traverse (resolveFileDependency . Iface.unUsage) . Iface.unList . Iface.usage
+      resolvedUsages <- catMaybes <$> resolveUsages iface
+      pure (S.fromList $ moduleNames iface, resolvedUsages)
 
 -- | Try to resolve the list of base names in the given directory by
 -- looking for unique instances of base names applied with the given

stack-lts-12.yaml

@@ -6,6 +6,7 @@ packages:
 - subs/curator
 - subs/http-download
 - subs/rio-prettyprint
+- subs/hi-file-parser
 
 # docker:
 #   enable: true

stack-nightly.yaml

@@ -6,6 +6,7 @@ packages:
 - subs/curator
 - subs/http-download
 - subs/rio-prettyprint
+- subs/hi-file-parser
 
 # docker:
 #   enable: true

stack.yaml

@@ -6,6 +6,7 @@ packages:
 - subs/curator
 - subs/http-download
 - subs/rio-prettyprint
+- subs/hi-file-parser
 
 # docker:
 #   enable: true

subs/hi-file-parser/ChangeLog.md

@@ -0,0 +1,5 @@
+# Changelog for hi-file-parser
+
+## 0.1.0.0
+
+Initial release

subs/hi-file-parser/LICENSE

@@ -0,0 +1,24 @@
+Copyright (c) 2015-2019, Stack contributors
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+    * Redistributions in binary form must reproduce the above copyright
+      notice, this list of conditions and the following disclaimer in the
+      documentation and/or other materials provided with the distribution.
+    * Neither the name of stack nor the
+      names of its contributors may be used to endorse or promote products
+      derived from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL STACK CONTRIBUTORS BE LIABLE FOR ANY
+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

subs/hi-file-parser/README.md

@@ -0,0 +1,11 @@
+# hi-file-parser
+
+Provide data types and functions for parsing the binary `.hi` files produced by
+GHC. Intended to support multiple versions of GHC, so that tooling can:
+
+* Support multiple versions of GHC
+* Avoid linking against the `ghc` library
+* Not need to use `ghc`'s textual dump file format.
+
+Note that this code was written for Stack's usage initially, though it is
+intended to be general purpose.

subs/hi-file-parser/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

subs/hi-file-parser/package.yaml

@@ -0,0 +1,60 @@
+name:                hi-file-parser
+version:             0.1.0.0
+github:              commercialhaskell/stack
+license:             MIT
+author:              Hussein Ait-Lahcen
+maintainer:          michael@snoyman.com
+
+extra-source-files:
+- README.md
+- ChangeLog.md
+- test-files/iface/x64/ghc844/Main.hi
+- test-files/iface/x64/ghc844/X.hi
+- test-files/iface/x64/ghc822/Main.hi
+- test-files/iface/x64/ghc822/X.hi
+- test-files/iface/x64/ghc864/Main.hi
+- test-files/iface/x64/ghc864/X.hi
+- test-files/iface/x32/ghc844/Main.hi
+- test-files/iface/x32/ghc802/Main.hi
+- test-files/iface/x32/ghc7103/Main.hi
+- test-files/iface/x32/ghc822/Main.hi
+
+# Metadata used when publishing your package
+synopsis:            Parser for GHC's hi files
+category:            Development
+
+# To avoid duplicated efforts in documentation and dealing with the
+# complications of embedding Haddock markup inside cabal files, it is
+# common to point users to the README.md file.
+description:         Please see the README on Github at <https://github.com/commercialhaskell/stack/blob/master/subs/hi-file-parser/README.md>
+
+dependencies:
+- base >= 4.10 && < 5
+- binary
+- bytestring
+- rio
+- vector
+
+ghc-options:
+- -Wall
+- -Wcompat
+- -Widentities
+- -Wincomplete-record-updates
+- -Wincomplete-uni-patterns
+- -Wredundant-constraints
+
+library:
+  source-dirs: src
+
+tests:
+  hi-file-parser-test:
+    main:                Spec.hs
+    source-dirs:         test
+    dependencies:
+    - hi-file-parser
+    - hspec
+
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N