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

import           Control.Exception.Safe as Safe
import           Control.Monad.IO.Class (MonadIO(liftIO))
import           Data.Version ( Version, parseVersion )
import           GHC (Ghc)
import qualified GHC
import           GHC.Exts                   (IsList (fromList), toList)
import           Language.Haskell.TH ( TExpQ )
import           Language.Haskell.TH.Syntax as TH
import           Language.Haskell.TH.Syntax.Compat
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
#else
    lift = unTypeQ . liftMyVersion
#endif
    -- lift = unTypeCode . 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

#if MIN_VERSION_template_haskell(2,17,0)
liftMyVersion :: (Quote m) => MyVersion -> Splice m MyVersion
#else
liftMyVersion :: MyVersion -> TExpQ MyVersion
#endif
liftMyVersion :: MyVersion -> Q (TExp MyVersion)
liftMyVersion MyVersion
ver = Q (TExp MyVersion) -> Q (TExp MyVersion)
forall a (m :: * -> *). m (TExp a) -> m (TExp a)
liftSplice (Q (TExp MyVersion) -> Q (TExp MyVersion))
-> Q (TExp MyVersion) -> Q (TExp MyVersion)
forall a b. (a -> b) -> a -> b
$ do
    Exp
verLifted <- [Int] -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
liftQuote (MyVersion -> [Item MyVersion]
forall l. IsList l => l -> [Item l]
toList MyVersion
ver)
    Q (TExp MyVersion) -> Q (TExp MyVersion)
forall (m :: * -> *) a. Splice m a -> Splice m a
examineSplice [|| fromList $$( liftSplice . 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
#if MIN_VERSION_ghc(9,0,1)
gcatchSafe = Safe.catch
#else
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
`GHC.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
#endif