uniform-error 0.1.0 → 0.1.3
raw patch · 5 files changed
+315/−52 lines, 5 filesdep +HTFdep +transformersdep +uniform-errordep −monads-tfdep ~uniform-strings
Dependencies added: HTF, transformers, uniform-error
Dependencies removed: monads-tf
Dependency ranges changed: uniform-strings
Files
- ChangeLog.md +2/−0
- Uniform/Error.hs +71/−46
- test/Testing.hs +37/−0
- test/Uniform/Error_test.hs +177/−0
- uniform-error.cabal +28/−6
ChangeLog.md view
@@ -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
Uniform/Error.hs view
@@ -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 () )
+ test/Testing.hs view
@@ -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++++
+ test/Uniform/Error_test.hs view
@@ -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!!+--+
uniform-error.cabal view
@@ -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 <https://github.com/andrewufrank/uniform-error/readme> 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