diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -24,7 +24,7 @@ ## Examples - vvv The summary of the exact examples is available here vvv - - [example/Main.hs](https://github.com/aiya000/hs-throwable-exceptions/blob/master/example/Main.hs) + - [test/MainTest.hs](https://github.com/aiya000/hs-throwable-exceptions/blob/master/test/MainTest.hs) - - - diff --git a/example/Main.hs b/example/Main.hs deleted file mode 100644 --- a/example/Main.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - --- | This is referenced from README.md -module Main where - -import Control.Exception.Safe (throwM, MonadCatch, catch, SomeException) -import Control.Exception.Throwable (GeneralException(..), generalException, IndexOutOfBoundsException(..)) -import Control.Exception.Throwable.TH (declareException) - -{- !! These line is needed by declareException !! -} -import Control.Exception.Safe (Exception) -import Data.Typeable (Typeable) -{- ---------------------------------------------- -} - - --- This is same as --- --- data MyException a = MyException --- { myExceptionCause :: String --- , myExceptionClue :: a --- } deriving (Typeable) --- --- instance Show a => Show (MyException a) where --- ... --- instance (Typeable a, Show a) => Exception (MyException a) --- -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 --- --- Left IndexOutOfBoundsException: "index is too big" --- MyException: "hi" --- MyException: "poi" --- Left FooException: poi poi poi !? - - --- IndexOutOfBoundsException, --- IOException', --- IllegalArgumentException, --- and GeneralException is presented by default. -at :: (MonadCatch m, Typeable a, Show a) => [a] -> Int -> m a -at xs index = do - if index < length xs - then return $ xs !! index - else throwM $ IndexOutOfBoundsException "index is too big" (xs, index) - --else throwM $ indexOutOfBoundsException' "index is too big" - -- You can use above code without some clue - - --- If you don't want to use TemplateHaskell (Control.Exception.Throwable.TH), --- you can use GeneralException and generalException instead ! --- --- data GeneralException a = GeneralException --- { exceptionName :: String -- ^ This should be named by 'PascalCase' for show, for example: "MyOperation", "Database" --- , exceptionCause :: String -- ^ The message for the cause of the exception --- , exceptionClue :: a -- ^ The clue of the exception. This can be anything of Show instance --- } --- --- generalException :: String -> String -> GeneralException () --- generalException name cause = GeneralException name cause () --- -foo :: (MonadCatch m, Typeable a, Show a) => m a -foo = throwM $ generalException "FooException" "poi poi poi !?" --- This is same as `GeneralException "FooException" "poi poi poi !?" ()` diff --git a/src/Control/Exception/Throwable/TH.hs b/src/Control/Exception/Throwable/TH.hs --- a/src/Control/Exception/Throwable/TH.hs +++ b/src/Control/Exception/Throwable/TH.hs @@ -10,7 +10,7 @@ ) 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 @@ -70,14 +70,28 @@ where toValueConstructorName :: ValueConstructorName -> Maybe ValueConstructor toValueConstructorName [] = Nothing - toValueConstructorName constrName@(c:onstrName) = - let constrName' = (toLower c) : onstrName -- camelCase + toValueConstructorName constrName = + let constrName' = pascalToCamelCase constrName in Just ValueConstructor { constructorName = constrName - , causeRecordName = constrName' ++ "Cause" - , clueRecordName = constrName' ++ "Clue" + , causeRecordName = causeRecordName constrName' + , clueRecordName = clueRecordName constrName' } + -- "ioException'" -> ("ioException", "'") + splitBodyAndSigns :: String -> (String, String) + splitBodyAndSigns = span $ not . isPunctuation + -- recordName "Cause" "ioException'" -> "ioExceptionCause'", + -- signs is important. + recordName :: String -> String -> String + recordName suffix constrName' = + let (name, signs) = splitBodyAndSigns constrName' + in name ++ suffix ++ signs + + causeRecordName = recordName "Cause" + clueRecordName = recordName "Clue" + + -- | A natural strategy of the evaluation noBang :: Bang noBang = Bang NoSourceUnpackedness NoSourceStrictness @@ -99,11 +113,11 @@ let dataDec = defineDatatype typeNames typeParam showInstanceDec <- defineShowInstanceFor typeNames exceptionInstancDec <- defineExceptionInstanceFor typeNames - fakeConstructorDecs <- mapM defineFakeConstructor $ constructors typeNames + fakeconstructorDecs <- concat <$> mapM (defineFakeConstructor $ datatypeName typeNames) (constructors typeNames) return $ [ dataDec , showInstanceDec , exceptionInstancDec - ] ++ fakeConstructorDecs + ] ++ fakeconstructorDecs where -- Define a data of an exception. -- the data is defined by @DatatypeNames@. @@ -128,15 +142,16 @@ -- Define an instance of a data of @DatatypeNames@ for @Show@. defineShowInstanceFor :: DatatypeNames -> Q Dec - defineShowInstanceFor dataTypeNames@(DatatypeNames {..}) = do + 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] + showFuncDec <- declareShowFunc datatypeNames + return $ + InstanceD Nothing [ConT showClass `AppT` VarT a] + (ConT showClass `AppT` ParensT (ConT exception `AppT` VarT a)) [ + showFuncDec + ] -- Make a @show@ function definition. declareShowFunc :: DatatypeNames -> Q Dec @@ -151,9 +166,9 @@ makeShowFuncClause (ValueConstructor {..}) showFunc = do let constructor = mkName constructorName cause <- newName "cause" - return $ Clause [ConP constructor [VarP cause, WildP]] -- (FooException cause _) = + return $ Clause [ConP constructor [VarP cause, WildP]] (NormalB - (InfixE (Just . LitE . StringL $ typeName ++ ": ") (VarE $ mkName "++") (Just $ AppE (VarE showFunc) (VarE cause))) -- show ("FooException: " ++ show cause) + (InfixE (Just . LitE . StringL $ typeName ++ ": ") (VarE $ mkName "++") (Just $ AppE (VarE showFunc) (VarE cause))) ) [] -- Define an instance of a data of @DatatypeNames@ for @Exception@. @@ -165,23 +180,30 @@ exception = mkName typeName a <- newName "a" return $ InstanceD Nothing - [ AppT (ConT typeableClass) (VarT a) - , AppT (ConT showClass) (VarT a) + [ ConT typeableClass `AppT` VarT a + , ConT showClass `AppT` VarT a ] - (AppT (ConT exceptionClass) (AppT (ConT exception) (VarT a))) + (ConT exceptionClass `AppT` ParensT (ConT exception `AppT` 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 + -- + -- Take a name of the target value constructor, and a name of its data type. + -- + -- Why @DecsQ@ is returned, because splicing type signature should be avoided. + defineFakeConstructor :: String -> ValueConstructor -> DecsQ + defineFakeConstructor typeName (ValueConstructor {..}) = do + let datatype = mkName typeName + fConstructor = mkName $ pascalToCamelCase constructorName constructor = mkName constructorName - a <- newName "a" - return $ FunD fConstructor [ - Clause [VarP a] (NormalB $ AppE (AppE (ConE constructor) (VarE a)) (TupE [])) - [] - ] + 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] -- | diff --git a/test/MainTest.hs b/test/MainTest.hs new file mode 100644 --- /dev/null +++ b/test/MainTest.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Basic specs. +-- And this is an example code. +-- +-- This should be compiled without the compile error. +module MainTest where + +import Control.Exception.Safe (throwM, MonadCatch, catch, SomeException) +import Control.Exception.Throwable (GeneralException(..), generalException, IndexOutOfBoundsException(..)) +import Control.Exception.Throwable.TH (declareException) + +{- !! These line is needed by declareException !! -} +import Control.Exception.Safe (Exception) +import Data.Typeable (Typeable) +{- ---------------------------------------------- -} + +-- For test +import System.IO.Silently (silence) +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (testCase, (@?=)) + + +-- This is same as +-- +-- data MyException a = MyException +-- { myExceptionCause :: String +-- , myExceptionClue :: a +-- } deriving (Typeable) +-- +-- instance Show a => Show (MyException a) where +-- ... +-- instance (Typeable a, Show a) => Exception (MyException a) +-- +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"] + + +-- A context of IO +main' :: IO () +main' = do + print $ ([1..4] `at` 5 :: Either SomeException Int) + print $ MyException "hi" (10 :: Int) + 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 :: Int) + print $ firstException "cocoa" + print $ secondException "rize" +-- +-- vvv output result vvv +-- +-- Left IndexOutOfBoundsException: "index is too big" +-- MyException: "hi" +-- MyException: "poi" +-- Left FooException: poi poi poi !? + + +-- IndexOutOfBoundsException, +-- IOException', +-- IllegalArgumentException, +-- and GeneralException is presented by default. +at :: (MonadCatch m, Typeable a, Show a) => [a] -> Int -> m a +at xs index = do + if index < length xs + then return $ xs !! index + else throwM $ IndexOutOfBoundsException "index is too big" (xs, index) + --else throwM $ indexOutOfBoundsException' "index is too big" + -- You can use above code without some clue + + +-- If you don't want to use TemplateHaskell (Control.Exception.Throwable.TH), +-- you can use GeneralException and generalException instead ! +-- +-- data GeneralException a = GeneralException +-- { exceptionName :: String -- ^ This should be named by 'PascalCase' for show, for example: "MyOperation", "Database" +-- , exceptionCause :: String -- ^ The message for the cause of the exception +-- , exceptionClue :: a -- ^ The clue of the exception. This can be anything of Show instance +-- } +-- +-- generalException :: String -> String -> GeneralException () +-- generalException name cause = GeneralException name cause () +-- +foo :: (MonadCatch m, Typeable a, Show a) => m a +foo = throwM $ generalException "FooException" "poi poi poi !?" +-- This is same as `GeneralException "FooException" "poi poi poi !?" ()` + + +test_this_code_should_be_compiled_without_the_compile_error :: [TestTree] +test_this_code_should_be_compiled_without_the_compile_error = [testCase "" $ silence main'] diff --git a/throwable-exceptions.cabal b/throwable-exceptions.cabal --- a/throwable-exceptions.cabal +++ b/throwable-exceptions.cabal @@ -1,5 +1,5 @@ name: throwable-exceptions -version: 0.1.0.7 +version: 0.1.0.8 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 @@ -30,23 +30,16 @@ main-is: Tasty.hs default-language: Haskell2010 ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wno-unused-top-binds - other-modules: Control.Exception.ThrowableTest + other-modules: MainTest , Control.Exception.Throwable.THTest + , Control.Exception.ThrowableTest build-depends: base , doctest , either , safe-exceptions + , silently , tasty , tasty-discover , tasty-hunit , text - , throwable-exceptions - -executable throwable-exception-example - hs-source-dirs: example - main-is: Main.hs - default-language: Haskell2010 - ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wno-name-shadowing -Wno-unused-do-bind - build-depends: base >= 4.7 && < 5 - , safe-exceptions , throwable-exceptions