@@ -0,0 +1,98 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Error
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
16+
17+module Language.PureScript.Errors where
18+
19+import Data.List (intercalate)
20+import Data.Monoid
21+
22+import Control.Monad.Error
23+
24+import Language.PureScript.Declarations
25+import Language.PureScript.Options
26+import Language.PureScript.Pretty
27+import Language.PureScript.Types
28+
29+-- |
30+-- Type for sources of type checking errors
31+--
32+data UnifyErrorSource
33+ -- |
34+ -- An error which originated at a Value
35+ --
36+ = ValueError Value
37+ -- |
38+ -- An error which originated at a Type
39+ --
40+ | TypeError Type deriving (Show)
41+
42+-- |
43+-- Unification errors
44+--
45+data UnifyError = UnifyError {
46+ -- |
47+ -- Error message
48+ --
49+ unifyErrorMessage :: String
50+ -- |
51+ -- The value where the error occurred
52+ --
53+ , unifyErrorValue :: Maybe UnifyErrorSource
54+ -- |
55+ -- Optional source position information
56+ --
57+ , unifyErrorPosition :: Maybe SourcePos
58+ } deriving (Show)
59+
60+-- |
61+-- A stack trace for an error
62+--
63+newtype UnifyErrorStack = UnifyErrorStack { runUnifyErrorStack :: [UnifyError] } deriving (Show, Monoid)
64+
65+instance Error UnifyErrorStack where
66+ strMsg s = UnifyErrorStack [UnifyError s Nothing Nothing]
67+ noMsg = UnifyErrorStack []
68+
69+prettyPrintUnifyErrorStack :: Options -> UnifyErrorStack -> String
70+prettyPrintUnifyErrorStack opts (UnifyErrorStack es) =
71+ case mconcat $ map (Last . unifyErrorPosition) es of
72+ Last (Just sourcePos) -> "Error at " ++ show sourcePos ++ ": \n" ++ prettyPrintUnifyErrorStack'
73+ _ -> prettyPrintUnifyErrorStack'
74+ where
75+ prettyPrintUnifyErrorStack' :: String
76+ prettyPrintUnifyErrorStack'
77+ | optionsVerboseErrors opts =
78+ intercalate "\n" (map showError (filter isErrorNonEmpty es))
79+ | otherwise =
80+ let
81+ es' = filter isErrorNonEmpty es
82+ in case length es' of
83+ 1 -> showError (head es')
84+ _ -> showError (head es') ++ "\n" ++ showError (last es')
85+
86+isErrorNonEmpty :: UnifyError -> Bool
87+isErrorNonEmpty = not . null . unifyErrorMessage
88+
89+showError :: UnifyError -> String
90+showError (UnifyError msg Nothing _) = msg
91+showError (UnifyError msg (Just (ValueError val)) _) = "Error in value " ++ prettyPrintValue val ++ "\n" ++ msg
92+showError (UnifyError msg (Just (TypeError ty)) _) = "Error in type " ++ prettyPrintType ty ++ "\n" ++ msg
93+
94+mkUnifyErrorStack :: String -> Maybe UnifyErrorSource -> UnifyErrorStack
95+mkUnifyErrorStack msg t = UnifyErrorStack [UnifyError msg t Nothing]
96+
97+positionError :: SourcePos -> UnifyErrorStack
98+positionError pos = UnifyErrorStack [UnifyError "" Nothing (Just pos)]