throwable-exceptions 0.1.0.6 → 0.1.0.7
raw patch · 6 files changed
+242/−139 lines, 6 files
Files
- README.md +33/−7
- example/Main.hs +31/−3
- src/Control/Exception/Throwable.hs +3/−3
- src/Control/Exception/Throwable/TH.hs +166/−121
- test/Control/Exception/Throwable/THTest.hs +8/−4
- throwable-exceptions.cabal +1/−1
README.md view
@@ -34,19 +34,45 @@ {-# LANGUAGE TemplateHaskell #-} module Main where -declareException "MyException"--- ^^^--- This is same to write below line yourself--- data MyException a = MyException--- { myExceptionCause :: String--- , MyExceptionClue :: a -- } deriving (Show, Typeable)--- instance (Typeable a, Show a) => Exception (MyException a)+-- This is same as+--+-- data MyException a = MyException+-- { myExceptionCause :: String+-- , myExceptionClue :: a+-- } deriving (Show, Typeable)+-- instance (Typeable a, Show a) => Exception (MyException a)+--+declareException "MyException" ["MyException"] +-- This is same as+--+-- data TwoException a =+-- FirstException+-- { firstExceptionCause :: String+-- , firstExceptionClue :: a+-- } |+-- SecondException+-- { secondExceptionCause :: String+-- , secondExceptionClue :: a+-- } deriving (Typeable)+--+-- instance Show a => (TwoException a) where+-- ...+-- instance (Typeable a, Show a) => Exception (TwoException a)+--+declareException "TwoException" ["FirstException", "SecondException"]+ main :: IO () main = do+ print $ ([1..4] `at` 5 :: Either SomeException Int) print $ MyException "hi" 10 print $ myException "poi"+ print $ firstException "chino"+ print $ secondException "cocoa" ```++- the completely example+ - in [example/Main.hs](https://github.com/aiya000/hs-throwable-exceptions/blob/master/example/Main.hs) - - -
example/Main.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} +-- | This is referenced from README.md module Main where import Control.Exception.Safe (throwM, MonadCatch, catch, SomeException)@@ -16,19 +17,46 @@ -- -- data MyException a = MyException -- { myExceptionCause :: String--- , MyExceptionClue :: a--- } deriving (Show, Typeable)+-- , myExceptionClue :: a+-- } deriving (Typeable)+--+-- instance Show a => Show (MyException a) where+-- ... -- instance (Typeable a, Show a) => Exception (MyException a) ---declareException "MyException"+declareException "MyException" ["MyException"]+-- ^ the second argument (the list of String) will be made as a value constructor. +-- This is same as+--+-- data TwoException a =+-- FirstException+-- { firstExceptionCause :: String+-- , firstExceptionClue :: a+-- } |+-- SecondException+-- { secondExceptionCause :: String+-- , secondExceptionClue :: a+-- } deriving (Typeable)+--+-- instance Show a => (TwoException a) where+-- ...+-- instance (Typeable a, Show a) => Exception (TwoException a)+--+declareException "TwoException" ["FirstException", "SecondException"] + main :: IO () main = do print $ ([1..4] `at` 5 :: Either SomeException Int) print $ MyException "hi" 10 print $ myException "poi"+ -- ^ a (fake) value constructor,+ -- this is same as `MyException` but without a clue value. print (foo :: Either SomeException Int)+ print $ FirstException "chino" 20+ print $ firstException "cocoa"+ print $ secondException "rize" -- -- vvv output result vvv --
src/Control/Exception/Throwable.hs view
@@ -41,6 +41,6 @@ generalException name cause = GeneralException name cause () -declareException "IOException'"-declareException "IndexOutOfBoundsException"-declareException "IllegalArgumentException"+declareException "IOException'" ["IOException'", "FileNotFoundException"]+declareException "IndexOutOfBoundsException" ["IndexOutOfBoundsException"]+declareException "IllegalArgumentException" ["IllegalArgumentException"]
src/Control/Exception/Throwable/TH.hs view
@@ -10,34 +10,181 @@ ) 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(..)- )+import Language.Haskell.TH ( Bang(..), DecsQ, newName, mkName, Dec(..), TyVarBndr(..), Con(..), Type(..), SourceUnpackedness(..), SourceStrictness(..), Q, Name, Exp(..), Lit(..), Pat(..), Clause(..), Body(..)) -- |+-- Mean names of a data type and its value constructors+-- -- @--- data IOException' a = IOException--- { ioExceptionCause :: String--- , ioExceptionClue :: a--- }--- ==> do--- a <- newName "a"--- ExceptionDataNames { typeName = mkName "IOException'"--- , causeRecordName = mkName "ioExceptionCause"--- , clueRecordName = mkName "ioExceptionClue"--- }+-- data IOException' a =+-- IOException'+-- { ioExceptionCause :: String+-- , ioExceptionClue :: a+-- } |+-- FileNotFoundException+-- { fileNotFoundExceptionCause :: String+-- , fileNotFoundExceptionClue :: a+-- }+-- ==>+-- DatatypeNames+-- { typeName = mkName "IOException'"+-- , constructors =+-- [ ValueConstructor+-- { constrName = "IOException'"+-- , causeRecordName = mkName "ioExceptionCause"+-- , clueRecordName = mkName "ioExceptionClue"+-- }+-- , ValueConstructor+-- { constrName = "FileNotFoundException"+-- , causeRecordName = mkName "fileNotFoundExceptionCause"+-- , clueRecordName = mkName "fileNotFoundExceptionClue"+-- }+-- ]+-- } -- @-data ExceptionDataNames = ExceptionDataNames- { typeName :: String+data DatatypeNames = DatatypeNames+ { datatypeName :: DatatypeName+ , constructors :: [ValueConstructor]+ } deriving (Show)++-- | Mean a name of a value constructor and its records+data ValueConstructor = ValueConstructor+ { constructorName :: ValueConstructorName , causeRecordName :: String , clueRecordName :: String- }+ } deriving (Show) +type DatatypeName = String+type ValueConstructorName = String + -- |+-- Create the value of @DatatypeNames@ by the type name.+-- That type name will be executed the instantiation for @Exception@.+--+-- @typeName@ and @constrNames@ elements must be non empty string.+-- If it is given, create Nothing.+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 -- camelCase+ in Just ValueConstructor { constructorName = constrName+ , causeRecordName = constrName' ++ "Cause"+ , clueRecordName = constrName' ++ "Clue"+ }+++-- | A natural strategy of the evaluation+noBang :: Bang+noBang = Bang NoSourceUnpackedness NoSourceStrictness+++-- |+-- Declare simple concrete exception data type in the compile time.+--+-- If the empty list is given to @constrNames@, create empty data type.+--+-- @typeName@ and @constrNames@ must be PascalCase+-- (e.g> "IOException'", "IndexOutOfBoundsException". NG> "ioException'", "indexOutOfBoundsException") .+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" -- type `a` of `data FooException a`+ let dataDec = defineDatatype typeNames typeParam+ showInstanceDec <- defineShowInstanceFor typeNames+ exceptionInstancDec <- defineExceptionInstanceFor typeNames+ fakeConstructorDecs <- mapM defineFakeConstructor $ constructors typeNames+ return $ [ dataDec+ , showInstanceDec+ , exceptionInstancDec+ ] ++ fakeConstructorDecs+ where+ -- Define a data of an exception.+ -- the data is defined by @DatatypeNames@.+ defineDatatype :: DatatypeNames -> Name -> Dec+ defineDatatype (DatatypeNames {..}) a =+ let exception = mkName datatypeName+ constrsCons = map (flip makeValueConstructorsCon a) constructors+ in DataD []+ exception [PlainTV a] Nothing+ constrsCons []++ -- Make @Con@ from @ValueConstructor@ for @defineDatatype@+ -- @a@ is @defineDatatype@'s datatype's type parameter.+ 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)+ ]++ -- Define an instance of a data of @DatatypeNames@ for @Show@.+ 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]++ -- Make a @show@ function definition.+ declareShowFunc :: DatatypeNames -> Q Dec+ declareShowFunc DatatypeNames {..} = do+ let showFunc = mkName "show"+ showFuncClauses <- mapM (flip makeShowFuncClause showFunc) constructors+ return $ FunD showFunc showFuncClauses+ where+ -- Make patterns of @show@ function (@showFunc@) implementation,+ -- for @constructors@ of @DatatypeNames@.+ makeShowFuncClause :: ValueConstructor -> Name -> Q Clause+ makeShowFuncClause (ValueConstructor {..}) showFunc = do+ let constructor = mkName constructorName+ cause <- newName "cause"+ return $ Clause [ConP constructor [VarP cause, WildP]] -- (FooException cause _) =+ (NormalB+ (InfixE (Just . LitE . StringL $ typeName ++ ": ") (VarE $ mkName "++") (Just $ AppE (VarE showFunc) (VarE cause))) -- show ("FooException: " ++ show cause)+ ) []++ -- Define an instance of a data of @DatatypeNames@ for @Exception@.+ 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)))+ []++ -- Define the casual data constructor.+ -- Like @Control.Exception.Throwable.generalException@ without name field.+ 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 []))+ []+ ]+++-- | -- Convert string of 'PascalCase' to 'camelCase'. -- If no 'PascalCase' string or multi byte string is given, undefined behavior is happended. --@@ -94,105 +241,3 @@ let (p:ascalCase) = pascalCase p' = toLower p in p' : ascalCase----- |--- Declare simple concrete exception datat type in the compile time.------ @exceptionName@ must be PascalCase--- (e.g> "IOException'", "IndexOutOfBoundsException". NG> "ioException'", "indexOutOfBoundsException") .------ And @exceptionName@ should have the suffix of "Exception".-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- -- The natural strategy of the evaluation- noBang :: Bang- noBang = Bang NoSourceUnpackedness NoSourceStrictness-- -- Create the value of @ExceptionDataNames@ by the type name.- -- That type name will be executed the instantiation for @Exception@.- getTypeNames :: String -> ExceptionDataNames- getTypeNames exceptionName =- let (e:xceptionName) = exceptionName --TODO: Guard empty pattern- camelExceptionName = (toLower e) : xceptionName- in ExceptionDataNames { typeName = exceptionName- , causeRecordName = camelExceptionName ++ "Cause"- , clueRecordName = camelExceptionName ++ "Clue"- }-- -- Define a data of an exception.- -- the data is defined by @ExceptionDataNames@.- 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)- ]- ] []-- -- Define an instance of a data of @ExceptionDataNames@ for @Show@.- 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]-- -- Define an instance of a data of @ExceptionDataNames@ for @Exception@.- defineExceptionInstanceFor :: ExceptionDataNames -> Q Dec- defineExceptionInstanceFor 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)))- []-- -- Define @show@ function implementation for @defineShowInstanceFor@.- declareShowFunc :: ExceptionDataNames -> Q Dec- declareShowFunc ExceptionDataNames {..} = do- let exception = mkName typeName- showFunc = mkName "show"- cause <- newName "cause"- return $ FunD showFunc [ -- show- Clause [ConP exception [VarP cause, WildP]] (NormalB -- (FooException cause _) =- (InfixE (Just . LitE . StringL $ typeName ++ ": ") (VarE $ mkName "++") (Just $ AppE (VarE showFunc) (VarE cause))) -- show ("FooException: " ++ show cause)- ) []- ]-- -- Define the casual data constructor.- -- Like @Control.Exception.Throwable.generalException@ without name field.- 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 []))- []- ]
test/Control/Exception/Throwable/THTest.hs view
@@ -13,14 +13,15 @@ import Test.Tasty.HUnit (testCase, Assertion) import qualified Control.Exception.Throwable.TH as ETH -ETH.declareException "THTestException"+ETH.declareException "TestException" ["FirstException", "SecondException"] + -- Indicate `e ()` is Exception instance in the compile time type IsException e = (Show (e ()), Typeable (e ()), Exception (e ())) => e () +typing :: IsException a+typing = undefined -refl :: IsException a-refl = undefined through :: a -> Assertion through = void . return@@ -33,5 +34,8 @@ test_generated_datatype :: [TestTree] test_generated_datatype =- [ testCase "is Exception instance" $ through (refl :: IsException THTestException)+ [ testCase "is Exception instance" $ through (typing :: IsException TestException)+ , testCase "is sum type" $ do+ through $ FirstException "hono" 10+ through $ secondException "koto" ]
throwable-exceptions.cabal view
@@ -1,5 +1,5 @@ name: throwable-exceptions-version: 0.1.0.6+version: 0.1.0.7 synopsis: throwable-exceptions gives the easy way to throw exceptions description: throwable-exceptions gives the easy way to throw exceptions homepage: https://github.com/aiya000/hs-throwable-exceptions#README.md