tfausak/witch
1
1
Fork 0
mirror of https://github.com/tfausak/witch.git synced 2024-11-29 22:57:21 +03:00
Code Issues Packages Projects Releases Wiki Activity

Attempt to fix Template Haskell problems

Browse Source
This commit is contained in:
Taylor Fausak 2021-04-10 13:56:15 -04:00
parent 5484556515
commit 4657c5bf49
6 changed files with 158 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
src/ghc-8.10/Witch/Lift.hs Normal file
View File

@ -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

50
src/ghc-8.8/Witch/Lift.hs Normal file
View File

@ -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

49
src/ghc-9.0/Witch/Lift.hs Normal file
View File

@ -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

7
src/lib/Witch.hs
View File

@ -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

36
src/lib/Witch/Utility.hs
View File

@ -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

9
witch.cabal
View File

@ -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