{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module ExceptionVia
(
type (<!!!)
, ExceptionVia(..)
, mkHierarchy
, Hierarchy(..)
) where
import Control.Exception
import Control.Monad
import Data.Typeable
import Debug.Trace
import Language.Haskell.TH
import Language.Haskell.TH.Quote
newtype ExceptionVia big lil = ExceptionVia { forall big lil. ExceptionVia big lil -> lil
unExceptionVia :: lil }
deriving Int -> ExceptionVia big lil -> ShowS
[ExceptionVia big lil] -> ShowS
ExceptionVia big lil -> String
(Int -> ExceptionVia big lil -> ShowS)
-> (ExceptionVia big lil -> String)
-> ([ExceptionVia big lil] -> ShowS)
-> Show (ExceptionVia big lil)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall big lil. Show lil => Int -> ExceptionVia big lil -> ShowS
forall big lil. Show lil => [ExceptionVia big lil] -> ShowS
forall big lil. Show lil => ExceptionVia big lil -> String
$cshowsPrec :: forall big lil. Show lil => Int -> ExceptionVia big lil -> ShowS
showsPrec :: Int -> ExceptionVia big lil -> ShowS
$cshow :: forall big lil. Show lil => ExceptionVia big lil -> String
show :: ExceptionVia big lil -> String
$cshowList :: forall big lil. Show lil => [ExceptionVia big lil] -> ShowS
showList :: [ExceptionVia big lil] -> ShowS
Show
instance (Hierarchy big, Exception big, Exception lil) => Exception (ExceptionVia big lil) where
toException :: ExceptionVia big lil -> SomeException
toException (ExceptionVia lil
e) = big -> SomeException
forall e. Exception e => e -> SomeException
toException (forall big lil. (Hierarchy big, Exception lil) => lil -> big
toParent @big lil
e)
fromException :: SomeException -> Maybe (ExceptionVia big lil)
fromException SomeException
e =
lil -> ExceptionVia big lil
forall big lil. lil -> ExceptionVia big lil
ExceptionVia
(lil -> ExceptionVia big lil)
-> Maybe lil -> Maybe (ExceptionVia big lil)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (big -> Maybe lil
forall lil. Exception lil => big -> Maybe lil
forall big lil. (Hierarchy big, Exception lil) => big -> Maybe lil
fromParent (big -> Maybe lil) -> Maybe big -> Maybe lil
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall e. Exception e => SomeException -> Maybe e
fromException @big SomeException
e)
type lil <!!! big = ExceptionVia big lil
class (Typeable big) => Hierarchy big where
toParent :: Exception lil => lil -> big
fromParent :: (Exception lil) => big -> Maybe lil
mkHierarchy :: Name -> DecsQ
mkHierarchy :: Name -> DecsQ
mkHierarchy Name
nm = do
Info
info <- Name -> Q Info
reify Name
nm
Con
con <-
case Info
info of
TyConI Dec
d ->
case Dec
d of
DataD Cxt
_ Name
_ [TyVarBndr ()]
_ Maybe Kind
_ [Con
con] [DerivClause]
_ ->
Con -> Q Con
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Con
con
NewtypeD Cxt
_ Name
_ [TyVarBndr ()]
_ Maybe Kind
_ Con
con [DerivClause]
_ ->
Con -> Q Con
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Con
con
DataInstD Cxt
_ Maybe [TyVarBndr ()]
_ Kind
_ Maybe Kind
_ [Con
con] [DerivClause]
_ ->
Con -> Q Con
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Con
con
NewtypeInstD Cxt
_ Maybe [TyVarBndr ()]
_ Kind
_ Maybe Kind
_ Con
con [DerivClause]
_ ->
Con -> Q Con
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Con
con
Dec
_ ->
String -> Q Con
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unsupported type constructor. Must have a single constructor."
let
getConName :: Con -> f Name
getConName Con
c =
case Con
c of
NormalC Name
n [BangType]
_ ->
Name -> f Name
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
RecC Name
n [VarBangType]
_ ->
Name -> f Name
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
ForallC [TyVarBndr Specificity]
_ Cxt
_ Con
c ->
Con -> f Name
getConName Con
c
GadtC [Name
n] [BangType]
_ Kind
_ ->
Name -> f Name
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
RecGadtC [Name
n] [VarBangType]
_ Kind
_ ->
Name -> f Name
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
Con
_ ->
String -> f Name
forall a. String -> f a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Can't use with an infix constructor. Must have a single argument."
Name
constrName <- Con -> Q Name
forall {f :: * -> *}. MonadFail f => Con -> f Name
getConName Con
con
[d|
instance Hierarchy $(Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT Name
nm) where
toParent = $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
constrName)
#if MIN_VERSION_template_haskell(2,18,0)
fromParent $(Pat -> Q Pat
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pat -> Q Pat) -> Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$ Name -> Cxt -> [Pat] -> Pat
ConP Name
constrName [] [Name -> Pat
VarP (String -> Name
mkName String
"e")]) = cast e
#else
fromParent $(pure $ ConP constrName [VarP (mkName "e")]) = cast e
#endif
|]