module Language.PureScript.Errors where
import Data.List (intercalate)
import Data.Monoid
import Control.Monad.Error
import Language.PureScript.Declarations
import Language.PureScript.Pretty
import Language.PureScript.Types
data ErrorSource
= ValueError Value
| TypeError Type deriving (Show)
data CompileError = CompileError {
compileErrorMessage :: String
, compileErrorValue :: Maybe ErrorSource
, compileErrorPosition :: Maybe SourcePos
} deriving (Show)
newtype ErrorStack = ErrorStack { runErrorStack :: [CompileError] } deriving (Show, Monoid)
instance Error ErrorStack where
strMsg s = ErrorStack [CompileError s Nothing Nothing]
noMsg = ErrorStack []
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')
stringifyErrorStack :: Bool -> Either ErrorStack a -> Either String a
stringifyErrorStack printFullStack = either (Left . prettyPrintErrorStack printFullStack) Right
isErrorNonEmpty :: CompileError -> Bool
isErrorNonEmpty = not . null . compileErrorMessage
showError :: CompileError -> String
showError (CompileError msg Nothing _) = msg
showError (CompileError msg (Just (ValueError val)) _) = "Error in value " ++ 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 [CompileError msg t Nothing]
positionError :: SourcePos -> ErrorStack
positionError pos = ErrorStack [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) => SourcePos -> m a -> m a
rethrowWithPosition pos = rethrow (positionError pos <>)