Split out hi-file-parser

snapshot-lts-12.yaml

@@ -16,6 +16,7 @@ packages:
 - optparse-simple-0.1.1.2
 - typed-process-0.2.6.0@rev:0 # for rio-0.1.10.0
 - rio-prettyprint-0.1.0.0
+- hi-file-parser-0.1.0.0
 - git: https://github.com/snoyberg/filelock.git
   commit: 97e83ecc133cd60a99df8e1fa5a3c2739ad007dc
 

snapshot-nightly.yaml

@@ -10,6 +10,7 @@ packages:
 - http-client-0.5.14@rev:0
 - cryptonite-0.26@rev:0
 - rio-prettyprint-0.1.0.0
+- hi-file-parser-0.1.0.0
 - git: https://github.com/snoyberg/filelock.git
   commit: 97e83ecc133cd60a99df8e1fa5a3c2739ad007dc
 

snapshot.yaml

@@ -24,6 +24,7 @@ packages:
 - hedgehog-0.6.1@rev:4 # for ansi-terminal-0.9
 - typed-process-0.2.6.0@rev:0 # for rio-0.1.10.0
 - rio-prettyprint-0.1.0.0
+- hi-file-parser-0.1.0.0
 - git: https://github.com/snoyberg/filelock.git
   commit: 97e83ecc133cd60a99df8e1fa5a3c2739ad007dc
 

stack-lts-12.yaml

@@ -4,7 +4,6 @@ packages:
 - .
 - subs/pantry
 - subs/http-download
-- subs/hi-file-parser
 
 docker:
   enable: false

stack-nightly.yaml

@@ -4,7 +4,6 @@ packages:
 - .
 - subs/pantry
 - subs/http-download
-- subs/hi-file-parser
 
 docker:
   enable: false

stack.yaml

@@ -4,7 +4,6 @@ packages:
 - .
 - subs/pantry
 - subs/http-download
-- subs/hi-file-parser
 
 docker:
   enable: false

subs/hi-file-parser/ChangeLog.md

-# Changelog for hi-file-parser
-
-## 0.1.0.0
-
-Initial release

subs/hi-file-parser/LICENSE

-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

-# 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

-import Distribution.Simple
-main = defaultMain

subs/hi-file-parser/package.yaml

-name:                hi-file-parser
-version:             0.1.0.0
-github:              commercialhaskell/stack
-license:             BSD3
-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

subs/hi-file-parser/src/HiFileParser.hs

-{-# 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

subs/hi-file-parser/test-files/iface/x32/Main.hs

-{-# LANGUAGE TemplateHaskell #-}
-import Language.Haskell.TH.Syntax
-
-main :: IO ()
-main = $(do
-  qAddDependentFile "some-dependency.txt"
-  [|pure ()|])

subs/hi-file-parser/test-files/iface/x32/run.sh

-#!/usr/bin/env bash
-
-set -eux
-
-go() {
-  for ver in 7.10.3 8.0.2 8.2.2 8.4.4 8.6.5
-  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

subs/hi-file-parser/test-files/iface/x64/Main.hs

-{-# 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)))

subs/hi-file-parser/test-files/iface/x64/README.md

-# Generating the dummy iface
-
-Update the `supportedVersions` in the `shell.nix` and then run the following command `nix-shell --pure --run "generate"`