{-# LANGUAGE TemplateHaskell #-}

module Control.Exception.Hierarchy (
	ExceptionHierarchy(..), exceptionHierarchy ) where

-- import Control.Applicative
import Control.Exception
import Data.Typeable
import Data.Char
import Language.Haskell.TH

data ExceptionHierarchy
	= ExNode String [ExceptionHierarchy]
	| ExType Name
	deriving Int -> ExceptionHierarchy -> ShowS
[ExceptionHierarchy] -> ShowS
ExceptionHierarchy -> String
(Int -> ExceptionHierarchy -> ShowS)
-> (ExceptionHierarchy -> String)
-> ([ExceptionHierarchy] -> ShowS)
-> Show ExceptionHierarchy
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExceptionHierarchy -> ShowS
showsPrec :: Int -> ExceptionHierarchy -> ShowS
$cshow :: ExceptionHierarchy -> String
show :: ExceptionHierarchy -> String
$cshowList :: [ExceptionHierarchy] -> ShowS
showList :: [ExceptionHierarchy] -> ShowS
Show

exceptionHierarchy :: Maybe Name -> ExceptionHierarchy -> DecsQ
exceptionHierarchy :: Maybe Name -> ExceptionHierarchy -> DecsQ
exceptionHierarchy Maybe Name
mc (ExNode String
e [ExceptionHierarchy]
es) = ([[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec]) -> ([[Dec]] -> [[Dec]]) -> [[Dec]] -> [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) (([[Dec]] -> [[Dec]]) -> [[Dec]] -> [Dec])
-> ([Dec] -> [[Dec]] -> [[Dec]]) -> [Dec] -> [[Dec]] -> [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:)
	([Dec] -> [[Dec]] -> [Dec]) -> DecsQ -> Q ([[Dec]] -> [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Name -> Name -> Bool -> DecsQ
exception1 Maybe Name
mc (String -> Name
mkName String
e) Bool
True
	Q ([[Dec]] -> [Dec]) -> Q [[Dec]] -> DecsQ
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ExceptionHierarchy -> DecsQ) -> [ExceptionHierarchy] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Maybe Name -> ExceptionHierarchy -> DecsQ
exceptionHierarchy (Maybe Name -> ExceptionHierarchy -> DecsQ)
-> (Name -> Maybe Name) -> Name -> ExceptionHierarchy -> DecsQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> ExceptionHierarchy -> DecsQ)
-> Name -> ExceptionHierarchy -> DecsQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
e) [ExceptionHierarchy]
es
exceptionHierarchy Maybe Name
mc (ExType Name
e) = Maybe Name -> Name -> Bool -> DecsQ
exception1 Maybe Name
mc Name
e Bool
False

exception1 :: Maybe Name -> Name -> Bool -> DecsQ
exception1 :: Maybe Name -> Name -> Bool -> DecsQ
exception1 Maybe Name
mc Name
e Bool
c = (:)
	(Dec -> [Dec] -> [Dec]) -> Q Dec -> Q ([Dec] -> [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Dec -> (Name -> Q Dec) -> Maybe Name -> Q Dec
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Name -> Q Dec
defInstException Name
e) (Name -> Name -> Q Dec
`instException` Name
e) Maybe Name
mc
	Q ([Dec] -> [Dec]) -> DecsQ -> DecsQ
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> if Bool
c then Name -> DecsQ
exceptionContainer Name
e else [Dec] -> DecsQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []

myClassP :: Name -> [Q Type] -> Q Pred
myClassP :: Name -> [Q Type] -> Q Type
myClassP Name
cla [Q Type]
tys = do
	[Type]
tysl <- [Q Type] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q Type]
tys
	Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
cla) [Type]
tysl)

myNotStrict :: Q Strict
myNotStrict :: Q Strict
myNotStrict = Q SourceUnpackedness -> Q SourceStrictness -> Q Strict
forall (m :: * -> *).
Quote m =>
m SourceUnpackedness -> m SourceStrictness -> m Strict
bang Q SourceUnpackedness
forall (m :: * -> *). Quote m => m SourceUnpackedness
noSourceUnpackedness Q SourceStrictness
forall (m :: * -> *). Quote m => m SourceStrictness
noSourceStrictness

exceptionContainer :: Name -> DecsQ
exceptionContainer :: Name -> DecsQ
exceptionContainer Name
ec = [Q Dec] -> DecsQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [
	do	TyVarBndr Specificity
tv <- Name -> Specificity -> Q (TyVarBndr Specificity)
forall (m :: * -> *).
Quote m =>
Name -> Specificity -> m (TyVarBndr Specificity)
plainInvisTV Name
e Specificity
specifiedSpec
		Q [Type]
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Q Con]
-> [Q DerivClause]
-> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type]
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [m Con]
-> [m DerivClause]
-> m Dec
dataD ([Q Type] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt []) Name
he [] Maybe Type
forall a. Maybe a
Nothing
			[[TyVarBndr Specificity] -> Q [Type] -> Q Con -> Q Con
forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m [Type] -> m Con -> m Con
forallC [TyVarBndr Specificity
tv] ([Q Type] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt [Name -> [Q Type] -> Q Type
myClassP ''Exception [Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
e]]) (Q Con -> Q Con) -> Q Con -> Q Con
forall a b. (a -> b) -> a -> b
$
				Name -> [Q BangType] -> Q Con
forall (m :: * -> *). Quote m => Name -> [m BangType] -> m Con
normalC Name
he [Q Strict -> Q Type -> Q BangType
forall (m :: * -> *). Quote m => m Strict -> m Type -> m BangType
bangType Q Strict
myNotStrict (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
e)]]
			[Maybe DerivStrategy -> [Q Type] -> Q DerivClause
forall (m :: * -> *).
Quote m =>
Maybe DerivStrategy -> [m Type] -> m DerivClause
derivClause Maybe DerivStrategy
forall a. Maybe a
Nothing [Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Typeable]],
	Q [Type] -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD ([Q Type] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt []) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Show Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
