{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE CPP, TemplateHaskell #-}
module GHC.Check.Util (MyVersion(..), liftTyped, gcatchSafe) where

import           Control.Exception.Safe
import           Control.Monad.IO.Class (MonadIO(liftIO))
import           Data.Version ( Version, parseVersion )
import           GHC (Ghc, gcatch)
import           GHC.Exts                   (IsList (fromList), toList)
import           Language.Haskell.TH ( TExpQ )
import           Language.Haskell.TH.Syntax as TH
import qualified Text.Read as Read

-- | A wrapper around 'Version' with TH lifting
newtype MyVersion = MyVersion Version
  deriving (MyVersion -> MyVersion -> Bool
(MyVersion -> MyVersion -> Bool)
-> (MyVersion -> MyVersion -> Bool) -> Eq MyVersion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MyVersion -> MyVersion -> Bool
$c/= :: MyVersion -> MyVersion -> Bool
== :: MyVersion -> MyVersion -> Bool
$c== :: MyVersion -> MyVersion -> Bool
Eq, Int -> [Item MyVersion] -> MyVersion
[Item MyVersion] -> MyVersion
MyVersion -> [Item MyVersion]
([Item MyVersion] -> MyVersion)
-> (Int -> [Item MyVersion] -> MyVersion)
-> (MyVersion -> [Item MyVersion])
-> IsList MyVersion
forall l.
([Item l] -> l)
-> (Int -> [Item l] -> l) -> (l -> [Item l]) -> IsList l
toList :: MyVersion -> [Item MyVersion]
$ctoList :: MyVersion -> [Item MyVersion]
fromListN :: Int -> [Item MyVersion] -> MyVersion
$cfromListN :: Int -> [Item MyVersion] -> MyVersion
fromList :: [Item MyVersion] -> MyVersion
$cfromList :: [Item MyVersion] -> MyVersion
IsList, Int -> MyVersion -> ShowS
[MyVersion] -> ShowS
MyVersion -> String
(Int -> MyVersion -> ShowS)
-> (MyVersion -> String)
-> ([MyVersion] -> ShowS)
-> Show MyVersion
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MyVersion] -> ShowS
$cshowList :: [MyVersion] -> ShowS
show :: MyVersion -> String
$cshow :: MyVersion -> String
showsPrec :: Int -> MyVersion -> ShowS
$cshowsPrec :: Int -> MyVersion -> ShowS
Show)

instance Lift MyVersion where
#if MIN_VERSION_template_haskell(2,16,0)
    liftTyped :: MyVersion -> Q (TExp MyVersion)
liftTyped = MyVersion -> Q (TExp MyVersion)
liftMyVersion
#endif
    lift :: MyVersion -> Q Exp
lift = Q (TExp MyVersion) -> Q Exp
forall a. Q (TExp a) -> Q Exp
unTypeQ (Q (TExp MyVersion) -> Q Exp)
-> (MyVersion -> Q (TExp MyVersion)) -> MyVersion -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MyVersion -> Q (TExp MyVersion)
liftMyVersion

instance Read MyVersion where
  readPrec :: ReadPrec MyVersion
readPrec = ReadP MyVersion -> ReadPrec MyVersion
forall a. ReadP a -> ReadPrec a
Read.lift (ReadP MyVersion -> ReadPrec MyVersion)
-> ReadP MyVersion -> ReadPrec MyVersion
forall a b. (a -> b) -> a -> b
$ Version -> MyVersion
MyVersion (Version -> MyVersion) -> ReadP Version -> ReadP MyVersion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP Version
parseVersion

liftMyVersion :: MyVersion -> TExpQ MyVersion
liftMyVersion :: MyVersion -> Q (TExp MyVersion)
liftMyVersion MyVersion
ver = do
    Exp
verLifted <- [Int] -> Q Exp
forall t. Lift t => t -> Q Exp
TH.lift (MyVersion -> [Item MyVersion]
forall l. IsList l => l -> [Item l]
toList MyVersion
ver)
    [|| fromList $$(pure $ TExp verLifted) ||]

#if !MIN_VERSION_template_haskell(2,16,0)
liftTyped :: Lift a => a -> TExpQ a
liftTyped = unsafeTExpCoerce . lift
#endif

gcatchSafe :: forall e a . Exception e => Ghc a -> (e -> Ghc a) -> Ghc a
gcatchSafe :: Ghc a -> (e -> Ghc a) -> Ghc a
gcatchSafe Ghc a
act e -> Ghc a
h = Ghc a
act Ghc a -> (e -> Ghc a) -> Ghc a
forall (m :: * -> *) e a.
(ExceptionMonad m, Exception e) =>
m a -> (e -> m a) -> m a
`gcatch` e -> Ghc a
rethrowAsyncExceptions
  where
      rethrowAsyncExceptions :: e -> Ghc a
      rethrowAsyncExceptions :: e -> Ghc a
rethrowAsyncExceptions e
e
        | e -> Bool
forall e. Exception e => e -> Bool
isAsyncException e
e = IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> Ghc a) -> (e -> IO a) -> e -> Ghc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (e -> Ghc a) -> e -> Ghc a
forall a b. (a -> b) -> a -> b
$ e
e
        | Bool
otherwise = e -> Ghc a
h e
e