@@ -1,6 +1,5 @@
11{-# LANGUAGE GeneralizedNewtypeDeriving #-}
22{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE RecordWildCards #-}
43{-# LANGUAGE MultiParamTypeClasses #-}
54
65module Language.PureScript.Errors where
@@ -9,6 +8,7 @@ import Prelude ()
98import Prelude.Compat
109
1110import Data.Ord (comparing)
11+import Data.Char (isSpace)
1212import Data.Either (lefts, rights)
1313import Data.List (intercalate, transpose, nub, nubBy, sortBy)
1414import Data.Foldable (fold)
@@ -412,11 +412,9 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse
412412 gHint (ErrorInInstance cl ts) = ErrorInInstance cl <$> traverse f ts
413413 gHint other = pure other
414414
415−
416415wikiUri :: ErrorMessage -> String
417416wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e
418417
419−
420418-- |
421419-- Pretty print a single error, simplifying if necessary
422420--
@@ -432,17 +430,17 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
432430 prettyPrintErrorMessage typeMap (ErrorMessage hints simple) =
433431 paras $
434432 [ foldr renderHint (indent (renderSimpleErrorMessage simple)) hints
435− , Box.moveDown 1 typeInformation
436433 ] ++
434+ maybe [] (return . Box.moveDown 1) typeInformation ++
437435 [ Box.moveDown 1 $ paras [ line $ "See " ++ wikiUri e ++ " for more information, "
438436 , line $ "or to contribute content related to this " ++ levelText ++ "."
439437 ]
440− | showWiki
438+ | showWiki
441439 ]
442440 where
443− typeInformation :: Box.Box
444− typeInformation | not (null types) = Box.hsep 1 Box.left [ line "where", paras types]
445− | otherwise = Box.emptyBox 0 0
441+ typeInformation :: Maybe Box.Box
442+ typeInformation | not (null types) = Just $ Box.hsep 1 Box.left [ line "where", paras types ]
443+ | otherwise = Nothing
446444 where
447445 types :: [Box.Box]
448446 types = map skolemInfo (M.elems (umSkolemMap typeMap)) ++
@@ -1026,7 +1024,7 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
10261024 where
10271025 -- Take the last instance of each "hint category"
10281026 simplifyHints :: [ErrorMessageHint] -> [ErrorMessageHint]
1029− simplifyHints = reverse . nubBy categoriesEqual . reverse
1027+ simplifyHints = reverse . nubBy categoriesEqual . stripRedudantHints simple . reverse
10301028
10311029 -- Don't remove hints in the "other" category
10321030 categoriesEqual :: ErrorMessageHint -> ErrorMessageHint -> Bool
@@ -1036,6 +1034,30 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
10361034 (_, OtherHint) -> False
10371035 (c1, c2) -> c1 == c2
10381036
1037+ -- | See https://github.com/purescript/purescript/issues/1802
1038+ stripRedudantHints :: SimpleErrorMessage -> [ErrorMessageHint] -> [ErrorMessageHint]
1039+ stripRedudantHints CannotApplyFunction{} = stripFirst isApplicationHint
1040+ where
1041+ isApplicationHint ErrorInApplication{} = True
1042+ isApplicationHint _ = False
1043+ stripRedudantHints ExprDoesNotHaveType{} = stripFirst isCheckHint
1044+ where
1045+ isCheckHint ErrorCheckingType{} = True
1046+ isCheckHint _ = False
1047+ stripRedudantHints TypesDoNotUnify{} = stripFirst isUnifyHint
1048+ where
1049+ isUnifyHint ErrorUnifyingTypes{} = True
1050+ isUnifyHint _ = False
1051+ stripRedudantHints _ = id
1052+
1053+ stripFirst :: (ErrorMessageHint -> Bool) -> [ErrorMessageHint] -> [ErrorMessageHint]
1054+ stripFirst p (PositionedError pos : hs) = PositionedError pos : stripFirst p hs
1055+ stripFirst p (ErrorInModule mn : hs) = ErrorInModule mn : stripFirst p hs
1056+ stripFirst p (hint : hs)
1057+ | p hint = hs
1058+ | otherwise = hint : hs
1059+ stripFirst _ [] = []
1060+
10391061 hintCategory :: ErrorMessageHint -> HintCategory
10401062 hintCategory ErrorCheckingType{} = ExprHint
10411063 hintCategory ErrorInferringType{} = ExprHint
@@ -1137,9 +1159,15 @@ line :: String -> Box.Box
11371159line = Box.text
11381160
11391161renderBox :: Box.Box -> String
1140−renderBox = unlines . map trimEnd . lines . Box.render
1162+renderBox = unlines
1163+ . map (dropWhileEnd isSpace)
1164+ . dropWhile whiteSpace
1165+ . dropWhileEnd whiteSpace
1166+ . lines
1167+ . Box.render
11411168 where
1142− trimEnd = reverse . dropWhile (== ' ') . reverse
1169+ dropWhileEnd p = reverse . dropWhile p . reverse
1170+ whiteSpace = all isSpace
11431171
11441172-- |
11451173-- Rethrow an error with a more detailed error message in the case of failure