-- @+leo-ver=4-thin -- @+node:gcross.20091202203048.1603:@thin ErrorMessage.hs -- @@language Haskell -- @@raw ------------------------------------------------------------------------------ -- | -- @@end_raw -- @+at -- Module : Data.ErrorMessage -- Copyright : (c) Gregory Crosswhite -- License : BSD-style -- Maintainer : gcross@phys.washington.edu -- Stability : provisional -- Portability : portable -- -- This philosophy behind this package is that it is often better to find out -- all of the errors that have occured in a computation and report them -- simultaneously, rather than aborting as soon as the first error is -- encountered. Towards this end, this module supplies a type of -- /combinable error messages/ so that all of the errors from subcomputations -- can be gathered and presented together. -- -- The following provides an example of how these can be used: -- -- @-at -- @@c -- @@raw -- > sqrtWithError :: Float -> Either ErrorMessage Float -- > sqrtWithError x -- > | x < 0 -- > = leftErrorMessageText -- > ("Error computing the square root of " ++ (show x) ++ ":") -- > "Square roots cannot be taken of negative numbers." -- > | otherwise -- > = Right (sqrt x) -- > -- > sumWithError :: Either ErrorMessage Float -> Either ErrorMessage Float -> Either ErrorMessage Float -- > sumWithError (Left error1) (Left error2) = Left (error1 `mappend` error2) -- > sumWithError (Left error) _ = Left error -- > sumWithError _ (Left error) = Left error -- > sumWithError (Right value1) (Right value2) = Right (value1 + value2) -- > -- > showSumOrErrorOf :: Float -> Float -> String -- > showSumOrErrorOf x y = -- > case sumWithError (sqrtWithError x) (sqrtWithError y) of -- > Right value -> "The value is " ++ show value -- > Left error -> show . formatErrorMessage $ error -- @@end_raw -- @+at -- -- The result of @showSumOrErrorOf (-1) (-2)@ is the string, -- -- > Error computing the square root of -1: -- > Square roots cannot be taken of negative numbers. -- > Error computing the square root of -2: -- > Square roots cannot be taken of negative numbers. -- -- whereas the result of @showSumOrErrorOf (-1) (-1)@ is the string, -- -- > Error computing the square root of -1: -- > Square roots cannot be taken of negative numbers. -- -- Note how the error message only appears once; this is because the process -- of combining the error messages automatically eliminates all identical -- headings under the assumption that they came from the same original -- computation, as was the case here. -- -- Currently, the definition of @sumWithError@ is largely boilerplate. -- Happily, the Haskell community has done a lot of work to identify patterns -- such as these and to write libraries that allow us to express them -- concisely. In particular, a standard trick when working with errors like -- this is to express the calculation as a 'Monad', such as by using the -- following definition: -- -- > sumWithError_2 argument1 argument2 = do -- > value1 <- argument1 -- > value2 <- argument2 -- > return (value1 + value2) -- -- Or, even more concisely: -- -- > sumWithError_3 = liftM2 (+) -- -- Unfortunately though, neither of these definitions have the same semantics -- as the original @sumWithError@, as using both we get the following error -- message for @showSumOrErrorOf (-1) (-2)@: -- -- > Error computing the square root of -1: -- > Square roots cannot be taken of negative numbers. -- -- That is, we have lost the second of the two error messages. The reason -- for this is that 'Monad'-style error processing expresses the computation -- as a sequence, and gives up as soon as it sees any error. In this case of -- @sumWithError@, however, the evaluation of the second argument can proceed -- even if there was an error in the first argument. Thus, rather than using -- a 'Monad' pattern, we use an 'Applicative' pattern: -- -- > sumWithError_4 = liftA2 (+) -- -- Now both error messages are displayed. -- -- @-at -- @@c -- @@raw ------------------------------------------------------------------------------ -- @@end_raw -- @<< Language extensions >> -- @+node:gcross.20091202203048.7000:<< Language extensions >> -- @-node:gcross.20091202203048.7000:<< Language extensions >> -- @nl module Data.ErrorMessage ( -- * The ErrorMessage Type ErrorMessage(..) ,ErrorMessageOr -- $error_message_type -- ** Instances for ErrorMessage -- $error_message_instances -- ** Instances for Doc -- $doc_instances -- ** Applicative Instances -- $applicative_instances -- * Creation of Error Messages -- $error_message_creation ,errorMessage ,errorMessageText ,errorMessageTextFromMultilineString ,leftErrorMessage ,leftErrorMessageText ,leftErrorMessageTextFromMultilineString -- * Formatting of Error Messages -- $error_message_formatting ,formatErrorMessage ,formatMessageWithHeading -- * Gathering Results with Errors -- $gathering_results_with_errors ,gatherResultsOrErrors ,gatherResultsOrError ) where -- @<< Import needed modules >> -- @+node:gcross.20091202203048.1605:<< Import needed modules >> import Control.Arrow import Control.Applicative hiding (empty) import Control.Applicative.Infix import Control.Monad import Control.Monad.Error import Data.Either import Data.Either.Unwrap import Data.Function import Data.Monoid import Data.Map (Map) import qualified Data.Map as Map import Text.PrettyPrint.ANSI.Leijen -- @-node:gcross.20091202203048.1605:<< Import needed modules >> -- @nl -- @+others -- @+node:gcross.20091202203048.1606:Types -- @+node:gcross.20091202203048.1607:ErrorMessage newtype ErrorMessage = ErrorMessage { unwrapErrorMessage :: Map String Doc } type ErrorMessageOr = Either ErrorMessage -- @-node:gcross.20091202203048.1607:ErrorMessage -- @-node:gcross.20091202203048.1606:Types -- @+node:gcross.20091202203048.1608:Instances -- @+node:gcross.20091202203048.1609:Applicative (Either e a) -- @@raw -- @@end_raw instance (Monoid e) => Applicative (Either e) where pure = Right (<*>) (Left error2) (Left error1) = Left (error1 `mappend` error2) (<*>) (Left error) _ = Left error (<*>) _ (Left error) = Left error (<*>) (Right function) (Right argument) = Right (function argument) -- @-node:gcross.20091202203048.1609:Applicative (Either e a) -- @+node:gcross.20091202203048.1610:Applicative (ErrorT e m a) instance (Monoid e, Error e, Monad m) => Applicative (ErrorT e m) where pure = return e_fn <*> e_arg = ErrorT $ liftM2 (<*>) (runErrorT e_fn) (runErrorT e_arg) -- @-node:gcross.20091202203048.1610:Applicative (ErrorT e m a) -- @+node:gcross.20091202203048.1611:Error ErrorMessage instance Error ErrorMessage where noMsg = strMsg "(and he did not even bother to include an error message! :-/)" strMsg = errorMessage "Error caused by the programmer:" . text -- @-node:gcross.20091202203048.1611:Error ErrorMessage -- @+node:gcross.20091202203048.7025:Monoid ErrorMessage instance Monoid ErrorMessage where mempty = ErrorMessage Map.empty mappend (ErrorMessage a) (ErrorMessage b) = ErrorMessage (mappend a b) mconcat = ErrorMessage . mconcat . map unwrapErrorMessage -- @-node:gcross.20091202203048.7025:Monoid ErrorMessage -- @+node:gcross.20091202203048.1613:Error Doc instance Error Doc where noMsg = empty strMsg = text -- @-node:gcross.20091202203048.1613:Error Doc -- @+node:gcross.20091202203048.1612:Monoid Doc -- @-node:gcross.20091202203048.1612:Monoid Doc -- @-node:gcross.20091202203048.1608:Instances -- @+node:gcross.20091202203048.1614:Functions -- @+node:gcross.20091202203048.7038:Error Message Creation -- @+node:gcross.20091202203048.1619:errorMessage / leftErrorMessage -- @@raw -- | -- @@end_raw -- @+at -- The function 'errorMessage' takes a heading and a body and produce an -- ErrorMessage object from them; this can be considered to be a thin -- wrapper around 'Data.Map.singleton'. -- @-at -- @@c errorMessage :: String -> Doc -> ErrorMessage errorMessage heading = ErrorMessage . Map.singleton heading -- @@raw -- | -- @@end_raw -- @+at -- Since one usually wants to return not just an ErrorMessage, but a value of -- the form @Left error_message@, the function 'leftErrorMessage' is provided -- as a convenience; it creates the error message, and then wraps it inside -- of 'Left'. -- @-at -- @@c leftErrorMessage :: String -> Doc -> Either ErrorMessage a leftErrorMessage heading = Left . errorMessage heading -- @-node:gcross.20091202203048.1619:errorMessage / leftErrorMessage -- @+node:gcross.20091202203048.1620:errorMessageText / leftErrorMessageText -- @@raw -- | -- @@end_raw -- @+at -- The function 'errorMessageText' is similar to the function 'errorMessage', -- but for the body it takes a 'String' instead of a 'Doc'. It is provided -- for convenience. -- @-at -- @@c errorMessageText :: String -> String -> ErrorMessage errorMessageText heading = errorMessage heading . text -- @@raw -- | -- @@end_raw -- @+at -- The function 'leftErrorMessageText' is 'errorMessageText' composed with -- the 'Left' constructor for convenience. -- @-at -- @@c leftErrorMessageText :: String -> String -> Either ErrorMessage a leftErrorMessageText heading = Left . errorMessageText heading -- @-node:gcross.20091202203048.1620:errorMessageText / leftErrorMessageText -- @+node:gcross.20091202203048.1621:errorMessageTextFromMultilineString / leftErrorMessageTextFromMultilineString -- @@raw -- | -- @@end_raw -- @+at -- Use this function when you want to create an error message from a -- multi-line string. -- -- Although one could alternatively use 'errorMessageText', if one were to do -- this then one would only see only the first line of be indented when the -- error message is formatted for output. For example, -- -- > errorMessageText "A poem:" "Roses are red.\nViolets are blue." -- -- produces the following (formatted) error message: -- -- > A poem: -- > Roses are red. -- > Violets are blue. -- -- The reason for this is because the line breaks are not known to the 'Doc' -- combinators, and so the indentation is not handled properly. The function -- 'errorMessageTextFromMultilineString' takes care of this for you. For -- example, -- -- @-at -- @@c -- @@raw -- > errorMessageTextFromMultilineString "A poem:" "Roses are red.\nViolets are blue." -- @@end_raw -- @+at -- -- produces the following (formatted) error message: -- -- > A poem: -- > Roses are red. -- > Violets are blue. -- -- @-at -- @@c errorMessageTextFromMultilineString :: String -> String -> ErrorMessage errorMessageTextFromMultilineString heading = errorMessage heading . vcat . map text . lines -- @@raw -- | -- @@end_raw -- @+at -- The function 'leftErrorMessageTextFromMultilineString' is -- 'errorMessageTextFromMultilineString' composed with the 'Left' constructor -- for convenience. -- @-at -- @@c leftErrorMessageTextFromMultilineString :: String -> String -> Either ErrorMessage a leftErrorMessageTextFromMultilineString heading = Left . errorMessageTextFromMultilineString heading -- @-node:gcross.20091202203048.1621:errorMessageTextFromMultilineString / leftErrorMessageTextFromMultilineString -- @-node:gcross.20091202203048.7038:Error Message Creation -- @+node:gcross.20091202203048.7039:Formatting -- @+node:gcross.20091202203048.1617:formatErrorMessage -- @@raw -- | -- @@end_raw -- @+at -- This function takes an 'ErrorMessage' and formats it into a 'Doc'. It -- does this by converting the headings into 'text' objects, merging them -- with their respective bodies (the latter having been indented by four -- spaces), and then concatenating the result. -- @-at -- @@c formatErrorMessage :: ErrorMessage -> Doc formatErrorMessage = vcat . map (uncurry formatMessageWithHeading) . Map.assocs . unwrapErrorMessage -- @-node:gcross.20091202203048.1617:formatErrorMessage -- @+node:gcross.20091202203048.1618:formatMessageWithHeading -- @@raw -- | -- @@end_raw -- @+at -- This is the utility function used by 'formatErrorMessage' to format a -- 'Doc' given a heading and a body; it indents the body by four spaces and -- then appends it after the heading. -- @-at -- @@c formatMessageWithHeading :: String -> Doc -> Doc formatMessageWithHeading heading body = text heading <$$> indent 4 body -- @-node:gcross.20091202203048.1618:formatMessageWithHeading -- @-node:gcross.20091202203048.7039:Formatting -- @+node:gcross.20091202203048.7040:Extracting results from a list -- @+node:gcross.20091202203048.1616:gatherResultsOrErrors -- @@raw -- | -- @@end_raw -- @+at -- This function takes a list of values which might contain errors and -- returns either a list of the errors found in the values or the full list -- of results. Note that there is no restriction on the type of the errors. -- @-at -- @@c gatherResultsOrErrors :: [Either e a] -> Either [e] [a] gatherResultsOrErrors eithers = case partitionEithers (eithers) of ([],results) -> Right results (errors,_) -> Left errors -- @-node:gcross.20091202203048.1616:gatherResultsOrErrors -- @+node:gcross.20091202203048.1615:gatherResultsOrError -- @@raw -- | -- @@end_raw -- @+at -- This function is similar to 'gatherResultsOrErrors', but instead of -- returning a list of errors it combines them into a single error. Note -- that only restriction on the type of the error is that it be an instance -- of 'Monoid', so this operation is not limited to 'ErrorMessage's but could -- also be used for, say, 'Doc's, as in the following example: -- -- > dictionary_mapping_words_to_lengths :: [(String,Int)] -- > dictionary_mapping_words_to_lengths = -- > [("foo",3) -- > ,("bar",3) -- > ] -- > -- > getWordLengthsOrError :: [String] -> Either ErrorMessage [Int] -- > getWordLengthsOrError = -- > mapLeft -- > (errorMessage -- > "Error looking up the following words in the dictionary:" -- > ) -- > . -- > gatherResultsOrError -- > . -- > map lookupAndReturnResultOrError -- -- The function call -- -- > getWordLengthsOrError ["foo","apple","cat","bar"] -- -- results in the following error message: -- -- > Error looking up the following words in the dictionary: -- > apple -- > cat -- -- @-at -- @@c gatherResultsOrError :: Monoid e => [Either e a] -> Either e [a] gatherResultsOrError = mapLeft mconcat . gatherResultsOrErrors -- @-node:gcross.20091202203048.1615:gatherResultsOrError -- @-node:gcross.20091202203048.7040:Extracting results from a list -- @-node:gcross.20091202203048.1614:Functions -- @-others -- @<< Documentation sections >> -- @+node:gcross.20091202203048.7003:<< Documentation sections >> -- @+others -- @+node:gcross.20091202203048.7004:ErrorMessage type -- @@raw -- $error_message_type -- @@end_raw -- @+at -- The 'ErrorMessage' type is simply a map from 'String' to 'Doc'; the reason -- why the values are 'Doc' is because this allows us to compose them using -- the combinators in Leijen's pretty-printing library. -- -- The reason why the internal type is a 'Map' rather than a List is because -- we /assume/ that error message headings are unique, and so if we see the -- same heading it must have come from the same error. If we did not make -- such an assumption, then we would have no way of preventing the same error -- from appearing several times in the message in the case that many -- sub-computations all depended on the same erroneous result. -- @-at -- @@c -- @+node:gcross.20091202203048.7027:ErrorMessage instances -- @@raw -- $error_message_instances -- @@end_raw -- @+at -- In some respects, the most important part of the 'ErrorMessage' type are -- its instances: -- -- * The 'Monoid' instance says that we can take any two error messages and -- combine them using 'mappend' and/or 'mconcat'; the implementation for -- this is just that of the underlying Map type. -- -- * The 'Error' instance allows us to work inside the 'ErrorT' monad using -- 'ErrorMessage' as the error type. Although it was mentioned earlier that -- using 'Applicative' is generally preferable since it finds as many errors -- as possible before halting, there are times when a later computation -- really does need the result of an earlier computation, and in this case -- the sequential structure of 'Monad's exactly fits the bill. -- -- Note that in order for 'ErrorMessage' to be an instance of 'Error', I -- needed to define how to create an 'ErrorMessage' without a heading -- ('strMsg') and possibly without even a body ('noMsg'); however, if this -- ever happens, it means that the error was not handled properly --- e.g., -- when there is a pattern match failure. Thus, the heading of errors -- created by 'noMsg' and 'strMsg' is -- /Error caused by the programmer:/ -- @-at -- @@c -- @-node:gcross.20091202203048.7027:ErrorMessage instances -- @+node:gcross.20091202203048.7029:Doc instances -- @@raw -- $doc_instances -- @@end_raw -- @+at -- Unfortunately, it does not show up in the API documentation that this -- module also defines the following two instances for 'Doc': -- -- * The 'Monoid' instance says that we can combine any two 'Doc's by -- concatenating them vertically. -- -- * The 'Error' instance defines a 'noMsg' error to be the 'empty' 'Doc' and -- the 'strMsg' error to be a 'text' 'Doc'. -- -- @-at -- @@c -- @-node:gcross.20091202203048.7029:Doc instances -- @+node:gcross.20091202203048.7031:Applicative instances -- @@raw -- $applicative_instances -- @@end_raw -- @+at -- Unfortunately, it does not show up in the API documentation that this -- module also defines the following two 'Applicative' instances: -- -- @-at -- @@c -- @@raw -- > instance (Monoid e) => Applicative (Either e) where ... -- @@end_raw -- @+at -- -- This instance declaration allows you to lift pure functions into functions -- that work with values that might have errors, since both 'Doc' and -- 'ErrorMessage' are instances of 'Monoid'. For example, we can use -- @liftA2 (+)@ to lift the @(+)@ function into a function that checks both -- of its arguments for errors before computing the sum. As was described -- earlier, the advantage of @liftA2 (+)@ over @liftM2 (+)@ is that the -- former checks for errors in both arguments and will combine them if -- present, whereas the latter will ignore errors in the second argument if -- there is an error in the first argument. -- -- @-at -- @@c -- @@raw -- > instance (Monoid e, Error e, Monad m) => Applicative (ErrorT e m) where -- > pure = return -- > e_fn <*> e_arg = ErrorT $ liftM2 (<*>) (runErrorT e_fn) (runErrorT e_arg) -- @@end_raw -- @+at -- -- This instance definition lifts the @Applicative (Either e)@ so that it -- works for values obtained from monadic computations. Note that the -- definition first executes the monad @e_fn@ and then the monad @e_arg@, and -- only after both monads have been executed in this sequence does it apply -- the operator @(\<*\>)@ to the values in order to possibly combine their -- error messages. -- -- These instances allow you to write code like the following: -- -- @-at -- @@c -- @@raw -- > data Point = Point { x :: Int, y :: Int, z :: Int } -- > -- > pOrError = Point <$> xOrError <*> yOrError <*> zOrError -- @@end_raw -- @+at -- -- The value @pOrError@ is either a @Point@, or a combination of the error -- messages in @xOrError@, @yOrError@, and @zOrError@. -- -- @-at -- @@c -- @-node:gcross.20091202203048.7031:Applicative instances -- @-node:gcross.20091202203048.7004:ErrorMessage type -- @+node:gcross.20091202203048.7032:Creating Error Messages -- @@raw -- $error_message_creation -- @@end_raw -- @+at -- Up to now we have spent a lot time discussing how to combine -- 'ErrorMessage's, but little time discussing how to produce them. The -- provided functions for doing this are as follows: -- @-at -- @@c -- @-node:gcross.20091202203048.7032:Creating Error Messages -- @+node:gcross.20091202203048.7042:Formatting Error Messages -- @@raw -- $error_message_formatting -- @@end_raw -- @+at -- The end purpose of 'ErrorMessage' \'s existence is to be displayed to the -- user. Towards this end, the following functions format an 'ErrorMessage' -- into a 'Doc'. -- @-at -- @@c -- @-node:gcross.20091202203048.7042:Formatting Error Messages -- @+node:gcross.20091202203048.7044:Gathering Results with Errors -- @@raw -- $gathering_results_with_errors -- @@end_raw -- @+at -- Although there are many combinators available (such as 'liftA' and \<$\>) -- for lifting pure functions to functions that handle errors, there are -- times when one wants to gather together a list of results which might -- possibly contain some errors. The following functions assist in doing -- this. -- @-at -- @@c -- @-node:gcross.20091202203048.7044:Gathering Results with Errors -- @-others -- @-node:gcross.20091202203048.7003:<< Documentation sections >> -- @nl -- @-node:gcross.20091202203048.1603:@thin ErrorMessage.hs -- @-leo