module Control.Exception.Throwable.TH
( declareException
, DatatypeName
, ValueConstructorName
) 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 =
let constrName' = pascalToCamelCase constrName
in Just ValueConstructor { constructorName = constrName
, causeRecordName = causeRecordName constrName'
, clueRecordName = clueRecordName constrName'
}
splitBodyAndSigns :: String -> (String, String)
splitBodyAndSigns = span $ not . isPunctuation
recordName :: String -> String -> String
recordName suffix constrName' =
let (name, signs) = splitBodyAndSigns constrName'
in name ++ suffix ++ signs
causeRecordName = recordName "Cause"
clueRecordName = recordName "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 <- concat <$> mapM (defineFakeConstructor $ datatypeName typeNames) (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 [ConT showClass `AppT` VarT a]
(ConT showClass `AppT` ParensT (ConT exception `AppT` 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
[ ConT typeableClass `AppT` VarT a
, ConT showClass `AppT` VarT a
]
(ConT exceptionClass `AppT` ParensT (ConT exception `AppT` VarT a))
[]
defineFakeConstructor :: String -> ValueConstructor -> DecsQ
defineFakeConstructor typeName (ValueConstructor {..}) = do
let datatype = mkName typeName
fConstructor = mkName $ pascalToCamelCase constructorName
constructor = mkName constructorName
x <- newName "x"
let sig = SigD fConstructor $ ArrowT `AppT` ConT (mkName "String") `AppT` (ConT datatype `AppT` TupleT 0)
let impl = FunD fConstructor [
Clause [VarP x] (NormalB $ ConE constructor `AppE` VarE x `AppE` TupE [])
[]
]
return [sig, impl]
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