diff --git a/package.yaml b/package.yaml index cae12c57b6..55deef23b2 100644 --- a/package.yaml +++ b/package.yaml @@ -66,6 +66,7 @@ dependencies: - generic-deriving - hackage-security - hashable +- hi-file-parser - hpack - hpc - http-client diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 5074c76cf3..de85de9a51 100644 --- a/src/Stack/Build/Execute.hs +++ b/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 diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index 57474f4921..352c6f0199 100644 --- a/src/Stack/Package.hs +++ b/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 diff --git a/stack-lts-12.yaml b/stack-lts-12.yaml index d810ca7327..2c680bb698 100644 --- a/stack-lts-12.yaml +++ b/stack-lts-12.yaml @@ -6,6 +6,7 @@ packages: - subs/curator - subs/http-download - subs/rio-prettyprint +- subs/hi-file-parser # docker: # enable: true diff --git a/stack-nightly.yaml b/stack-nightly.yaml index 738c589a9b..cfa633d56d 100644 --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -6,6 +6,7 @@ packages: - subs/curator - subs/http-download - subs/rio-prettyprint +- subs/hi-file-parser # docker: # enable: true diff --git a/stack.yaml b/stack.yaml index d05c9a8bce..b8918d6ce1 100644 --- a/stack.yaml +++ b/stack.yaml @@ -6,6 +6,7 @@ packages: - subs/curator - subs/http-download - subs/rio-prettyprint +- subs/hi-file-parser # docker: # enable: true diff --git a/subs/hi-file-parser/ChangeLog.md b/subs/hi-file-parser/ChangeLog.md new file mode 100644 index 0000000000..6d30512c88 --- /dev/null +++ b/subs/hi-file-parser/ChangeLog.md @@ -0,0 +1,5 @@ +# Changelog for hi-file-parser + +## 0.1.0.0 + +Initial release diff --git a/subs/hi-file-parser/LICENSE b/subs/hi-file-parser/LICENSE new file mode 100644 index 0000000000..0baab09ec8 --- /dev/null +++ b/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. diff --git a/subs/hi-file-parser/README.md b/subs/hi-file-parser/README.md new file mode 100644 index 0000000000..dd5a64d04d --- /dev/null +++ b/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. diff --git a/subs/hi-file-parser/Setup.hs b/subs/hi-file-parser/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/subs/hi-file-parser/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/subs/hi-file-parser/package.yaml b/subs/hi-file-parser/package.yaml new file mode 100644 index 0000000000..ea6e12b8a0 --- /dev/null +++ b/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 + +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 diff --git a/subs/hi-file-parser/src/HiFileParser.hs b/subs/hi-file-parser/src/HiFileParser.hs new file mode 100644 index 0000000000..83232dfc37 --- /dev/null +++ b/subs/hi-file-parser/src/HiFileParser.hs @@ -0,0 +1,435 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module HiFileParser + ( Interface(..) + , List(..) + , Dictionary(..) + , Module(..) + , Usage(..) + , Dependencies(..) + , getInterface + , fromFile + ) where + +{- HLINT ignore "Reduce duplication" -} + +import Control.Monad (replicateM, replicateM_) +import Data.Binary (Get, Word32) +import Data.Binary.Get (Decoder (..), bytesRead, + getByteString, getInt64be, + getWord32be, getWord64be, + getWord8, lookAhead, + runGetIncremental, skip) +import Data.Bool (bool) +import Data.ByteString.Lazy.Internal (defaultChunkSize) +import Data.Char (chr) +import Data.Functor (void, ($>)) +import Data.List (find) +import Data.Maybe (catMaybes) +import Data.Semigroup ((<>)) +import qualified Data.Vector as V +import GHC.IO.IOMode (IOMode (..)) +import Numeric (showHex) +import RIO.ByteString as B (ByteString, hGetSome, null) +import System.IO (withBinaryFile) + +type IsBoot = Bool + +type ModuleName = ByteString + +newtype List a = List + { unList :: [a] + } deriving newtype (Show) + +newtype Dictionary = Dictionary + { unDictionary :: V.Vector ByteString + } deriving newtype (Show) + +newtype Module = Module + { unModule :: ModuleName + } deriving newtype (Show) + +newtype Usage = Usage + { unUsage :: FilePath + } deriving newtype (Show) + +data Dependencies = Dependencies + { dmods :: List (ModuleName, IsBoot) + , dpkgs :: List (ModuleName, Bool) + , dorphs :: List Module + , dfinsts :: List Module + , dplugins :: List ModuleName + } deriving (Show) + +data Interface = Interface + { deps :: Dependencies + , usage :: List Usage + } deriving (Show) + +-- | Read a block prefixed with its length +withBlockPrefix :: Get a -> Get a +withBlockPrefix f = getWord32be *> f + +getBool :: Get Bool +getBool = toEnum . fromIntegral <$> getWord8 + +getString :: Get String +getString = fmap (chr . fromIntegral) . unList <$> getList getWord32be + +getMaybe :: Get a -> Get (Maybe a) +getMaybe f = bool (pure Nothing) (Just <$> f) =<< getBool + +getList :: Get a -> Get (List a) +getList f = do + i <- getWord8 + l <- + if i == 0xff + then getWord32be + else pure (fromIntegral i :: Word32) + List <$> replicateM (fromIntegral l) f + +getTuple :: Get a -> Get b -> Get (a, b) +getTuple f g = (,) <$> f <*> g + +getByteStringSized :: Get ByteString +getByteStringSized = do + size <- getInt64be + getByteString (fromIntegral size) + +getDictionary :: Int -> Get Dictionary +getDictionary ptr = do + offset <- bytesRead + skip $ ptr - fromIntegral offset + size <- fromIntegral <$> getInt64be + Dictionary <$> V.replicateM size getByteStringSized + +getCachedBS :: Dictionary -> Get ByteString +getCachedBS d = go =<< getWord32be + where + go i = + case unDictionary d V.!? fromIntegral i of + Just bs -> pure bs + Nothing -> fail $ "Invalid dictionary index: " <> show i + +getFP :: Get () +getFP = void $ getWord64be *> getWord64be + +getInterface721 :: Dictionary -> Get Interface +getInterface721 d = do + void getModule + void getBool + replicateM_ 2 getFP + void getBool + void getBool + Interface <$> getDependencies <*> getUsage + where + getModule = getCachedBS d *> (Module <$> getCachedBS d) + getDependencies = + withBlockPrefix $ + Dependencies <$> getList (getTuple (getCachedBS d) getBool) <*> + getList (getTuple (getCachedBS d) getBool) <*> + getList getModule <*> + getList getModule <*> + pure (List []) + getUsage = withBlockPrefix $ List . catMaybes . unList <$> getList go + where + go :: Get (Maybe Usage) + go = do + usageType <- getWord8 + case usageType of + 0 -> getModule *> getFP *> getBool $> Nothing + 1 -> + getCachedBS d *> getFP *> getMaybe getFP *> + getList (getTuple (getWord8 *> getCachedBS d) getFP) *> + getBool $> Nothing + _ -> fail $ "Invalid usageType: " <> show usageType + +getInterface741 :: Dictionary -> Get Interface +getInterface741 d = do + void getModule + void getBool + replicateM_ 3 getFP + void getBool + void getBool + Interface <$> getDependencies <*> getUsage + where + getModule = getCachedBS d *> (Module <$> getCachedBS d) + getDependencies = + withBlockPrefix $ + Dependencies <$> getList (getTuple (getCachedBS d) getBool) <*> + getList (getTuple (getCachedBS d) getBool) <*> + getList getModule <*> + getList getModule <*> + pure (List []) + getUsage = withBlockPrefix $ List . catMaybes . unList <$> getList go + where + go :: Get (Maybe Usage) + go = do + usageType <- getWord8 + case usageType of + 0 -> getModule *> getFP *> getBool $> Nothing + 1 -> + getCachedBS d *> getFP *> getMaybe getFP *> + getList (getTuple (getWord8 *> getCachedBS d) getFP) *> + getBool $> Nothing + 2 -> Just . Usage <$> getString <* getWord64be <* getWord64be + _ -> fail $ "Invalid usageType: " <> show usageType + +getInterface761 :: Dictionary -> Get Interface +getInterface761 d = do + void getModule + void getBool + replicateM_ 3 getFP + void getBool + void getBool + Interface <$> getDependencies <*> getUsage + where + getModule = getCachedBS d *> (Module <$> getCachedBS d) + getDependencies = + withBlockPrefix $ + Dependencies <$> getList (getTuple (getCachedBS d) getBool) <*> + getList (getTuple (getCachedBS d) getBool) <*> + getList getModule <*> + getList getModule <*> + pure (List []) + getUsage = withBlockPrefix $ List . catMaybes . unList <$> getList go + where + go :: Get (Maybe Usage) + go = do + usageType <- getWord8 + case usageType of + 0 -> getModule *> getFP *> getBool $> Nothing + 1 -> + getCachedBS d *> getFP *> getMaybe getFP *> + getList (getTuple (getWord8 *> getCachedBS d) getFP) *> + getBool $> Nothing + 2 -> Just . Usage <$> getString <* getWord64be <* getWord64be + _ -> fail $ "Invalid usageType: " <> show usageType + +getInterface781 :: Dictionary -> Get Interface +getInterface781 d = do + void getModule + void getBool + replicateM_ 3 getFP + void getBool + void getBool + Interface <$> getDependencies <*> getUsage + where + getModule = getCachedBS d *> (Module <$> getCachedBS d) + getDependencies = + withBlockPrefix $ + Dependencies <$> getList (getTuple (getCachedBS d) getBool) <*> + getList (getTuple (getCachedBS d) getBool) <*> + getList getModule <*> + getList getModule <*> + pure (List []) + getUsage = withBlockPrefix $ List . catMaybes . unList <$> getList go + where + go :: Get (Maybe Usage) + go = do + usageType <- getWord8 + case usageType of + 0 -> getModule *> getFP *> getBool $> Nothing + 1 -> + getCachedBS d *> getFP *> getMaybe getFP *> + getList (getTuple (getWord8 *> getCachedBS d) getFP) *> + getBool $> Nothing + 2 -> Just . Usage <$> getString <* getFP + _ -> fail $ "Invalid usageType: " <> show usageType + +getInterface801 :: Dictionary -> Get Interface +getInterface801 d = do + void getModule + void getWord8 + replicateM_ 3 getFP + void getBool + void getBool + Interface <$> getDependencies <*> getUsage + where + getModule = getCachedBS d *> (Module <$> getCachedBS d) + getDependencies = + withBlockPrefix $ + Dependencies <$> getList (getTuple (getCachedBS d) getBool) <*> + getList (getTuple (getCachedBS d) getBool) <*> + getList getModule <*> + getList getModule <*> + pure (List []) + getUsage = withBlockPrefix $ List . catMaybes . unList <$> getList go + where + go :: Get (Maybe Usage) + go = do + usageType <- getWord8 + case usageType of + 0 -> getModule *> getFP *> getBool $> Nothing + 1 -> + getCachedBS d *> getFP *> getMaybe getFP *> + getList (getTuple (getWord8 *> getCachedBS d) getFP) *> + getBool $> Nothing + 2 -> Just . Usage <$> getString <* getFP + 3 -> getModule *> getFP $> Nothing + _ -> fail $ "Invalid usageType: " <> show usageType + +getInterface821 :: Dictionary -> Get Interface +getInterface821 d = do + void getModule + void $ getMaybe getModule + void getWord8 + replicateM_ 3 getFP + void getBool + void getBool + Interface <$> getDependencies <*> getUsage + where + getModule = do + idType <- getWord8 + case idType of + 0 -> void $ getCachedBS d + _ -> + void $ + getCachedBS d *> getList (getTuple (getCachedBS d) getModule) + Module <$> getCachedBS d + getDependencies = + withBlockPrefix $ + Dependencies <$> getList (getTuple (getCachedBS d) getBool) <*> + getList (getTuple (getCachedBS d) getBool) <*> + getList getModule <*> + getList getModule <*> + pure (List []) + getUsage = withBlockPrefix $ List . catMaybes . unList <$> getList go + where + go :: Get (Maybe Usage) + go = do + usageType <- getWord8 + case usageType of + 0 -> getModule *> getFP *> getBool $> Nothing + 1 -> + getCachedBS d *> getFP *> getMaybe getFP *> + getList (getTuple (getWord8 *> getCachedBS d) getFP) *> + getBool $> Nothing + 2 -> Just . Usage <$> getString <* getFP + 3 -> getModule *> getFP $> Nothing + _ -> fail $ "Invalid usageType: " <> show usageType + +getInterface841 :: Dictionary -> Get Interface +getInterface841 d = do + void getModule + void $ getMaybe getModule + void getWord8 + replicateM_ 5 getFP + void getBool + void getBool + Interface <$> getDependencies <*> getUsage + where + getModule = do + idType <- getWord8 + case idType of + 0 -> void $ getCachedBS d + _ -> + void $ + getCachedBS d *> getList (getTuple (getCachedBS d) getModule) + Module <$> getCachedBS d + getDependencies = + withBlockPrefix $ + Dependencies <$> getList (getTuple (getCachedBS d) getBool) <*> + getList (getTuple (getCachedBS d) getBool) <*> + getList getModule <*> + getList getModule <*> + pure (List []) + getUsage = withBlockPrefix $ List . catMaybes . unList <$> getList go + where + go :: Get (Maybe Usage) + go = do + usageType <- getWord8 + case usageType of + 0 -> getModule *> getFP *> getBool $> Nothing + 1 -> + getCachedBS d *> getFP *> getMaybe getFP *> + getList (getTuple (getWord8 *> getCachedBS d) getFP) *> + getBool $> Nothing + 2 -> Just . Usage <$> getString <* getFP + 3 -> getModule *> getFP $> Nothing + _ -> fail $ "Invalid usageType: " <> show usageType + +getInterface861 :: Dictionary -> Get Interface +getInterface861 d = do + void getModule + void $ getMaybe getModule + void getWord8 + replicateM_ 6 getFP + void getBool + void getBool + Interface <$> getDependencies <*> getUsage + where + getModule = do + idType <- getWord8 + case idType of + 0 -> void $ getCachedBS d + _ -> + void $ + getCachedBS d *> getList (getTuple (getCachedBS d) getModule) + Module <$> getCachedBS d + getDependencies = + withBlockPrefix $ + Dependencies <$> getList (getTuple (getCachedBS d) getBool) <*> + getList (getTuple (getCachedBS d) getBool) <*> + getList getModule <*> + getList getModule <*> + getList (getCachedBS d) + getUsage = withBlockPrefix $ List . catMaybes . unList <$> getList go + where + go :: Get (Maybe Usage) + go = do + usageType <- getWord8 + case usageType of + 0 -> getModule *> getFP *> getBool $> Nothing + 1 -> + getCachedBS d *> getFP *> getMaybe getFP *> + getList (getTuple (getWord8 *> getCachedBS d) getFP) *> + getBool $> Nothing + 2 -> Just . Usage <$> getString <* getFP + 3 -> getModule *> getFP $> Nothing + _ -> fail $ "Invalid usageType: " <> show usageType + +getInterface :: Get Interface +getInterface = do + magic <- getWord32be + case magic of + -- x32 + 0x1face -> void getWord32be + -- x64 + 0x1face64 -> void getWord64be + invalidMagic -> fail $ "Invalid magic: " <> showHex invalidMagic "" + -- ghc version + version <- getString + -- way + void getString + -- dict_ptr + dictPtr <- getWord32be + -- dict + dict <- lookAhead $ getDictionary $ fromIntegral dictPtr + -- symtable_ptr + void getWord32be + let versions = + [ ("8061", getInterface861) + , ("8041", getInterface841) + , ("8021", getInterface821) + , ("8001", getInterface801) + , ("7081", getInterface781) + , ("7061", getInterface761) + , ("7041", getInterface741) + , ("7021", getInterface721) + ] + case snd <$> find ((version >=) . fst) versions of + Just f -> f dict + Nothing -> fail $ "Unsupported version: " <> version + +fromFile :: FilePath -> IO (Either String Interface) +fromFile fp = withBinaryFile fp ReadMode go + where + go h = + let feed (Done _ _ iface) = pure $ Right iface + feed (Fail _ _ msg) = pure $ Left msg + feed (Partial k) = do + chunk <- hGetSome h defaultChunkSize + feed $ k $ if B.null chunk then Nothing else Just chunk + in feed $ runGetIncremental getInterface diff --git a/subs/hi-file-parser/test-files/iface/x32/Main.hs b/subs/hi-file-parser/test-files/iface/x32/Main.hs new file mode 100644 index 0000000000..6fd36ba675 --- /dev/null +++ b/subs/hi-file-parser/test-files/iface/x32/Main.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +import Language.Haskell.TH.Syntax + +main :: IO () +main = $(do + qAddDependentFile "some-dependency.txt" + [|pure ()|]) diff --git a/subs/hi-file-parser/test-files/iface/x32/ghc7103/Main.hi b/subs/hi-file-parser/test-files/iface/x32/ghc7103/Main.hi new file mode 100644 index 0000000000..58f3c54d70 Binary files /dev/null and b/subs/hi-file-parser/test-files/iface/x32/ghc7103/Main.hi differ diff --git a/subs/hi-file-parser/test-files/iface/x32/ghc802/Main.hi b/subs/hi-file-parser/test-files/iface/x32/ghc802/Main.hi new file mode 100644 index 0000000000..bbfae7e387 Binary files /dev/null and b/subs/hi-file-parser/test-files/iface/x32/ghc802/Main.hi differ diff --git a/subs/hi-file-parser/test-files/iface/x32/ghc822/Main.hi b/subs/hi-file-parser/test-files/iface/x32/ghc822/Main.hi new file mode 100644 index 0000000000..c3c1ae8ad1 Binary files /dev/null and b/subs/hi-file-parser/test-files/iface/x32/ghc822/Main.hi differ diff --git a/subs/hi-file-parser/test-files/iface/x32/ghc844/Main.hi b/subs/hi-file-parser/test-files/iface/x32/ghc844/Main.hi new file mode 100644 index 0000000000..19b0f70fcc Binary files /dev/null and b/subs/hi-file-parser/test-files/iface/x32/ghc844/Main.hi differ diff --git a/subs/hi-file-parser/test-files/iface/x32/run.sh b/subs/hi-file-parser/test-files/iface/x32/run.sh new file mode 100755 index 0000000000..0a4a74f6ba --- /dev/null +++ b/subs/hi-file-parser/test-files/iface/x32/run.sh @@ -0,0 +1,16 @@ +#!/usr/bin/env bash + +set -eux + +go() { + for ver in 7.10.3 8.0.2 8.2.2 8.4.4 8.6.4 + do + stack --resolver ghc-$ver --arch i386 ghc -- -fforce-recomp Main.hs + local DIR + DIR=ghc"$(echo $ver | tr -d '.')" + mkdir -p DIR + mv Main.hi $DIR/Main.hi + done +} + +go diff --git a/subs/hi-file-parser/test-files/iface/x64/Main.hs b/subs/hi-file-parser/test-files/iface/x64/Main.hs new file mode 100644 index 0000000000..524ae0d0e4 --- /dev/null +++ b/subs/hi-file-parser/test-files/iface/x64/Main.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} + +module Main where + +import GHC.Types +import Language.Haskell.TH.Lib +import Language.Haskell.TH.Syntax +import X + +#include "Test.h" + +main :: IO () +main = putStrLn "Hello, World!" + +f :: String +f = $(let readme = "README.md" + in qAddDependentFile readme *> (stringE =<< qRunIO (readFile readme))) diff --git a/subs/hi-file-parser/test-files/iface/x64/README.md b/subs/hi-file-parser/test-files/iface/x64/README.md new file mode 100644 index 0000000000..d245656d61 --- /dev/null +++ b/subs/hi-file-parser/test-files/iface/x64/README.md @@ -0,0 +1,3 @@ +# Generating the dummy iface + +Update the `supportedVersions` in the `shell.nix` and then run the following command `nix-shell --pure --run "generate"` diff --git a/subs/hi-file-parser/test-files/iface/x64/Test.h b/subs/hi-file-parser/test-files/iface/x64/Test.h new file mode 100644 index 0000000000..bb31ec3f0f --- /dev/null +++ b/subs/hi-file-parser/test-files/iface/x64/Test.h @@ -0,0 +1,2 @@ +#define TRUE 1 +#define FALSE 0 diff --git a/subs/hi-file-parser/test-files/iface/x64/X.hs b/subs/hi-file-parser/test-files/iface/x64/X.hs new file mode 100644 index 0000000000..a1d5b7bc22 --- /dev/null +++ b/subs/hi-file-parser/test-files/iface/x64/X.hs @@ -0,0 +1,4 @@ +module X where + +x :: Integer +x = 1 diff --git a/subs/hi-file-parser/test-files/iface/x64/ghc822/Main.hi b/subs/hi-file-parser/test-files/iface/x64/ghc822/Main.hi new file mode 100644 index 0000000000..32ebe107a8 Binary files /dev/null and b/subs/hi-file-parser/test-files/iface/x64/ghc822/Main.hi differ diff --git a/subs/hi-file-parser/test-files/iface/x64/ghc822/X.hi b/subs/hi-file-parser/test-files/iface/x64/ghc822/X.hi new file mode 100644 index 0000000000..e934d1f3e5 Binary files /dev/null and b/subs/hi-file-parser/test-files/iface/x64/ghc822/X.hi differ diff --git a/subs/hi-file-parser/test-files/iface/x64/ghc844/Main.hi b/subs/hi-file-parser/test-files/iface/x64/ghc844/Main.hi new file mode 100644 index 0000000000..19f78d0e50 Binary files /dev/null and b/subs/hi-file-parser/test-files/iface/x64/ghc844/Main.hi differ diff --git a/subs/hi-file-parser/test-files/iface/x64/ghc844/X.hi b/subs/hi-file-parser/test-files/iface/x64/ghc844/X.hi new file mode 100644 index 0000000000..84c8be089c Binary files /dev/null and b/subs/hi-file-parser/test-files/iface/x64/ghc844/X.hi differ diff --git a/subs/hi-file-parser/test-files/iface/x64/ghc864/Main.hi b/subs/hi-file-parser/test-files/iface/x64/ghc864/Main.hi new file mode 100644 index 0000000000..83fc501533 Binary files /dev/null and b/subs/hi-file-parser/test-files/iface/x64/ghc864/Main.hi differ diff --git a/subs/hi-file-parser/test-files/iface/x64/ghc864/X.hi b/subs/hi-file-parser/test-files/iface/x64/ghc864/X.hi new file mode 100644 index 0000000000..2168134fa9 Binary files /dev/null and b/subs/hi-file-parser/test-files/iface/x64/ghc864/X.hi differ diff --git a/subs/hi-file-parser/test-files/iface/x64/shell.nix b/subs/hi-file-parser/test-files/iface/x64/shell.nix new file mode 100644 index 0000000000..7691bf127b --- /dev/null +++ b/subs/hi-file-parser/test-files/iface/x64/shell.nix @@ -0,0 +1,29 @@ +with (import (builtins.fetchTarball { + name = "nixpkgs-19.03"; + url = "https://github.com/nixos/nixpkgs/archive/release-19.03.tar.gz"; + sha256 = "sha256:1p0xkcz183gwga9f9b24ihq3b7syjimkhr31y6h044yfmrkcnb6d"; +}) {}); +let + supportedVersions = [ + "822" + "844" + "864" + ]; + generate = version: + let ghc = haskell.compiler."ghc${version}"; + main = "Main"; + in '' + mkdir -p ghc${version}/ + ${ghc}/bin/ghc -fforce-recomp -hidir ghc${version} ${main}.hs && \ + rm *.o && \ + rm ${main} + ''; +in + mkShell { + shellHook = + '' + generate() { + ${lib.concatMapStrings generate supportedVersions} + } + ''; + } diff --git a/subs/hi-file-parser/test/HiFileParserSpec.hs b/subs/hi-file-parser/test/HiFileParserSpec.hs new file mode 100644 index 0000000000..77da245773 --- /dev/null +++ b/subs/hi-file-parser/test/HiFileParserSpec.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module HiFileParserSpec (spec) where + +import Data.Foldable (traverse_) +import Data.Semigroup ((<>)) +import qualified HiFileParser as Iface +import RIO +import Test.Hspec (Spec, describe, it, shouldBe) + +type Version = String +type Directory = FilePath +type Usage = String +type Module = ByteString + +versions32 :: [Version] +versions32 = ["ghc7103", "ghc802", "ghc822", "ghc844"] + +versions64 :: [Version] +versions64 = ["ghc822", "ghc844", "ghc864"] + +spec :: Spec +spec = describe "should succesfully deserialize x32 interface for" $ do + traverse_ (deserialize check32) (("x32/" <>) <$> versions32) + traverse_ (deserialize check64) (("x64/" <>) <$> versions64) + +check32 :: Iface.Interface -> IO () +check32 iface = do + hasExpectedUsage "some-dependency.txt" iface `shouldBe` True + +check64 :: Iface.Interface -> IO () +check64 iface = do + hasExpectedUsage "Test.h" iface `shouldBe` True + hasExpectedUsage "README.md" iface `shouldBe` True + hasExpectedModule "X" iface `shouldBe` True + +deserialize :: (Iface.Interface -> IO ()) -> Directory -> Spec +deserialize check d = do + it d $ do + let ifacePath = "test-files/iface/" <> d <> "/Main.hi" + result <- Iface.fromFile ifacePath + case result of + (Left msg) -> fail msg + (Right iface) -> check iface + +-- | `Usage` is the name given by GHC to TH dependency +hasExpectedUsage :: Usage -> Iface.Interface -> Bool +hasExpectedUsage u = + elem u . fmap Iface.unUsage . Iface.unList . Iface.usage + +hasExpectedModule :: Module -> Iface.Interface -> Bool +hasExpectedModule m = + elem m . fmap fst . Iface.unList . Iface.dmods . Iface.deps diff --git a/subs/hi-file-parser/test/Spec.hs b/subs/hi-file-parser/test/Spec.hs new file mode 100644 index 0000000000..a824f8c30c --- /dev/null +++ b/subs/hi-file-parser/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}