{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Language.Haskell.Liquid.GHC.Plugin.Util (
      -- * Serialising and deserialising things from/to specs.
        serialiseLiquidLib
      , deserialiseLiquidLib
      , deserialiseLiquidLibFromEPS

      -- * Aborting the plugin execution
      , pluginAbort
      ) where

import           Data.Foldable                            ( asum )

import           Control.Monad.IO.Class
import           Control.Monad

import qualified Data.Binary                             as B
import           Data.Binary                              ( Binary )
import qualified Data.ByteString.Lazy                    as B
import           Data.Typeable
import           Data.Maybe                               ( listToMaybe )

import           Liquid.GHC.API
import           Language.Haskell.Liquid.GHC.Plugin.Types (LiquidLib)


pluginAbort :: MonadIO m => String -> m a
pluginAbort :: forall (m :: * -> *) a. MonadIO m => String -> m a
pluginAbort = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> (String -> IO a) -> String -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhcException -> IO a
forall a. GhcException -> IO a
throwGhcExceptionIO (GhcException -> IO a)
-> (String -> GhcException) -> String -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> GhcException
ProgramError

--
-- Serialising and deserialising Specs
--

deserialiseBinaryObjectFromEPS
  :: forall a. (Typeable a, Binary a)
  => Module
  -> ExternalPackageState
  -> Maybe a
deserialiseBinaryObjectFromEPS :: forall a.
(Typeable a, Binary a) =>
Module -> ExternalPackageState -> Maybe a
deserialiseBinaryObjectFromEPS Module
thisModule ExternalPackageState
eps = Maybe a
extractFromEps
  where
    extractFromEps :: Maybe a
    extractFromEps :: Maybe a
extractFromEps = [a] -> Maybe a
forall a. [a] -> Maybe a
listToMaybe ([a] -> Maybe a) -> [a] -> Maybe a
forall a b. (a -> b) -> a -> b
$ ([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]
forall a.
Typeable a =>
([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]
findAnns (ByteString -> a
forall a. Binary a => ByteString -> a
B.decode (ByteString -> a) -> ([Word8] -> ByteString) -> [Word8] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ByteString
B.pack) (ExternalPackageState -> AnnEnv
eps_ann_env ExternalPackageState
eps) (Module -> CoreAnnTarget
forall name. Module -> AnnTarget name
ModuleTarget Module
thisModule)

deserialiseBinaryObject :: forall a. (Typeable a, Binary a)
                        => Module
                        -> ExternalPackageState
                        -> HomePackageTable
                        -> Maybe a
deserialiseBinaryObject :: forall a.
(Typeable a, Binary a) =>
Module -> ExternalPackageState -> HomePackageTable -> Maybe a
deserialiseBinaryObject Module
thisModule ExternalPackageState
eps HomePackageTable
hpt =
    [Maybe a] -> Maybe a
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [Maybe a
extractFromHpt, Module -> ExternalPackageState -> Maybe a
forall a.
(Typeable a, Binary a) =>
Module -> ExternalPackageState -> Maybe a
deserialiseBinaryObjectFromEPS Module
thisModule ExternalPackageState
eps]
  where
    extractFromHpt :: Maybe a
    extractFromHpt :: Maybe a
extractFromHpt = do
      HomeModInfo
modInfo <- HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
hpt (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
thisModule)
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Module
thisModule Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== (ModIface_ 'ModIfaceFinal -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (ModIface_ 'ModIfaceFinal -> Module)
-> (HomeModInfo -> ModIface_ 'ModIfaceFinal)
-> HomeModInfo
-> Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModIface_ 'ModIfaceFinal
hm_iface (HomeModInfo -> Module) -> HomeModInfo -> Module
forall a b. (a -> b) -> a -> b
$ HomeModInfo
modInfo))
      [a]
xs <- (IfaceAnnotation -> Maybe a) -> [IfaceAnnotation] -> Maybe [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (([Word8] -> a) -> Serialized -> Maybe a
forall a. Typeable a => ([Word8] -> a) -> Serialized -> Maybe a
fromSerialized [Word8] -> a
deserialise (Serialized -> Maybe a)
-> (IfaceAnnotation -> Serialized) -> IfaceAnnotation -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IfaceAnnotation -> Serialized
ifAnnotatedValue) (ModIface_ 'ModIfaceFinal -> [IfaceAnnotation]
forall (phase :: ModIfacePhase).
ModIface_ phase -> [IfaceAnnotation]
mi_anns (ModIface_ 'ModIfaceFinal -> [IfaceAnnotation])
-> (HomeModInfo -> ModIface_ 'ModIfaceFinal)
-> HomeModInfo
-> [IfaceAnnotation]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModIface_ 'ModIfaceFinal
hm_iface (HomeModInfo -> [IfaceAnnotation])
-> HomeModInfo -> [IfaceAnnotation]
forall a b. (a -> b) -> a -> b
$ HomeModInfo
modInfo)
      [a] -> Maybe a
forall a. [a] -> Maybe a
listToMaybe [a]
xs

    deserialise :: [B.Word8] -> a
    deserialise :: [Word8] -> a
deserialise [Word8]
payload = ByteString -> a
forall a. Binary a => ByteString -> a
B.decode ([Word8] -> ByteString
B.pack [Word8]
payload)

serialiseBinaryObject :: forall a. (Binary a, Typeable a) => a -> Module -> Annotation
serialiseBinaryObject :: forall a. (Binary a, Typeable a) => a -> Module -> Annotation
serialiseBinaryObject a
obj Module
thisModule = Annotation
serialised
  where
    serialised :: Annotation
    serialised :: Annotation
serialised = CoreAnnTarget -> Serialized -> Annotation
Annotation (Module -> CoreAnnTarget
forall name. Module -> AnnTarget name
ModuleTarget Module
thisModule) ((a -> [Word8]) -> a -> Serialized
forall a. Typeable a => (a -> [Word8]) -> a -> Serialized
toSerialized (ByteString -> [Word8]
B.unpack (ByteString -> [Word8]) -> (a -> ByteString) -> a -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. Binary a => a -> ByteString
B.encode) a
obj)

-- | Serialise a 'LiquidLib', removing the termination checks from the target.
serialiseLiquidLib :: LiquidLib -> Module -> Annotation
serialiseLiquidLib :: LiquidLib -> Module -> Annotation
serialiseLiquidLib LiquidLib
lib = forall a. (Binary a, Typeable a) => a -> Module -> Annotation
serialiseBinaryObject @LiquidLib LiquidLib
lib

deserialiseLiquidLib :: Module -> ExternalPackageState -> HomePackageTable -> Maybe LiquidLib
deserialiseLiquidLib :: Module
-> ExternalPackageState -> HomePackageTable -> Maybe LiquidLib
deserialiseLiquidLib Module
thisModule = forall a.
(Typeable a, Binary a) =>
Module -> ExternalPackageState -> HomePackageTable -> Maybe a
deserialiseBinaryObject @LiquidLib Module
thisModule

deserialiseLiquidLibFromEPS :: Module -> ExternalPackageState -> Maybe LiquidLib
deserialiseLiquidLibFromEPS :: Module -> ExternalPackageState -> Maybe LiquidLib
deserialiseLiquidLibFromEPS = forall a.
(Typeable a, Binary a) =>
Module -> ExternalPackageState -> Maybe a
deserialiseBinaryObjectFromEPS @LiquidLib