Allow errors to carry multiple positions (purescript#3255)

garyb · web-flow · commit 3171a77e117e · 2018-03-10T20:01:09.000Z
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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,15 +315,15 @@ 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)) $
         not (M.member qualifiedClassName (typeClasses env))
       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
@@ -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
@@ -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
