{-# 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExceptionHierarchy] -> ShowS
$cshowList :: [ExceptionHierarchy] -> ShowS
show :: ExceptionHierarchy -> String
$cshow :: ExceptionHierarchy -> String
showsPrec :: Int -> ExceptionHierarchy -> ShowS
$cshowsPrec :: Int -> ExceptionHierarchy -> ShowS
Show

exceptionHierarchy :: Maybe Name -> ExceptionHierarchy -> DecsQ
exceptionHierarchy :: Maybe Name -> ExceptionHierarchy -> DecsQ
exceptionHierarchy Maybe Name
mc (ExNode String
e [ExceptionHierarchy]
es) = (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:)
	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
	forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe Name -> ExceptionHierarchy -> DecsQ
exceptionHierarchy forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just 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 = (:)
	forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Name -> DecQ
defInstException Name
e) (Name -> Name -> DecQ
`instException` Name
e) Maybe Name
mc
	forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> if Bool
c then Name -> DecsQ
exceptionContainer Name
e else 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 <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q Type]
tys
	forall (m :: * -> *) a. Monad m => a -> m a
return (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 = forall (m :: * -> *).
Quote m =>
m SourceUnpackedness -> m SourceStrictness -> m Strict
bang forall (m :: * -> *). Quote m => m SourceUnpackedness
noSourceUnpackedness forall (m :: * -> *). Quote m => m SourceStrictness
noSourceStrictness

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

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

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