ghc-hie-0.0.4: test/SmokeSpec.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BlockArguments #-}
module SmokeSpec (spec) where

import Test.Hspec
import Test.QuickCheck

import Foreign (Ptr, peek)
import Data.Word
import Data.Foldable hiding (find)
import Control.Exception (bracket_)
import System.Environment (lookupEnv)
import System.Process

import GHC.Settings.Config (cProjectVersion, cProjectUnitId)
import GHC.Types.Unique.Supply (initUniqSupply)

import GHC.Iface.Ext.Binary
import GHC.Iface.Ext.BinarySpec ()
import qualified GHC.Iface.Ext.Upstream as Upstream

foreign import ccall unsafe "&ghc_unique_counter64" ghc_unique_counter64 :: Ptr Word64
foreign import ccall unsafe "&ghc_unique_inc"       ghc_unique_inc       :: Ptr Int

withDeterministicUniqueSupply :: IO a -> IO a
withDeterministicUniqueSupply action = do
  counter <- peek ghc_unique_counter64
  increment <- peek ghc_unique_inc
  bracket_ (initUniqSupply 0 1) (initUniqSupply counter increment) action

findHieFiles :: IO [FilePath]
findHieFiles = lookupEnv "CI" >>= \ case
  Nothing -> return []; Just
    _ -> (++)
      <$> do find $ "~/.local/state/ghc-hie-files/ghc-" <> cProjectVersion
      <*> do find $ "~/.local/state/cabal/store/" <> cProjectUnitId
  where
    find :: FilePath -> IO [String]
    find dir = lines <$> readCreateProcess (shell $ "find " <> dir <> " -name '*.hie'") ""

spec :: Spec
spec = do
  describe "withDeterministicUniqueSupply" do
    it "runs an action with a deterministic unique supply" do
      withDeterministicUniqueSupply do
        peek ghc_unique_counter64 `shouldReturn` 0
        peek ghc_unique_inc `shouldReturn` 1

    it "restores the original unique supply when done" do
      counter <- peek ghc_unique_counter64
      increment <- peek ghc_unique_inc
      withDeterministicUniqueSupply do
        initUniqSupply 23 42
        peek ghc_unique_counter64 `shouldReturn` 23
        peek ghc_unique_inc `shouldReturn` 42
      peek ghc_unique_counter64 `shouldReturn` counter
      peek ghc_unique_inc `shouldReturn` increment

  describe "smoke tests" do
    runIO findHieFiles >>= traverse_ \ hieFile -> do
      it hieFile do
        theirs <- withDeterministicUniqueSupply do
          nameCache <- newEmptyNameCache
          Upstream.readHieFile hieFile nameCache
        mine <- withDeterministicUniqueSupply do
          nameCache <- newEmptyNameCache
          hie_file_result <$> readHieFile nameCache hieFile
        Blind mine `shouldBe` Blind theirs