diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -6,3 +6,5 @@ cleaned 0.0.10.1 added (moved) startApp from 0.1.0 cleaned and removed unnecessary comments and functions + +0.1.2 moved to Control.Monad.Exception diff --git a/Uniform/Error.hs b/Uniform/Error.hs --- a/Uniform/Error.hs +++ b/Uniform/Error.hs @@ -17,16 +17,28 @@ {-# OPTIONS_GHC -w #-} module Uniform.Error - ( module Uniform.Error, + ( module Uniform.Error -- module Uniform.Strings, - module Safe, - module Control.Monad.Error, -- is monads-tf - module Control.Exception, -- to avoid control.error + , module Safe + , module Control.Monad + , module Control.Monad.Trans.Except + , liftIO, MonadIO + , SomeException + -- , module Control.Monad.IO.Class + + -- module Control.Monad.Error, -- is monads-tf + -- module Control.Excepcation, -- to avoid control.error ) where -import Control.Exception (Exception, SomeException, bracket, catch) -import "monads-tf" Control.Monad.Error (Error, ErrorT, ErrorType, MonadError, MonadIO, catchError, liftIO, runErrorT, throwError, unless, when) +import Control.Exception (Exception, SomeException, bracket, catch, throw, SomeException) +import Control.Monad -- just to make it available everywhere +import Control.Monad.IO.Class (liftIO, MonadIO) +-- import "monads-tf" Control.Monad.Error (Error, ErrorT, ErrorType, MonadError, MonadIO, catchError, liftIO, runErrorT, throwError, unless, when) + +-- ErrorT Text IO xxx becomes ErrIO xxx + +import Control.Monad.Trans.Except import Safe (headNote, readNote) import Uniform.Strings hiding (S, (<.>), ()) @@ -35,9 +47,9 @@ type ErrOrVal = Either Text -type ErrIO = ErrorT Text IO +type ErrIO = ExceptT Text IO -instance Exception [Text] +-- instance Exception [Text] toErrOrVal :: Either String a -> ErrOrVal a @@ -46,7 +58,7 @@ -- | runErr to avoid the depreceated message for runErrorT, which is identical runErr :: ErrIO a -> IO (ErrOrVal a) -runErr = runErrorT +runErr = runExceptT runErrorVoid :: ErrIO () -> IO () -- ^ run an operation in ErrIO which is not returning anything @@ -85,31 +97,43 @@ (\a -> runErr $ after . fromRightEOV $ a) (\a -> runErr $ thing . fromRightEOV $ a) -instance Error Text +-- instance Error Text -callIO :: (MonadError m, MonadIO m, ErrorType m ~ Text) => IO a -> m a +callIO :: + -- (MonadError m, MonadIO m, ErrorType m ~ Text) => + -- (MonadIO m) => + IO a -> ErrIO a -- | this is using catch to grab all errors callIO op = do - r2 <- - liftIO $ - do - r <- op - return $ Right r - `catch` ( \e -> do - -- putStrLn "callIO catch caught error\n" - return . Left $ (e :: SomeException) - ) - case r2 of - Left e -> do + r2 <- liftIO $ + do + r <- op + return $ Right r + `catch` ( \e -> do + -- putStrLn "callIO catch caught error\n" + return . Left $ (e :: SomeException) + ) + case r2 of + Left e -> do -- putIOwords ["\ncallIO Left branch\n", showT e, "throwError\n"] - throwError (showT e) - Right v -> return v + throwE (showT e) + Right v -> return v -throwErrorT :: [Text] -> ErrIO a +throwErrorWords :: [Text] -> ErrIO a -- throw an error with a list of texts as a text -throwErrorT = throwError . unwordsT +throwErrorWords = throwE . unwordsT + +throwErrorT :: Text -> ErrIO a +-- throw an error - for compatibility with old code +throwErrorT = throwE + +catchError :: Monad m => ExceptT e m a + -> (e -> ExceptT e' m a) -> ExceptT e' m a +-- catch Error in the ExceptT monad (but not others??) +catchError = catchE + maybe2error :: Maybe a -> ErrIO a maybe2error Nothing = fail "was Nothing" maybe2error (Just a) = return a @@ -141,28 +165,29 @@ startProg :: Show a => Text -> ErrIO a -> IO () startProg programName mainProg = - do - putIOwords - [ "------------------ ", - programName, - " ----------------------------\n" - ] - r <- runErr $ mainProg - putIOwords - [ "\n------------------", - "main", - programName, - "\nreturning", - either id showT r, - "\n" - ] - return () - `catchError` ( \e -> do + (do + putIOwords + [ "------------------ ", + programName, + " ----------------------------\n" + ] + r <- runErr $ mainProg + putIOwords + [ "\n------------------", + "main", + programName, + "\nreturning", + either id showT r, + "\n" + ] + return () + ) + `catch` ( \e -> do -- here catch because in the IO monad + -- (not ExceptT ) putIOwords [ "startProg error caught\n", - programName, - "\n", - showT e + programName, "\n", + showT (e :: SomeException) ] return () ) diff --git a/test/Testing.hs b/test/Testing.hs new file mode 100644 --- /dev/null +++ b/test/Testing.hs @@ -0,0 +1,37 @@ +----------------------------------------------------------------------------- +-- +-- Module : top tests for error +----------------------------------------------------------------------------- +{-# OPTIONS_GHC -F -pgmF htfpp #-} + + {-# LANGUAGE + MultiParamTypeClasses + , TypeSynonymInstances +-- , FunctionalDependencies + , FlexibleInstances + , FlexibleContexts + , ScopedTypeVariables +-- , UndecidableInstances + , OverloadedStrings + , TypeFamilies + + #-} + +module Main where + +import {-@ HTF_TESTS @-} Uniform.Error_test +import Test.Framework +import Uniform.Strings ( putIOwords, showT ) + +main :: IO () +main = do + putIOwords ["HTF errorTest.hs:\n uniform-error test"] + r <- htfMainWithArgs ["--quiet"] htf_importedTests + putIOwords ["HTF end errorTest.hs:\n posTest", showT r] + -- r2 <- errorTest + -- putIOwords [" error test end\n ", showT r2] + return r + + + + diff --git a/test/Uniform/Error_test.hs b/test/Uniform/Error_test.hs new file mode 100644 --- /dev/null +++ b/test/Uniform/Error_test.hs @@ -0,0 +1,177 @@ +----------------------------------------------------------------------------- +-- +-- Module : Uniform.Error +-- +-- | a miniaml set of error processing +-- uses monads-tf -- family used (not fp) +-- and other monads often used (state) +-- collects from eithererror package what is working (with monads-tf) +----------------------------------------------------------------------------- +{-# OPTIONS_GHC -F -pgmF htfpp #-} +{-# LANGUAGE BangPatterns #-} +--{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} + -- runErrorT is depreceiated but used in monads-tf +{-# OPTIONS_GHC -w #-} + + +module Uniform.Error_test where + +--import "monads-tf" Control.Monad.Error +--import Safe +import Test.Framework + ( assertBool_, + assertEqual_, + makeLoc, + makeTestSuite, + makeUnitTest, + TestSuite ) +--import Uniform.Strings hiding ((), (<.>), (<|>)) +import Uniform.Error +import Uniform.Strings +import Control.Exception ( catch, SomeException ) + +op1 :: ErrIO () +op1 = putIOwords ["acquire"] :: ErrIO () +op2 :: p -> ErrIO () +op2 h = putIOwords ["operate"]:: ErrIO () +op3 :: p -> ErrIO () +op3 h = putIOwords ["close"] :: ErrIO () + +test_bracket0 :: IO () +test_bracket0 = do + runErr $ do + op1 + op2 () + op3 () + assertEqual True True + +test_bracket1 :: IO () +test_bracket1 = do + runErr $ bracketErrIO op1 op3 op2 + assertEqual True True + + +-- errorTest :: IO Bool +-- errorTest = do +-- r <- runErr errorTest2 +-- v1 <- case r of +-- Left msg -> do +-- putIOwords ["errorTest returned Left :", msg] +-- return False +-- Right v -> return v +-- return v1 + + + +--test2 :: ErrIO Bool +--test2 = do +-- test2catch False +-- return False +-- +-- `catchError` \s -> return True + +-- errorTest2 :: ErrIO Bool +-- errorTest2 = do +-- c1 :: Bool <- mustFailM "test throw" $ (throwError "error1") +-- c2 :: Bool <- mustSucceedM "test return ok" $ (return ()) +-- c3 <- mustSucceedM "test catch ok" $ test2catch True +-- c4 <- mustSucceedM "test catch ok" $ test2catch False +-- let res = and [c1, c2, c3, c4] +-- return res + + +test2catch :: Bool -> ErrIO () +test2catch b = do + (if b then return () + else do + putIOwords ["ssd"] + throwErrorT "test2catch message" + ) + `catchE` (\e -> do + putIOwords ["error caught when thrown"] + -- putIOwords ["the error", showT (e :: SomeException)] + throwErrorT "test2catch - error caught" + ) +-- +-- test_error2 :: IO () +-- test_error2 = do +-- r <- (runErr errorTest2) +-- assertEqual (Right True :: ErrOrVal Bool) r + +test_catch2 :: IO () +test_catch2 = do + r <- (runErr $ test2catch True) + assertEqual (Right () :: ErrOrVal ()) r + +test_catch2f :: IO () +test_catch2f = do + r <- (runErr $ test2catch False) + assertEqual (Left "test2catch - error caught" :: ErrOrVal ()) r + +test_catch2x :: IO () -- catch bomb, not caught - yet +test_catch2x = do + r <- (runErr $ test2catch undefined) + assertEqual (Left "test2catch - error caught" :: ErrOrVal ()) r + + +--instance (Show a) => Strings (ErrOrVal a) where +-- toString (Left msg) = msg +-- toString (Right r) = show r + + +test_catch :: IO () +test_catch = + error "some intentional error" + `catch` \(e::SomeException) -> assertBool True + +--test_catch_error = +-- error "some intentional error" +-- `catchT` \(e :: S) -> assertBool True + + +test_callIO :: IO () +test_callIO = do + r <- runErr $ callIO $ readFile "xxxabc" + case r of + Left _ -> assertBool True + Right _ -> assertBool False + +--test_catch2 = +-- readFile2 "xxxabc" +-- `catch` \(e::SomeException) -> assertBool True +-- +--test_catch_error2 = +-- readFile2 "xxxabcd" +-- `catchError ` \(e) -> assertBool True + +-- +--data SomethingBad = SomethingBad [Text] +-- deriving D.Typeable +--unSMB (SomethingBad ss) = ss +-- +--instance Show SomethingBad where +-- show (SomethingBad s) = "something bad happened:" ++ unwords s +--instance N.Exception SomethingBad +-- +--throwErrorWords2 :: (N.MonadCatch m) => [Text] -> m a +--throwErrorWords2 s = N.throwM (SomethingBad s) +-- +---- {-# DEPRECATED throwErrorWords "replace with class throwErrorWords2 " #-} +---- the constraint MonadCatch is not possible for em +-- +--throwErrorWords :: (MonadError m, ErrorType m ~ Text) => [Text] -> m a +--throwErrorWords s = throwError .unwords $ s -- use only this!! +-- + diff --git a/uniform-error.cabal b/uniform-error.cabal --- a/uniform-error.cabal +++ b/uniform-error.cabal @@ -1,18 +1,20 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.34.2. +-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack -- --- hash: 7f798466051704587a2355486782bd1165e67a54c1ac54700691c2f06af5fd92 +-- hash: c47f92101ef8ccea1f09bb2d556bb209628baebfbcae67fbcfd614a124740ac1 name: uniform-error -version: 0.1.0 +version: 0.1.3 synopsis: Handling errors in the uniform framework description: A minimal package to handle errors and exception in a simple but flexible way. Includes functions to adapt the prefered method of calling IO with error handling (ErrIO) to the approaches encountered in other packages when writing applications. . + 0.1.3 added stack build lts 19.16 for ghc 9.0.2 + . Please see the README on GitHub at category: Error Exception Uniform bug-reports: https://github.com/andrewufrank/uniform-error/issues @@ -31,11 +33,31 @@ other-modules: Paths_uniform_error hs-source-dirs: - ./. + ./ build-depends: base >=4.7 && <5 - , monads-tf , safe - , uniform-strings + , transformers + , uniform-strings >=0.1.3 default-language: Haskell2010 autogen-modules: Paths_uniform_error + +test-suite error-test + type: exitcode-stdio-1.0 + main-is: Testing.hs + other-modules: + Uniform.Error_test + Paths_uniform_error + autogen-modules: + Paths_uniform_error + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + HTF + , base >=4.7 && <5 + , safe + , transformers + , uniform-error + , uniform-strings >=0.1.3 + default-language: Haskell2010