{-# 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 [
        dataD (cxt []) he [] Nothing
                [forallC [PlainTV e] (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) []]],
        sigD toEx . forallT [PlainTV e] (cxt [myClassP ''Exception [varT e]]) $
                varT e `arrT` conT ''SomeException,
        valD (varP toEx)
                (normalB $ infixE
                        (Just $ varE 'toException) (varE '(.)) (Just $ conE he))
                [],
        sigD fromEx . forallT [PlainTV e] (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 _ = ""