diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,8 @@ +0.0.10 + move from the 0.0.9 versions in Workspace8 2019 + change to uniform approach: + test/Testing.hs + .ghci + cleaned +0.0.10.1 added (moved) startApp from +0.1.0 cleaned and removed unnecessary comments and functions diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,20 @@ +`Error.hs` defines an uniform approach to error: + any function which can fail returns a value of + - `ErrIO`, which is a wrapper around `IO`, returning a `Text` messages if the computation fails + - `ErrOrVal` (which is `Either Text`) for functions not in the IO monad + +All cases where functions use other error signaling methods must be converted as part of their integration into the uniform framework. + +Especially important are the functions to convert to regular IO: + +- `callIO` which calls an IO function and catches a possible error return. + +- converts back functions running in `ErrIO a` into (normal) `IO (ErrOrVal a)` which is used when functions from the uniform style are used where functions in the normal IO monad are expected. + +Some other functions are helpful to identify hard to track problems in Haskell: + +`undef` to find where an undefined value is used, producing an error message. + +The StartApp is a bridge between the ErrIO used here and the standard IO monad in `main:: IO ()` + +The package depends on uniform-string. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain + diff --git a/Uniform/Error.hs b/Uniform/Error.hs new file mode 100644 --- /dev/null +++ b/Uniform/Error.hs @@ -0,0 +1,169 @@ +---------------------------------------------------------------------- +-- +-- Module : Uniform.Error +-- +---------------------------------------------------------------------- + + {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} +-- runErrorT is depreceiated but used in monads-tf +{-# OPTIONS_GHC -w #-} + +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 + ) +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 Safe (headNote, readNote) +import Uniform.Strings hiding (S, (<.>), ()) + +instance CharChains2 IOError Text where + show' = s2t . show + +type ErrOrVal = Either Text + +type ErrIO = ErrorT Text IO + +instance Exception [Text] + + +toErrOrVal :: Either String a -> ErrOrVal a +toErrOrVal (Left s) = Left (s2t s) +toErrOrVal (Right r) = Right r + +-- | runErr to avoid the depreceated message for runErrorT, which is identical +runErr :: ErrIO a -> IO (ErrOrVal a) +runErr = runErrorT + +runErrorVoid :: ErrIO () -> IO () +-- ^ run an operation in ErrIO which is not returning anything +-- simpler to use than runErr +runErrorVoid a = do + res <- runErr a + case res of + Left msg -> error (t2s msg) + Right _ -> return () + +undef :: Text -> a +undef = error . t2s +-- ^ for type specification, not to be evaluated + +fromRightEOV :: ErrOrVal a -> a +fromRightEOV (Right a) = a +fromRightEOV (Left msg) = errorT ["fromrightEOV", msg] + +bracketErrIO :: + -- | computation to run first (\"acquire resource\") + ErrIO a -> + -- | computation to run last (\"release resource\") + (a -> ErrIO b) -> + -- | computation to run in-between + (a -> ErrIO c) -> + ErrIO c -- returns the value from the in-between computation + --bracketErrIO before after thing = bracket before after thing + -- no way to catch IO errors reliably in ErrIO -- missing Monad Mask or similar +bracketErrIO before after thing = + fmap fromRightEOV . callIO $ + bracket + ( do + ra <- runErr $ before + return ra -- (ra :: ErrOrVal a) ) + ) + (\a -> runErr $ after . fromRightEOV $ a) + (\a -> runErr $ thing . fromRightEOV $ a) + +instance Error Text + +callIO :: (MonadError m, MonadIO m, ErrorType m ~ Text) => IO a -> m 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 + -- putIOwords ["\ncallIO Left branch\n", showT e, "throwError\n"] + throwError (showT e) + Right v -> return v + + +throwErrorT :: [Text] -> ErrIO a +-- throw an error with a list of texts as a text +throwErrorT = throwError . unwordsT + +maybe2error :: Maybe a -> ErrIO a +maybe2error Nothing = fail "was Nothing" +maybe2error (Just a) = return a + +errorT :: [Text] -> a +-- ^ a list of texts is output with failure +errorT = error . t2s . unwordsT + +errorWords :: [Text] -> a +errorWords = errorT + +fromJustNoteT :: [Text] -> Maybe a -> a +-- produce error with msg when Nothing, msg is list of texts +fromJustNoteT msgs a = fromJustNote (t2s . unlinesT $ msgs) a + +fromRightNoteString :: Text -> Either String b -> b +-- produce an error when assuming that a value is Right +fromRightNoteString msg (Left a) = errorT ["fromRight", showT a, msg] +fromRightNoteString _ (Right a) = a + +fromRightNote :: Text -> Either Text b -> b +-- produce an error when assuming that a value is Right +fromRightNote msg (Left a) = errorT ["fromRight", showT a, msg] +fromRightNote _ (Right a) = a + +headNoteT :: [Text] -> [a] -> a +-- get head with a list of texts +headNoteT msg s = headNote (t2s $ unwords' msg) s + +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 + putIOwords + [ "startProg error caught\n", + programName, + "\n", + showT e + ] + return () + ) + diff --git a/uniform-error.cabal b/uniform-error.cabal new file mode 100644 --- /dev/null +++ b/uniform-error.cabal @@ -0,0 +1,41 @@ +cabal-version: 2.2 + +-- This file has been generated from package.yaml by hpack version 0.34.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 7f798466051704587a2355486782bd1165e67a54c1ac54700691c2f06af5fd92 + +name: uniform-error +version: 0.1.0 +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. + . + Please see the README on GitHub at +category: Error Exception Uniform +bug-reports: https://github.com/andrewufrank/uniform-error/issues +author: Andrew Frank +maintainer: Andrew U. Frank +copyright: 2021 Andrew U. Frank +license: GPL-2.0-only +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +library + exposed-modules: + Uniform.Error + other-modules: + Paths_uniform_error + hs-source-dirs: + ./. + build-depends: + base >=4.7 && <5 + , monads-tf + , safe + , uniform-strings + default-language: Haskell2010 + autogen-modules: Paths_uniform_error