From 4657c5bf49161be33b3b76ac9accf4182d15927b Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 10 Apr 2021 13:56:15 -0400 Subject: [PATCH] Attempt to fix Template Haskell problems --- src/ghc-8.10/Witch/Lift.hs | 46 +++++++++++++++++++++++++++++++++++ src/ghc-8.8/Witch/Lift.hs | 50 ++++++++++++++++++++++++++++++++++++++ src/ghc-9.0/Witch/Lift.hs | 49 +++++++++++++++++++++++++++++++++++++ src/lib/Witch.hs | 7 +++--- src/lib/Witch/Utility.hs | 36 --------------------------- witch.cabal | 9 +++++++ 6 files changed, 158 insertions(+), 39 deletions(-) create mode 100644 src/ghc-8.10/Witch/Lift.hs create mode 100644 src/ghc-8.8/Witch/Lift.hs create mode 100644 src/ghc-9.0/Witch/Lift.hs diff --git a/src/ghc-8.10/Witch/Lift.hs b/src/ghc-8.10/Witch/Lift.hs new file mode 100644 index 0000000..b82254b --- /dev/null +++ b/src/ghc-8.10/Witch/Lift.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE TypeFamilies #-} + +module Witch.Lift where + +import qualified Control.Exception as Exception +import qualified Control.Monad.IO.Class as IO +import qualified Data.Typeable as Typeable +import qualified Language.Haskell.TH.Syntax as TH +import qualified Witch.Identity as Identity +import qualified Witch.TryCast as TryCast + +liftedCast + :: ( TryCast.TryCast source target + , TH.Lift target + , Show source + , Typeable.Typeable source + , Typeable.Typeable target + ) => source + -> TH.Q (TH.TExp target) +liftedCast = either (IO.liftIO . Exception.throwIO) TH.liftTyped . TryCast.tryCast + +liftedFrom + :: forall s source target + . ( Identity.Identity s ~ source + , TryCast.TryCast source target + , TH.Lift target + , Show source + , Typeable.Typeable source + , Typeable.Typeable target + ) => source + -> TH.Q (TH.TExp target) +liftedFrom = liftedCast + +liftedInto + :: forall t source target + . ( Identity.Identity t ~ target + , TryCast.TryCast source target + , TH.Lift target + , Show source + , Typeable.Typeable source + , Typeable.Typeable target + ) => source + -> TH.Q (TH.TExp target) +liftedInto = liftedCast diff --git a/src/ghc-8.8/Witch/Lift.hs b/src/ghc-8.8/Witch/Lift.hs new file mode 100644 index 0000000..8abd6c7 --- /dev/null +++ b/src/ghc-8.8/Witch/Lift.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Witch.Lift where + +import qualified Control.Exception as Exception +import qualified Control.Monad.IO.Class as IO +import qualified Data.Typeable as Typeable +import qualified Language.Haskell.TH.Syntax as TH +import qualified Witch.Identity as Identity +import qualified Witch.TryCast as TryCast + +liftedCast + :: forall source target + . ( TryCast.TryCast source target + , TH.Lift target + , Show source + , Typeable.Typeable source + , Typeable.Typeable target + ) => source + -> TH.Q TH.Exp +liftedCast s = case TryCast.tryCast s of + Left e -> IO.liftIO $ Exception.throwIO e + Right t -> TH.lift (t :: target) + +liftedFrom + :: forall s source target + . ( Identity.Identity s ~ source + , TryCast.TryCast source target + , TH.Lift target + , Show source + , Typeable.Typeable source + , Typeable.Typeable target + ) => source + -> TH.Q TH.Exp +liftedFrom = liftedCast @source @target + +liftedInto + :: forall t source target + . ( Identity.Identity t ~ target + , TryCast.TryCast source target + , TH.Lift target + , Show source + , Typeable.Typeable source + , Typeable.Typeable target + ) => source + -> TH.Q TH.Exp +liftedInto = liftedCast @source @target diff --git a/src/ghc-9.0/Witch/Lift.hs b/src/ghc-9.0/Witch/Lift.hs new file mode 100644 index 0000000..47a8883 --- /dev/null +++ b/src/ghc-9.0/Witch/Lift.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE TypeFamilies #-} + +module Witch.Lift where + +import qualified Control.Exception as Exception +import qualified Control.Monad.IO.Class as IO +import qualified Data.Typeable as Typeable +import qualified Language.Haskell.TH.Syntax as TH +import qualified Witch.Identity as Identity +import qualified Witch.TryCast as TryCast + +liftedCast + :: ( TryCast.TryCast source target + , TH.Lift target + , Show source + , Typeable.Typeable source + , Typeable.Typeable target + , TH.Quote m + ) => source + -> TH.Code m target +liftedCast = either (TH.liftCode . IO.liftIO . Exception.throwIO) TH.liftTyped . TryCast.tryCast + +liftedFrom + :: forall s source target + . ( Identity.Identity s ~ source + , TryCast.TryCast source target + , TH.Lift target + , Show source + , Typeable.Typeable source + , Typeable.Typeable target + , TH.Quote m + ) => source + -> TH.Code m target +liftedFrom = liftedCast + +liftedInto + :: forall t source target + . ( Identity.Identity t ~ target + , TryCast.TryCast source target + , TH.Lift target + , Show source + , Typeable.Typeable source + , Typeable.Typeable target + , TH.Quote m + ) => source + -> TH.Code m target +liftedInto = liftedCast diff --git a/src/lib/Witch.hs b/src/lib/Witch.hs index 714d2cd..a26d864 100644 --- a/src/lib/Witch.hs +++ b/src/lib/Witch.hs @@ -12,12 +12,13 @@ module Witch , Witch.Utility.unsafeCast , Witch.Utility.unsafeFrom , Witch.Utility.unsafeInto - , Witch.Utility.liftedCast - , Witch.Utility.liftedFrom - , Witch.Utility.liftedInto + , Witch.Lift.liftedCast + , Witch.Lift.liftedFrom + , Witch.Lift.liftedInto ) where import qualified Witch.Cast +import qualified Witch.Lift import qualified Witch.Utility import qualified Witch.TryCast import qualified Witch.TryCastException diff --git a/src/lib/Witch/Utility.hs b/src/lib/Witch/Utility.hs index dabdb45..4e92f13 100644 --- a/src/lib/Witch/Utility.hs +++ b/src/lib/Witch/Utility.hs @@ -5,10 +5,8 @@ module Witch.Utility where import qualified Control.Exception as Exception -import qualified Control.Monad.IO.Class as IO import qualified Data.Typeable as Typeable import qualified GHC.Stack as Stack -import qualified Language.Haskell.TH.Syntax as TH import qualified Witch.Cast as Cast import qualified Witch.Identity as Identity import qualified Witch.TryCast as TryCast @@ -97,37 +95,3 @@ unsafeInto ) => source -> target unsafeInto = unsafeCast - -liftedCast - :: ( TryCast.TryCast source target - , TH.Lift target - , Show source - , Typeable.Typeable source - , Typeable.Typeable target - ) => source - -> TH.Q (TH.TExp target) -liftedCast = either (IO.liftIO . Exception.throwIO) TH.liftTyped . TryCast.tryCast - -liftedFrom - :: forall s source target - . ( Identity.Identity s ~ source - , TryCast.TryCast source target - , TH.Lift target - , Show source - , Typeable.Typeable source - , Typeable.Typeable target - ) => source - -> TH.Q (TH.TExp target) -liftedFrom = liftedCast - -liftedInto - :: forall t source target - . ( Identity.Identity t ~ target - , TryCast.TryCast source target - , TH.Lift target - , Show source - , Typeable.Typeable source - , Typeable.Typeable target - ) => source - -> TH.Q (TH.TExp target) -liftedInto = liftedCast diff --git a/witch.cabal b/witch.cabal index 0ac10cf..9867794 100644 --- a/witch.cabal +++ b/witch.cabal @@ -25,6 +25,7 @@ library Witch Witch.Cast Witch.Identity + Witch.Lift Witch.TryCast Witch.TryCastException Witch.Utility @@ -41,6 +42,14 @@ library -Wno-unsafe hs-source-dirs: src/lib + if impl(ghc >= 9.0) + hs-source-dirs: src/ghc-9.0 + else + if impl(ghc >= 8.10) + hs-source-dirs: src/ghc-8.10 + else + hs-source-dirs: src/ghc-8.8 + test-suite test build-depends: base