{-# 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 Show

exceptionHierarchy :: Maybe Name -> ExceptionHierarchy -> DecsQ
exceptionHierarchy mc (ExNode e es) = (concat .) . (:)
	<$> exception1 mc (mkName e) True
	<*> mapM (exceptionHierarchy . Just $ mkName e) es
exceptionHierarchy mc (ExType e) = exception1 mc e False

exception1 :: Maybe Name -> Name -> Bool -> DecsQ
exception1 mc e c = (:)
	<$> maybe (defInstException e) (`instException` e) mc
	<*> if c then exceptionContainer e else return []

myClassP :: Name -> [Q Type] -> Q Pred
myClassP cla tys = do
	tysl <- sequence tys
	return (foldl AppT (ConT cla) tysl)

myNotStrict :: Q Strict
myNotStrict = bang noSourceUnpackedness noSourceStrictness

exceptionContainer :: Name -> DecsQ
exceptionContainer ec = sequence [
	do	tv <- plainInvisTV e specifiedSpec
		dataD (cxt []) he [] Nothing
			[forallC [tv] (cxt [myClassP ''Exception [varT e]]) $
				normalC he [bangType myNotStrict (varT e)]]
			[derivClause Nothing [conT ''Typeable]],
	instanceD (cxt []) (conT ''Show `appT` conT he)
		[funD 'showsPrec
			[clause [varP d, conP he [varP e]]
				(normalB $ varE 'showsPrec `appE` varE d `appE` varE e) []]],
	do	tv <- plainInvisTV e specifiedSpec
		sigD toEx . forallT [tv] (cxt [myClassP ''Exception [varT e]]) $
			varT e `arrT` conT ''SomeException,
	valD (varP toEx)
		(normalB $ infixE
			(Just $ varE 'toException) (varE '(.)) (Just $ conE he))
		[],
	do	tv <- plainInvisTV e specifiedSpec
		sigD fromEx . forallT [tv] (cxt [myClassP ''Exception [varT e]]) $
			conT ''SomeException `arrT` (conT ''Maybe `appT` varT e),
	funD fromEx [clause
		[varP se]
		(normalB $ doE [
			bindS (conP he [varP e])
				(varE 'fromException `appE` varE se),
			noBindS $ varE 'cast `appE` varE e])
		[]]
	]
	where
	he = ec
	ec' = toLowerH $ nameBase ec
	toEx = mkName $ ec' ++ "ToException"
	fromEx = mkName $ ec' ++ "FromException"
	e = mkName "e"
	se = mkName "se"
	d = mkName "d"

defInstException :: Name -> DecQ
defInstException e = instanceD (cxt []) (conT ''Exception `appT` conT e) []

infixr `arrT`
arrT :: TypeQ -> TypeQ -> TypeQ
arrT t1 t2 = arrowT `appT` t1 `appT` t2

instException :: Name -> Name -> DecQ
instException ec e = instanceD (cxt [])
	(conT ''Exception `appT` conT e) [
		valD (varP $ mkName "toException") (normalB $ varE te) [],
		valD (varP $ mkName "fromException") (normalB $ varE fe) [] ]
	where
	ec' = toLowerH $ nameBase ec
	te = mkName $ ec' ++ "ToException"
	fe = mkName $ ec' ++ "FromException"

toLowerH :: String -> String
toLowerH (c : cs) = toLower c : cs
toLowerH _ = ""