{-# LANGUAGE DeriveGeneric #-}

{-# 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.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 { StableModule -> Module
unStableModule :: GHC.Module }
  deriving (forall x. StableModule -> Rep StableModule x)
-> (forall x. Rep StableModule x -> StableModule)
-> Generic StableModule
forall x. Rep StableModule x -> StableModule
forall x. StableModule -> Rep StableModule x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. StableModule -> Rep StableModule x
from :: forall x. StableModule -> Rep StableModule x
$cto :: forall x. Rep StableModule x -> StableModule
to :: forall x. Rep StableModule x -> StableModule
Generic

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

moduleUnitId :: GHC.Module -> GHC.UnitId
moduleUnitId :: Module -> UnitId
moduleUnitId = Unit -> UnitId
GHC.toUnitId (Unit -> UnitId) -> (Module -> Unit) -> Module -> UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> Unit
forall unit. GenModule unit -> unit
GHC.moduleUnit

renderModule :: GHC.Module -> String
renderModule :: Module -> String
renderModule Module
m =    String
"Module { unitId = " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (UnitId -> String
GHC.unitIdString (UnitId -> String) -> (Module -> UnitId) -> Module -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> UnitId
moduleUnitId (Module -> String) -> Module -> String
forall a b. (a -> b) -> a -> b
$ Module
m)
                 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", name = " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ModuleName -> String
GHC.moduleNameString (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
GHC.moduleName Module
m)
                 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" }"

-- These two orphans originally lived inside module 'Language.Haskell.Liquid.Types.Types'.
instance Hashable GHC.ModuleName where
  hashWithSalt :: Int -> ModuleName -> Int
hashWithSalt Int
i = Int -> String -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
i (String -> Int) -> (ModuleName -> String) -> ModuleName -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> String
GHC.moduleNameString

instance Hashable StableModule where
  hashWithSalt :: Int -> StableModule -> Int
hashWithSalt Int
s (StableModule Module
mdl) = Int -> String -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s (Module -> String
GHC.moduleStableString Module
mdl)

instance Ord StableModule where
  (StableModule Module
m1) compare :: StableModule -> StableModule -> Ordering
`compare` (StableModule Module
m2) = Module -> Module -> Ordering
GHC.stableModuleCmp Module
m1 Module
m2

instance Eq StableModule where
  (StableModule Module
m1) == :: StableModule -> StableModule -> Bool
== (StableModule Module
m2) = (Module
m1 Module -> Module -> Ordering
`GHC.stableModuleCmp` Module
m2) Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ

instance Show StableModule where
    show :: StableModule -> String
show (StableModule Module
mdl) = String
"Stable" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Module -> String
renderModule Module
mdl

instance Binary StableModule where

    put :: StableModule -> Put
put (StableModule Module
mdl) = do
      String -> Put
forall t. Binary t => t -> Put
put (UnitId -> String
GHC.unitIdString (UnitId -> String) -> (Module -> UnitId) -> Module -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> UnitId
moduleUnitId (Module -> String) -> Module -> String
forall a b. (a -> b) -> a -> b
$ Module
mdl)
      String -> Put
forall t. Binary t => t -> Put
put (ModuleName -> String
GHC.moduleNameString (ModuleName -> String)
-> (Module -> ModuleName) -> Module -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> ModuleName
forall unit. GenModule unit -> ModuleName
GHC.moduleName (Module -> String) -> Module -> String
forall a b. (a -> b) -> a -> b
$ Module
mdl)

    get :: Get StableModule
get = do
      String
uidStr <- Get String
forall t. Binary t => Get t
get
      UnitId -> ModuleName -> StableModule
mkStableModule (String -> UnitId
GHC.stringToUnitId String
uidStr) (ModuleName -> StableModule)
-> (String -> ModuleName) -> String -> StableModule
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ModuleName
GHC.mkModuleName (String -> StableModule) -> Get String -> Get StableModule
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get String
forall t. Binary t => Get t
get

--
-- Compat shim layer
--

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