-- @+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