module Control.Exception.Throwable.TH
( declareException
) where
import Data.Char (toLower, isUpper, isPunctuation, isNumber)
import Language.Haskell.TH ( Bang(..), DecsQ, newName, mkName
, Dec(..), TyVarBndr(..), Con(..), Type(..)
, SourceUnpackedness(..), SourceStrictness(..)
, Q, Name, Exp(..)
, Lit(..), Pat(..), Clause(..), Body(..)
)
data ExceptionDataNames = ExceptionDataNames
{ typeName :: String
, causeRecordName :: String
, clueRecordName :: String
}
pascalToCamelCase :: String -> String
pascalToCamelCase pascalCase
| upperIsCont pascalCase = forUpperContCase pascalCase
| signInMiddle pascalCase = forSignMiddleCase pascalCase
| otherwise = forCasualCase pascalCase
where
upperIsCont :: String -> Bool
upperIsCont "" = False
upperIsCont (_:a:_) = isUpper a
upperIsCont (_:_) = False
signInMiddle :: String -> Bool
signInMiddle = any isNumber . init . tail
forUpperContCase :: String -> String
forUpperContCase pascalCase =
let (pascalCase', signs) = span (not . isPunctuation) pascalCase
(p:ascalCase) = pascalCase'
p' = toLower p
(ascal, case_) = span isUpper ascalCase
(l:acsa) = reverse ascal
asca = map toLower $ reverse acsa
in p':asca ++ l:case_ ++ signs
forSignMiddleCase :: String -> String
forSignMiddleCase pascal0Case =
let (pascal, _0Case) = span (not . isNumber) pascal0Case
pascal' = map toLower pascal
in pascal' ++ _0Case
forCasualCase :: String -> String
forCasualCase pascalCase =
let (p:ascalCase) = pascalCase
p' = toLower p
in p' : ascalCase
declareException :: String -> DecsQ
declareException exceptionName = do
typeParam <- newName "a"
let typeNames = getTypeNames exceptionName
dataDec = defineDatatype typeNames typeParam
showInstanceDec <- defineShowInstanceFor typeNames
exceptionInstancDec <- defineExceptionInstanceFor typeNames
fakeConstructorDec <- defineFakeConstructorFor typeNames
return [ dataDec
, showInstanceDec
, exceptionInstancDec
, fakeConstructorDec
]
where
noBang :: Bang
noBang = Bang NoSourceUnpackedness NoSourceStrictness
getTypeNames :: String -> ExceptionDataNames
getTypeNames exceptionName =
let (e:xceptionName) = exceptionName
camelExceptionName = (toLower e) : xceptionName
in ExceptionDataNames { typeName = exceptionName
, causeRecordName = camelExceptionName ++ "Cause"
, clueRecordName = camelExceptionName ++ "Clue"
}
defineDatatype :: ExceptionDataNames -> Name -> Dec
defineDatatype (ExceptionDataNames {..}) a =
let exception = mkName typeName
causeRecord = mkName causeRecordName
clueRecord = mkName clueRecordName
in DataD []
exception [PlainTV a] Nothing
[ RecC exception [ (causeRecord, noBang, ConT $ mkName "String")
, (clueRecord, noBang, VarT a)
]
] []
defineShowInstanceFor :: ExceptionDataNames -> Q Dec
defineShowInstanceFor exceptionDataNames@(ExceptionDataNames {..}) = do
let showClass = mkName "Show"
exception = mkName typeName
a <- newName "a"
showImpl <- declareShowFunc exceptionDataNames
return $ InstanceD Nothing
[AppT (ConT showClass) (VarT a)]
(AppT (ConT showClass) (AppT (ConT exception) (VarT a)))
[showImpl]
defineExceptionInstanceFor :: ExceptionDataNames -> Q Dec
defineExceptionInstanceFor exceptionDataNames@(ExceptionDataNames {..}) = do
let typeableClass = mkName "Typeable"
showClass = mkName "Show"
exceptionClass = mkName "Exception"
exception = mkName typeName
a <- newName "a"
return $ InstanceD Nothing
[ AppT (ConT typeableClass) (VarT a)
, AppT (ConT showClass) (VarT a)
]
(AppT (ConT exceptionClass) (AppT (ConT exception) (VarT a)))
[]
declareShowFunc :: ExceptionDataNames -> Q Dec
declareShowFunc ExceptionDataNames {..} = do
let exception = mkName typeName
showFunc = mkName "show"
cause <- newName "cause"
return $ FunD showFunc [
Clause [ConP exception [VarP cause, WildP]] (NormalB
(InfixE (Just . LitE . StringL $ typeName ++ ": ") (VarE $ mkName "++") (Just $ AppE (VarE showFunc) (VarE cause)))
) []
]
defineFakeConstructorFor :: ExceptionDataNames -> Q Dec
defineFakeConstructorFor ExceptionDataNames {..} = do
let fConstructor = mkName $ pascalToCamelCase exceptionName
exception = mkName typeName
a <- newName "a"
return $ FunD fConstructor [
Clause [VarP a] (NormalB $ AppE (AppE (ConE exception) (VarE a)) (TupE []))
[]
]