hi-file-parser (empty) → 0.1.0.0
raw patch · 18 files changed
+604/−0 lines, 18 filesdep +basedep +binarydep +bytestringsetup-changedbinary-added
Dependencies added: base, binary, bytestring, hi-file-parser, hspec, rio, vector
Files
- ChangeLog.md +5/−0
- LICENSE +24/−0
- README.md +11/−0
- Setup.hs +2/−0
- hi-file-parser.cabal +72/−0
- src/HiFileParser.hs +435/−0
- test-files/iface/x32/ghc7103/Main.hi binary
- test-files/iface/x32/ghc802/Main.hi binary
- test-files/iface/x32/ghc822/Main.hi binary
- test-files/iface/x32/ghc844/Main.hi binary
- test-files/iface/x64/ghc822/Main.hi binary
- test-files/iface/x64/ghc822/X.hi binary
- test-files/iface/x64/ghc844/Main.hi binary
- test-files/iface/x64/ghc844/X.hi binary
- test-files/iface/x64/ghc864/Main.hi binary
- test-files/iface/x64/ghc864/X.hi binary
- test/HiFileParserSpec.hs +54/−0
- test/Spec.hs +1/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Changelog for hi-file-parser++## 0.1.0.0++Initial release
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hi-file-parser.cabal view
@@ -0,0 +1,72 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.1.+--+-- see: https://github.com/sol/hpack+--+-- hash: 2313c7d2911f3c633e0e5dc904c1a47cfe30b325de4f4aeac2752a703c62823d++name: hi-file-parser+version: 0.1.0.0+synopsis: Parser for GHC's hi files+description: Please see the README on Github at <https://github.com/commercialhaskell/stack/blob/master/subs/hi-file-parser/README.md>+category: Development+homepage: https://github.com/commercialhaskell/stack#readme+bug-reports: https://github.com/commercialhaskell/stack/issues+author: Hussein Ait-Lahcen+maintainer: michael@snoyman.com+license: BSD3+license-file: LICENSE+build-type: Simple+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++source-repository head+ type: git+ location: https://github.com/commercialhaskell/stack++library+ exposed-modules:+ HiFileParser+ other-modules:+ Paths_hi_file_parser+ hs-source-dirs:+ src+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints+ build-depends:+ base >=4.10 && <5+ , binary+ , bytestring+ , rio+ , vector+ default-language: Haskell2010++test-suite hi-file-parser-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ HiFileParserSpec+ Paths_hi_file_parser+ hs-source-dirs:+ test+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.10 && <5+ , binary+ , bytestring+ , hi-file-parser+ , hspec+ , rio+ , vector+ default-language: Haskell2010
+ src/HiFileParser.hs view
@@ -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
+ test-files/iface/x32/ghc7103/Main.hi view
binary file changed (absent → 827 bytes)
+ test-files/iface/x32/ghc802/Main.hi view
binary file changed (absent → 1067 bytes)
+ test-files/iface/x32/ghc822/Main.hi view
binary file changed (absent → 1217 bytes)
+ test-files/iface/x32/ghc844/Main.hi view
binary file changed (absent → 1168 bytes)
+ test-files/iface/x64/ghc822/Main.hi view
binary file changed (absent → 2178 bytes)
+ test-files/iface/x64/ghc822/X.hi view
binary file changed (absent → 866 bytes)
+ test-files/iface/x64/ghc844/Main.hi view
binary file changed (absent → 2196 bytes)
+ test-files/iface/x64/ghc844/X.hi view
binary file changed (absent → 817 bytes)
+ test-files/iface/x64/ghc864/Main.hi view
binary file changed (absent → 2223 bytes)
+ test-files/iface/x64/ghc864/X.hi view
binary file changed (absent → 844 bytes)
+ test/HiFileParserSpec.hs view
@@ -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
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}