module Language.PureScript.Errors where
import Data.Either (lefts, rights)
import Data.String (IsString(..))
import Data.List (intersperse, intercalate)
import Data.Monoid
import Control.Monad.Except
import Control.Applicative ((<$>))
import Language.PureScript.AST
import Language.PureScript.Pretty
import Language.PureScript.Types
data ErrorSource
= ExprError Expr
| TypeError Type deriving (Show)
data CompileError
= CompileError
{
compileErrorMessage :: String
, compileErrorValue :: Maybe ErrorSource
, compileErrorPosition :: Maybe SourceSpan
}
deriving (Show)
data ErrorStack
= ErrorStack { runErrorStack :: [CompileError] }
| MultipleErrors [ErrorStack] deriving (Show)
strMsg :: String -> ErrorStack
strMsg s = ErrorStack [CompileError s Nothing Nothing]
instance IsString ErrorStack where
fromString = strMsg
prettyPrintErrorStack :: Bool -> ErrorStack -> String
prettyPrintErrorStack printFullStack (ErrorStack es) =
case mconcat $ map (Last . compileErrorPosition) es of
Last (Just sourcePos) -> "Error at " ++ show sourcePos ++ ": \n" ++ prettyPrintErrorStack'
_ -> prettyPrintErrorStack'
where
prettyPrintErrorStack' :: String
prettyPrintErrorStack'
| printFullStack = intercalate "\n" (map showError (filter isErrorNonEmpty es))
| otherwise =
let
es' = filter isErrorNonEmpty es
in case length es' of
1 -> showError (head es')
_ -> showError (head es') ++ "\n" ++ showError (last es')
prettyPrintErrorStack printFullStack (MultipleErrors es) =
unlines $ intersperse "" $ "Multiple errors:" : map (prettyPrintErrorStack printFullStack) es
stringifyErrorStack :: (MonadError String m) => Bool -> Either ErrorStack a -> m a
stringifyErrorStack printFullStack = either (throwError . prettyPrintErrorStack printFullStack) return
isErrorNonEmpty :: CompileError -> Bool
isErrorNonEmpty = not . null . compileErrorMessage
showError :: CompileError -> String
showError (CompileError msg Nothing _) = msg
showError (CompileError msg (Just (ExprError val)) _) = "Error in expression " ++ prettyPrintValue val ++ ":\n" ++ msg
showError (CompileError msg (Just (TypeError ty)) _) = "Error in type " ++ prettyPrintType ty ++ ":\n" ++ msg
mkErrorStack :: String -> Maybe ErrorSource -> ErrorStack
mkErrorStack msg t = ErrorStack [mkCompileError msg t]
mkCompileError :: String -> Maybe ErrorSource -> CompileError
mkCompileError msg t = CompileError msg t Nothing
positionError :: SourceSpan -> CompileError
positionError pos = CompileError "" Nothing (Just pos)
rethrow :: (MonadError e m) => (e -> e) -> m a -> m a
rethrow f = flip catchError $ \e -> throwError (f e)
rethrowWithPosition :: (MonadError ErrorStack m) => SourceSpan -> m a -> m a
rethrowWithPosition pos = rethrow (positionError pos `combineErrors`)
parU :: (MonadError ErrorStack m, Functor m) => [a] -> (a -> m b) -> m [b]
parU xs f = forM xs (withError . f) >>= collectErrors
where
withError :: (MonadError ErrorStack m, Functor m) => m a -> m (Either ErrorStack a)
withError u = catchError (Right <$> u) (return . Left)
collectErrors :: (MonadError ErrorStack m, Functor m) => [Either ErrorStack a] -> m [a]
collectErrors es = case lefts es of
[err] -> throwError err
[] -> return $ rights es
errs -> throwError $ MultipleErrors errs
combineErrors :: CompileError -> ErrorStack -> ErrorStack
combineErrors ce err = go (ErrorStack [ce]) err
where
go (ErrorStack xs) (ErrorStack ys) = ErrorStack (xs ++ ys)
go (MultipleErrors es) x = MultipleErrors [ go e x | e <- es ]
go x (MultipleErrors es) = MultipleErrors [ go x e | e <- es ]