he)
		[Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'showsPrec
			[[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
d, Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
he [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
e]]
				(Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'showsPrec Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
d Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
e) []]],
	do	TyVarBndr Specificity
tv <- Name -> Specificity -> Q (TyVarBndr Specificity)
forall (m :: * -> *).
Quote m =>
Name -> Specificity -> m (TyVarBndr Specificity)
plainInvisTV Name
e Specificity
specifiedSpec
		Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
toEx (Q Type -> Q Dec) -> (Q Type -> Q Type) -> Q Type -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TyVarBndr Specificity] -> Q [Type] -> Q Type -> Q Type
forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m [Type] -> m Type -> m Type
forallT [TyVarBndr Specificity
tv] ([Q Type] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt [Name -> [Q Type] -> Q Type
myClassP ''Exception [Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
e]]) (Q Type -> Q Dec) -> Q Type -> Q Dec
forall a b. (a -> b) -> a -> b
$
			Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
e Q Type -> Q Type -> Q Type
`arrT` Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''SomeException,
	Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
toEx)
		(Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Maybe (Q Exp) -> Q Exp -> Maybe (Q Exp) -> Q Exp
forall (m :: * -> *).
Quote m =>
Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
infixE
			(Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just (Q Exp -> Maybe (Q Exp)) -> Q Exp -> Maybe (Q Exp)
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'toException) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE '(.)) (Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just (Q Exp -> Maybe (Q Exp)) -> Q Exp -> Maybe (Q Exp)
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
he))
		[],
	do	TyVarBndr Specificity
tv <- Name -> Specificity -> Q (TyVarBndr Specificity)
forall (m :: * -> *).
Quote m =>
Name -> Specificity -> m (TyVarBndr Specificity)
plainInvisTV Name
e Specificity
specifiedSpec
		Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
fromEx (Q Type -> Q Dec) -> (Q Type -> Q Type) -> Q Type -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TyVarBndr Specificity] -> Q [Type] -> Q Type -> Q Type
forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m [Type] -> m Type -> m Type
forallT [TyVarBndr Specificity
tv] ([Q Type] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt [Name -> [Q Type] -> Q Type
myClassP ''Exception [Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
e]]) (Q Type -> Q Dec) -> Q Type -> Q Dec
forall a b. (a -> b) -> a -> b
$
			Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''SomeException Q Type -> Q Type -> Q Type
`arrT` (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Maybe Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
e),
	Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
fromEx [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
		[Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
se]
		(Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ [Q Stmt] -> Q Exp
forall (m :: * -> *). Quote m => [m Stmt] -> m Exp
doE [
			Q Pat -> Q Exp -> Q Stmt
forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Stmt
bindS (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
he [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
e])
				(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'fromException Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
se),
			Q Exp -> Q Stmt
forall (m :: * -> *). Quote m => m Exp -> m Stmt
noBindS (Q Exp -> Q Stmt) -> Q Exp -> Q Stmt
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'cast Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
e])
		[]]
	]
	where
	he :: Name
he = Name
ec
	ec' :: String
ec' = ShowS
toLowerH ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
ec
	ec'' :: String
ec'' = String -> ShowS -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
ec' (String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Char
'.' Char -> ShowS
forall a. a -> [a] -> [a]
: String
ec')) (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ Name -> Maybe String
nameModule Name
ec
	toEx :: Name
toEx = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
ec'' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"ToException"
	fromEx :: Name
fromEx = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
ec'' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"FromException"
	e :: Name
e = String -> Name
mkName String
"e"
	se :: Name
se = String -> Name
mkName String
"se"
	d :: Name
d = String -> Name
mkName String
"d"

defInstException :: Name -> DecQ
defInstException :: Name -> Q Dec
defInstException Name
e = Q [Type] -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD ([Q Type] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt []) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Exception Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
e) []

infixr `arrT`
arrT :: TypeQ -> TypeQ -> TypeQ
arrT :: Q Type -> Q Type -> Q Type
arrT Q Type
t1 Q Type
t2 = Q Type
forall (m :: * -> *). Quote m => m Type
arrowT Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
t1 Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
t2

instException :: Name -> Name -> DecQ
instException :: Name -> Name -> Q Dec
instException Name
ec Name
e = Q [Type] -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD ([Q Type] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt [])
	(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Exception Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
e) [
		Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (Name -> Q Pat) -> Name -> Q Pat
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"toException") (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
te) [],
		Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (Name -> Q Pat) -> Name -> Q Pat
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"fromException") (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fe) [] ]
	where
	ec' :: String
ec' = ShowS
toLowerH ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
ec
	ec'' :: String
ec'' = String -> ShowS -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
ec' (String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Char
'.' Char -> ShowS
forall a. a -> [a] -> [a]
: String
ec')) (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ Name -> Maybe String
nameModule Name
ec
	te :: Name
te = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
ec'' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"ToException"
	fe :: Name
fe = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
ec'' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"FromException"

toLowerH :: String -> String
toLowerH :: ShowS
toLowerH (Char
c : String
cs) = Char -> Char
toLower Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: String
cs
toLowerH String
_ = String
""