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 DatatypeNames = DatatypeNames
{ datatypeName :: DatatypeName
, constructors :: [ValueConstructor]
} deriving (Show)
data ValueConstructor = ValueConstructor
{ constructorName :: ValueConstructorName
, causeRecordName :: String
, clueRecordName :: String
} deriving (Show)
type DatatypeName = String
type ValueConstructorName = String
getDatatypeNames :: DatatypeName -> [ValueConstructorName] -> Maybe DatatypeNames
getDatatypeNames "" _ = Nothing
getDatatypeNames typeName constrNames = fmap (DatatypeNames typeName) $ mapM toValueConstructorName constrNames
where
toValueConstructorName :: ValueConstructorName -> Maybe ValueConstructor
toValueConstructorName [] = Nothing
toValueConstructorName constrName@(c:onstrName) =
let constrName' = (toLower c) : onstrName
in Just ValueConstructor { constructorName = constrName
, causeRecordName = constrName' ++ "Cause"
, clueRecordName = constrName' ++ "Clue"
}
noBang :: Bang
noBang = Bang NoSourceUnpackedness NoSourceStrictness
declareException :: DatatypeName -> [ValueConstructorName] -> DecsQ
declareException typeName constrNames = do
case getDatatypeNames typeName constrNames of
Nothing -> fail "Data.Exception.Throwable.TH.declareException requires non empty string for `typeName`"
Just typeNames -> do
typeParam <- newName "a"
let dataDec = defineDatatype typeNames typeParam
showInstanceDec <- defineShowInstanceFor typeNames
exceptionInstancDec <- defineExceptionInstanceFor typeNames
fakeConstructorDecs <- mapM defineFakeConstructor $ constructors typeNames
return $ [ dataDec
, showInstanceDec
, exceptionInstancDec
] ++ fakeConstructorDecs
where
defineDatatype :: DatatypeNames -> Name -> Dec
defineDatatype (DatatypeNames {..}) a =
let exception = mkName datatypeName
constrsCons = map (flip makeValueConstructorsCon a) constructors
in DataD []
exception [PlainTV a] Nothing
constrsCons []
makeValueConstructorsCon :: ValueConstructor -> Name -> Con
makeValueConstructorsCon (ValueConstructor {..}) a =
let constructor = mkName constructorName
causeRecord = mkName causeRecordName
clueRecord = mkName clueRecordName
in RecC constructor [ (causeRecord, noBang, ConT $ mkName "String")
, (clueRecord, noBang, VarT a)
]
defineShowInstanceFor :: DatatypeNames -> Q Dec
defineShowInstanceFor dataTypeNames@(DatatypeNames {..}) = do
let showClass = mkName "Show"
exception = mkName typeName
a <- newName "a"
showFuncDec <- declareShowFunc dataTypeNames
return $ InstanceD Nothing
[AppT (ConT showClass) (VarT a)]
(AppT (ConT showClass) (AppT (ConT exception) (VarT a)))
[showFuncDec]
declareShowFunc :: DatatypeNames -> Q Dec
declareShowFunc DatatypeNames {..} = do
let showFunc = mkName "show"
showFuncClauses <- mapM (flip makeShowFuncClause showFunc) constructors
return $ FunD showFunc showFuncClauses
where
makeShowFuncClause :: ValueConstructor -> Name -> Q Clause
makeShowFuncClause (ValueConstructor {..}) showFunc = do
let constructor = mkName constructorName
cause <- newName "cause"
return $ Clause [ConP constructor [VarP cause, WildP]]
(NormalB
(InfixE (Just . LitE . StringL $ typeName ++ ": ") (VarE $ mkName "++") (Just $ AppE (VarE showFunc) (VarE cause)))
) []
defineExceptionInstanceFor :: DatatypeNames -> Q Dec
defineExceptionInstanceFor DatatypeNames {..} = 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)))
[]
defineFakeConstructor :: ValueConstructor -> Q Dec
defineFakeConstructor ValueConstructor {..} = do
let fConstructor = mkName $ pascalToCamelCase constructorName
constructor = mkName constructorName
a <- newName "a"
return $ FunD fConstructor [
Clause [VarP a] (NormalB $ AppE (AppE (ConE constructor) (VarE a)) (TupE []))
[]
]
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