diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 41eabcab53..adc8f95c54 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -198,7 +198,7 @@ data ErrorMessageHint | ErrorInTypeClassDeclaration (ProperName 'ClassName) | ErrorInForeignImport Ident | ErrorSolvingConstraint Constraint - | PositionedError SourceSpan + | PositionedError (NEL.NonEmpty SourceSpan) deriving (Show) -- | Categories of hints diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index d260836946..f9c40519ff 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -47,7 +47,7 @@ import qualified Text.PrettyPrint.Boxes as Box newtype ErrorSuggestion = ErrorSuggestion Text -- | Get the source span for an error -errorSpan :: ErrorMessage -> Maybe SourceSpan +errorSpan :: ErrorMessage -> Maybe (NEL.NonEmpty SourceSpan) errorSpan = findHint matchSpan where matchSpan (PositionedError ss) = Just ss @@ -195,7 +195,7 @@ errorMessage err = MultipleErrors [ErrorMessage [] err] -- | Create an error set from a single simple error message and source annotation errorMessage' :: SourceSpan -> SimpleErrorMessage -> MultipleErrors -errorMessage' ss err = MultipleErrors [ErrorMessage [PositionedError ss] err] +errorMessage' ss err = MultipleErrors [ErrorMessage [positionedError ss] err] -- | Create an error set from a single error message singleError :: ErrorMessage -> MultipleErrors @@ -327,7 +327,10 @@ errorSuggestion err = suggestionSpan :: ErrorMessage -> Maybe SourceSpan suggestionSpan e = - getSpan (unwrapErrorMessage e) <$> errorSpan e + -- The `NEL.head` is a bit arbitrary here, but I don't think we'll + -- have errors-with-suggestions that also have multiple source + -- spans. -garyb + getSpan (unwrapErrorMessage e) . NEL.head <$> errorSpan e where startOnly SourceSpan{spanName, spanStart} = SourceSpan {spanName, spanStart, spanEnd = spanStart} @@ -1108,7 +1111,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl ] ] renderHint (PositionedError srcSpan) detail = - paras [ line $ "at " <> displaySourceSpan relPath srcSpan + paras [ line $ "at " <> displaySourceSpan relPath (NEL.head srcSpan) , detail ] @@ -1393,7 +1396,10 @@ warnAndRethrowWithPosition :: (MonadError MultipleErrors m, MonadWriter Multiple warnAndRethrowWithPosition pos = rethrowWithPosition pos . warnWithPosition pos withPosition :: SourceSpan -> ErrorMessage -> ErrorMessage -withPosition pos (ErrorMessage hints se) = ErrorMessage (PositionedError pos : hints) se +withPosition pos (ErrorMessage hints se) = ErrorMessage (positionedError pos : hints) se + +positionedError :: SourceSpan -> ErrorMessageHint +positionedError = PositionedError . pure -- | Runs a computation listening for warnings and then escalating any warnings -- that match the predicate to error status. diff --git a/src/Language/PureScript/Errors/JSON.hs b/src/Language/PureScript/Errors/JSON.hs index d013235011..65f872d23b 100644 --- a/src/Language/PureScript/Errors/JSON.hs +++ b/src/Language/PureScript/Errors/JSON.hs @@ -5,6 +5,7 @@ module Language.PureScript.Errors.JSON where import Prelude.Compat import qualified Data.Aeson.TH as A +import qualified Data.List.NonEmpty as NEL import Data.Monoid ((<>)) import qualified Data.Text as T import Data.Text (Text) @@ -31,6 +32,7 @@ data JSONError = JSONError , filename :: Maybe String , moduleName :: Maybe Text , suggestion :: Maybe ErrorSuggestion + , allSpans :: [P.SourceSpan] } deriving (Show, Eq) data JSONResult = JSONResult @@ -43,22 +45,22 @@ $(A.deriveJSON A.defaultOptions ''JSONError) $(A.deriveJSON A.defaultOptions ''JSONResult) $(A.deriveJSON A.defaultOptions ''ErrorSuggestion) - toJSONErrors :: Bool -> P.Level -> P.MultipleErrors -> [JSONError] toJSONErrors verbose level = map (toJSONError verbose level) . P.runMultipleErrors toJSONError :: Bool -> P.Level -> P.ErrorMessage -> JSONError toJSONError verbose level e = - JSONError (toErrorPosition <$> sspan) + JSONError (toErrorPosition <$> fmap NEL.head spans) (P.renderBox (P.prettyPrintSingleError (P.PPEOptions Nothing verbose level False mempty) (P.stripModuleAndSpan e))) (P.errorCode e) (P.errorDocUri e) - (P.spanName <$> sspan) + (P.spanName <$> fmap NEL.head spans) (P.runModuleName <$> P.errorModule e) (toSuggestion e) + (maybe [] NEL.toList spans) where - sspan :: Maybe P.SourceSpan - sspan = P.errorSpan e + spans :: Maybe (NEL.NonEmpty P.SourceSpan) + spans = P.errorSpan e toErrorPosition :: P.SourceSpan -> ErrorPosition toErrorPosition ss = diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 0486696220..71ecd20cc9 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -351,7 +351,7 @@ parseModuleFromFile toFilePath (k, content) = do -- | Converts a 'ParseError' into a 'PositionedError' toPositionedError :: P.ParseError -> ErrorMessage -toPositionedError perr = ErrorMessage [ PositionedError (SourceSpan name start end) ] (ErrorParsingModule perr) +toPositionedError perr = ErrorMessage [ positionedError (SourceSpan name start end) ] (ErrorParsingModule perr) where name = (P.sourceName . P.errorPos) perr start = (toSourcePos . P.errorPos) perr diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 9ec8c0960a..9cd3500098 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -233,7 +233,7 @@ typeCheckAll moduleName _ = traverse go where go :: Declaration -> m Declaration go (DataDeclaration sa@(ss, _) dtype name args dctors) = do - warnAndRethrow (addHint (ErrorInTypeConstructor name) . addHint (PositionedError ss)) $ do + warnAndRethrow (addHint (ErrorInTypeConstructor name) . addHint (positionedError ss)) $ do when (dtype == Newtype) $ checkNewtype name dctors checkDuplicateTypeArguments $ map fst args ctorKind <- kindsOf True moduleName name args (concatMap snd dctors) @@ -263,7 +263,7 @@ typeCheckAll moduleName _ = traverse go toDataDecl (DataDeclaration _ dtype nm args dctors) = Just (dtype, nm, args, dctors) toDataDecl _ = Nothing go (TypeSynonymDeclaration sa@(ss, _) name args ty) = do - warnAndRethrow (addHint (ErrorInTypeSynonym name) . addHint (PositionedError ss) ) $ do + warnAndRethrow (addHint (ErrorInTypeSynonym name) . addHint (positionedError ss) ) $ do checkDuplicateTypeArguments $ map fst args kind <- kindsOf False moduleName name args [ty] let args' = args `withKinds` kind @@ -273,7 +273,7 @@ typeCheckAll moduleName _ = traverse go internalError "Type declarations should have been removed before typeCheckAlld" go (ValueDecl sa@(ss, _) name nameKind [] [MkUnguarded val]) = do env <- getEnv - warnAndRethrow (addHint (ErrorInValueDeclaration name) . addHint (PositionedError ss)) $ do + warnAndRethrow (addHint (ErrorInValueDeclaration name) . addHint (positionedError ss)) $ do val' <- checkExhaustiveExpr ss env moduleName val valueIsNotDefined moduleName name [(_, (val'', ty))] <- typesOf NonRecursiveBindingGroup moduleName [((sa, name), val')] @@ -304,7 +304,7 @@ typeCheckAll moduleName _ = traverse go putEnv $ env { kinds = S.insert (Qualified (Just moduleName) name) (kinds env) } return d go (d@(ExternDeclaration (ss, _) name ty)) = do - warnAndRethrow (addHint (ErrorInForeignImport name) . addHint (PositionedError ss)) $ do + warnAndRethrow (addHint (ErrorInForeignImport name) . addHint (positionedError ss)) $ do env <- getEnv kind <- kindOf ty guardWith (errorMessage (ExpectedType ty kind)) $ kind == kindType @@ -315,7 +315,7 @@ typeCheckAll moduleName _ = traverse go go d@FixityDeclaration{} = return d go d@ImportDeclaration{} = return d go d@(TypeClassDeclaration (ss, _) pn args implies deps tys) = do - warnAndRethrow (addHint (ErrorInTypeClassDeclaration pn) . addHint (PositionedError ss)) $ do + warnAndRethrow (addHint (ErrorInTypeClassDeclaration pn) . addHint (positionedError ss)) $ do env <- getEnv let qualifiedClassName = Qualified (Just moduleName) pn guardWith (errorMessage (DuplicateTypeClass pn ss)) $ @@ -323,7 +323,7 @@ typeCheckAll moduleName _ = traverse go addTypeClass qualifiedClassName args implies deps tys return d go (d@(TypeInstanceDeclaration (ss, _) ch idx dictName deps className tys body)) = - rethrow (addHint (ErrorInInstance className tys) . addHint (PositionedError ss)) $ do + rethrow (addHint (ErrorInInstance className tys) . addHint (positionedError ss)) $ do env <- getEnv let qualifiedDictName = Qualified (Just moduleName) dictName flip (traverse_ . traverse_) (typeClassDictionaries env) $ \dictionaries -> @@ -568,4 +568,3 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = extractMemberName (TypeDeclaration td) = tydeclIdent td extractMemberName _ = internalError "Unexpected declaration in typeclass member list" checkClassMembersAreExported _ = return () - diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 4fee1b8586..c8ecc791c2 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -127,7 +127,7 @@ rethrowWithPositionTC => SourceSpan -> m a -> m a -rethrowWithPositionTC pos = withErrorMessageHint (PositionedError pos) +rethrowWithPositionTC pos = withErrorMessageHint (positionedError pos) warnAndRethrowWithPositionTC :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs index 0b6ef54537..f80d87e177 100644 --- a/src/Language/PureScript/TypeChecker/Skolems.hs +++ b/src/Language/PureScript/TypeChecker/Skolems.hs @@ -100,7 +100,7 @@ skolemEscapeCheck expr@TypedValue{} = go (scopes, _) (PositionedValue ss _ _) = ((scopes, Just ss), []) go (scopes, ssUsed) val@(TypedValue _ _ ty) = ( (allScopes, ssUsed) - , [ ErrorMessage (maybe id ((:) . PositionedError) ssUsed [ ErrorInExpression val ]) $ + , [ ErrorMessage (maybe id ((:) . positionedError) ssUsed [ ErrorInExpression val ]) $ EscapedSkolem name ssBound ty | (name, scope, ssBound) <- collectSkolems ty , notMember scope allScopes