diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Changelog for hi-file-parser + +## 0.1.0.0 + +Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hi-file-parser.cabal b/hi-file-parser.cabal new file mode 100644 --- /dev/null +++ b/hi-file-parser.cabal @@ -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 +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 diff --git a/src/HiFileParser.hs b/src/HiFileParser.hs new file mode 100644 --- /dev/null +++ b/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/test-files/iface/x32/ghc7103/Main.hi b/test-files/iface/x32/ghc7103/Main.hi new file mode 100644 Binary files /dev/null and b/test-files/iface/x32/ghc7103/Main.hi differ diff --git a/test-files/iface/x32/ghc802/Main.hi b/test-files/iface/x32/ghc802/Main.hi new file mode 100644 Binary files /dev/null and b/test-files/iface/x32/ghc802/Main.hi differ diff --git a/test-files/iface/x32/ghc822/Main.hi b/test-files/iface/x32/ghc822/Main.hi new file mode 100644 Binary files /dev/null and b/test-files/iface/x32/ghc822/Main.hi differ diff --git a/test-files/iface/x32/ghc844/Main.hi b/test-files/iface/x32/ghc844/Main.hi new file mode 100644 Binary files /dev/null and b/test-files/iface/x32/ghc844/Main.hi differ diff --git a/test-files/iface/x64/ghc822/Main.hi b/test-files/iface/x64/ghc822/Main.hi new file mode 100644 Binary files /dev/null and b/test-files/iface/x64/ghc822/Main.hi differ diff --git a/test-files/iface/x64/ghc822/X.hi b/test-files/iface/x64/ghc822/X.hi new file mode 100644 Binary files /dev/null and b/test-files/iface/x64/ghc822/X.hi differ diff --git a/test-files/iface/x64/ghc844/Main.hi b/test-files/iface/x64/ghc844/Main.hi new file mode 100644 Binary files /dev/null and b/test-files/iface/x64/ghc844/Main.hi differ diff --git a/test-files/iface/x64/ghc844/X.hi b/test-files/iface/x64/ghc844/X.hi new file mode 100644 Binary files /dev/null and b/test-files/iface/x64/ghc844/X.hi differ diff --git a/test-files/iface/x64/ghc864/Main.hi b/test-files/iface/x64/ghc864/Main.hi new file mode 100644 Binary files /dev/null and b/test-files/iface/x64/ghc864/Main.hi differ diff --git a/test-files/iface/x64/ghc864/X.hi b/test-files/iface/x64/ghc864/X.hi new file mode 100644 Binary files /dev/null and b/test-files/iface/x64/ghc864/X.hi differ diff --git a/test/HiFileParserSpec.hs b/test/HiFileParserSpec.hs new file mode 100644 --- /dev/null +++ b/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/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}