StableModule.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Liquid.GHC.API.StableModule (
    StableModule
  -- * Constructing a 'StableModule'
  , mkStableModule
  -- * Converting a 'StableModule' into a standard 'Module'
  , unStableModule
  -- * Utility functions
  , toStableModule
  , renderModule
  ) where

import qualified GHC
import qualified GHC.Unit.Types as GHC
import qualified GHC.Unit.Module as GHC
import           Data.Data (Data)
import           Data.Hashable
import           GHC.Generics            hiding (to, moduleName)
import           Data.Binary

-- | A newtype wrapper around a 'Module' which:
--
-- * Allows a 'Module' to be serialised (i.e. it has a 'Binary' instance)
-- * It tries to use stable comparison and equality under the hood.
--
newtype StableModule =
  StableModule { unStableModule :: GHC.Module }
  deriving (Data, Generic)

-- | Converts a 'Module' into a 'StableModule'.
toStableModule :: GHC.Module -> StableModule
toStableModule = StableModule

moduleUnitId :: GHC.Module -> GHC.UnitId
moduleUnitId = GHC.toUnitId . GHC.moduleUnit

renderModule :: GHC.Module -> String
renderModule m =    "Module { unitId = " <> (GHC.unitIdString . moduleUnitId $ m)
                 <> ", name = " <> GHC.moduleNameString (GHC.moduleName m)
                 <> " }"

-- These two orphans originally lived inside module 'Language.Haskell.Liquid.Types.Types'.
instance Hashable GHC.ModuleName where
  hashWithSalt i = hashWithSalt i . GHC.moduleNameString

instance Hashable StableModule where
  hashWithSalt s (StableModule mdl) = hashWithSalt s (GHC.moduleStableString mdl)

instance Ord StableModule where
  (StableModule m1) `compare` (StableModule m2) = GHC.stableModuleCmp m1 m2

instance Eq StableModule where
  (StableModule m1) == (StableModule m2) = (m1 `GHC.stableModuleCmp` m2) == EQ

instance Show StableModule where
    show (StableModule mdl) = "Stable" ++ renderModule mdl

instance Binary StableModule where

    put (StableModule mdl) = do
      put (GHC.unitIdString . moduleUnitId $ mdl)
      put (GHC.moduleNameString . GHC.moduleName $ mdl)

    get = do
      uidStr <- get
      mkStableModule (GHC.stringToUnitId uidStr) . GHC.mkModuleName <$> get

--
-- Compat shim layer
--

-- | Creates a new 'StableModule' out of a 'ModuleName' and a 'UnitId'.
mkStableModule :: GHC.UnitId -> GHC.ModuleName -> StableModule
mkStableModule uid modName =
  let realUnit = GHC.RealUnit $ GHC.Definite uid
  in StableModule (GHC.Module realUnit modName)