diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 93f8d879e5..5fc08867ae 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -85,7 +85,8 @@ data SimpleErrorMessage | OrphanTypeDeclaration Ident | RedefinedIdent Ident | OverlappingNamesInLet - | UnknownName (Qualified Name) + | UnknownName [(ModuleName, DeclarationRef)] (Qualified Name) + -- ^ possible imports (filled with values in Make); missing name | UnknownImport ModuleName Name | UnknownImportDataConstructor ModuleName (ProperName 'TypeName) (ProperName 'ConstructorName) | UnknownExport Name diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index cb4f460952..5661fb1669 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -319,11 +319,11 @@ errorDocUri e = "https://github.com/purescript/documentation/blob/master/errors/ -- TODO Other possible suggestions: -- WildcardInferredType - source span not small enough -- DuplicateSelectiveImport - would require 2 ranges to remove and 1 insert -errorSuggestion :: SimpleErrorMessage -> Maybe ErrorSuggestion -errorSuggestion err = +errorSuggestions :: SimpleErrorMessage -> [ErrorSuggestion] +errorSuggestions err = case err of - UnusedImport{} -> emptySuggestion - DuplicateImport{} -> emptySuggestion + UnusedImport{} -> [] + DuplicateImport{} -> [] UnusedExplicitImport mn _ qual refs -> suggest $ importSuggestion mn refs qual UnusedDctorImport mn _ qual refs -> suggest $ importSuggestion mn refs qual UnusedDctorExplicitImport mn _ _ qual refs -> suggest $ importSuggestion mn refs qual @@ -333,17 +333,21 @@ errorSuggestion err = HidingImport mn refs -> suggest $ importSuggestion mn refs Nothing MissingTypeDeclaration ident ty -> suggest $ showIdent ident <> " :: " <> T.pack (prettyPrintSuggestedType ty) WildcardInferredType ty _ -> suggest $ T.pack (prettyPrintSuggestedType ty) - _ -> Nothing + UnknownName alternatives _ -> suggestMultiple $ (\(mn, ref) -> importSuggestionWithReexport mn ref) <$> alternatives + _ -> [] + where + suggest a = [ErrorSuggestion a] + suggestMultiple = map ErrorSuggestion + importSuggestionWithReexport :: ModuleName -> DeclarationRef -> Text + importSuggestionWithReexport mn (ReExportRef _ _ ref) = importSuggestionWithReexport mn ref + importSuggestionWithReexport mn other = importSuggestion mn [other] Nothing + +importSuggestion :: ModuleName -> [ DeclarationRef ] -> Maybe ModuleName -> Text +importSuggestion mn refs qual = + "import " <> runModuleName mn <> " (" <> T.intercalate ", " (mapMaybe prettyPrintRef refs) <> ")" <> qstr qual where - emptySuggestion = Just $ ErrorSuggestion "" - suggest = Just . ErrorSuggestion - - importSuggestion :: ModuleName -> [ DeclarationRef ] -> Maybe ModuleName -> Text - importSuggestion mn refs qual = - "import " <> runModuleName mn <> " (" <> T.intercalate ", " (mapMaybe prettyPrintRef refs) <> ")" <> qstr qual - qstr :: Maybe ModuleName -> Text - qstr (Just mn) = " as " <> runModuleName mn + qstr (Just moduleName) = " as " <> runModuleName moduleName qstr Nothing = "" suggestionSpan :: ErrorMessage -> Maybe SourceSpan @@ -360,10 +364,8 @@ suggestionSpan e = MissingTypeDeclaration{} -> startOnly ss _ -> ss -showSuggestion :: SimpleErrorMessage -> Text -showSuggestion suggestion = case errorSuggestion suggestion of - Just (ErrorSuggestion x) -> x - _ -> "" +showSuggestions :: SimpleErrorMessage -> [Text] +showSuggestions simpleError = (\(ErrorSuggestion message) -> message) <$> errorSuggestions simpleError ansiColor :: (ANSI.ColorIntensity, ANSI.Color) -> String ansiColor (intesity, color) = @@ -534,10 +536,12 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl line $ "The type declaration for " <> markCode (showIdent nm) <> " should be followed by its definition." renderSimpleErrorMessage (RedefinedIdent name) = line $ "The value " <> markCode (showIdent name) <> " has been defined multiple times" - renderSimpleErrorMessage (UnknownName name@(Qualified Nothing (IdentName (Ident i)))) | i `elem` [ C.bind, C.discard ] = + renderSimpleErrorMessage (UnknownName _ name@(Qualified Nothing (IdentName (Ident i)))) | i `elem` [ C.bind, C.discard ] = line $ "Unknown " <> printName name <> ". You're probably using do-notation, which the compiler replaces with calls to the " <> markCode i <> " function. Please import " <> markCode i <> " from module " <> markCode "Prelude" - renderSimpleErrorMessage (UnknownName name) = - line $ "Unknown " <> printName name + renderSimpleErrorMessage msg@(UnknownName _ name) = + paras [ line $ "Unknown " <> printName name + , indent $ Box.vcat Box.left $ line . markCode <$> showSuggestions msg + ] renderSimpleErrorMessage (UnknownImport mn name) = paras [ line $ "Cannot import " <> printName (Qualified Nothing name) <> " from module " <> markCode (runModuleName mn) , line "It either does not exist or the module does not export it." @@ -904,20 +908,20 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line $ "The import of module " <> markCode (runModuleName mn) <> " contains the following unused references:" , indent $ paras $ map (line . markCode . runName . Qualified Nothing) names , line "It could be replaced with:" - , indent $ line $ markCode $ showSuggestion msg ] + , indent $ Box.vcat Box.left $ line . markCode <$> showSuggestions msg ] renderSimpleErrorMessage msg@(UnusedDctorImport mn name _ _) = paras [line $ "The import of type " <> markCode (runProperName name) <> " from module " <> markCode (runModuleName mn) <> " includes data constructors but only the type is used" , line "It could be replaced with:" - , indent $ line $ markCode $ showSuggestion msg ] + , indent $ Box.vcat Box.left $ line . markCode <$> showSuggestions msg ] renderSimpleErrorMessage msg@(UnusedDctorExplicitImport mn name names _ _) = paras [ line $ "The import of type " <> markCode (runProperName name) <> " from module " <> markCode (runModuleName mn) <> " includes the following unused data constructors:" , indent $ paras $ map (line . markCode . runProperName) names , line "It could be replaced with:" - , indent $ line $ markCode $ showSuggestion msg ] + , indent $ Box.vcat Box.left $ line . markCode <$> showSuggestions msg ] renderSimpleErrorMessage (DuplicateSelectiveImport name) = line $ "There is an existing import of " <> markCode (runModuleName name) <> ", consider merging the import lists" @@ -938,22 +942,22 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl renderSimpleErrorMessage msg@(ImplicitQualifiedImport importedModule asModule _) = paras [ line $ "Module " <> markCode (runModuleName importedModule) <> " was imported as " <> markCode (runModuleName asModule) <> " with unspecified imports." , line $ "As there are multiple modules being imported as " <> markCode (runModuleName asModule) <> ", consider using the explicit form:" - , indent $ line $ markCode $ showSuggestion msg + , indent $ Box.vcat Box.left $ line . markCode <$> showSuggestions msg ] renderSimpleErrorMessage msg@(ImplicitQualifiedImportReExport importedModule asModule _) = paras [ line $ "Module " <> markCode (runModuleName importedModule) <> " was imported as " <> markCode (runModuleName asModule) <> " with unspecified imports." , line $ "As this module is being re-exported, consider using the explicit form:" - , indent $ line $ markCode $ showSuggestion msg + , indent $ Box.vcat Box.left $ line . markCode <$> showSuggestions msg ] renderSimpleErrorMessage msg@(ImplicitImport mn _) = paras [ line $ "Module " <> markCode (runModuleName mn) <> " has unspecified imports, consider using the explicit form: " - , indent $ line $ markCode $ showSuggestion msg + , indent $ Box.vcat Box.left $ line . markCode <$> showSuggestions msg ] renderSimpleErrorMessage msg@(HidingImport mn _) = paras [ line $ "Module " <> markCode (runModuleName mn) <> " has unspecified imports, consider using the inclusive form: " - , indent $ line $ markCode $ showSuggestion msg + , indent $ Box.vcat Box.left $ line . markCode <$> showSuggestions msg ] renderSimpleErrorMessage (CaseBinderLengthDiffers l bs) = @@ -1185,6 +1189,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line $ "at " <> displaySourceSpan relPath (NEL.head srcSpan) , detail ] + printRow :: (Int -> Type a -> Box.Box) -> Type a -> Box.Box printRow f t = markCodeBox $ indent $ f prettyDepth t diff --git a/src/Language/PureScript/Errors/JSON.hs b/src/Language/PureScript/Errors/JSON.hs index f552f91f03..458179689d 100644 --- a/src/Language/PureScript/Errors/JSON.hs +++ b/src/Language/PureScript/Errors/JSON.hs @@ -69,9 +69,9 @@ toJSONError verbose level e = (P.sourcePosColumn (P.spanEnd ss)) toSuggestion :: P.ErrorMessage -> Maybe ErrorSuggestion toSuggestion em = - case P.errorSuggestion $ P.unwrapErrorMessage em of - Nothing -> Nothing - Just s -> Just $ ErrorSuggestion (suggestionText s) (toErrorPosition <$> P.suggestionSpan em) + case P.errorSuggestions $ P.unwrapErrorMessage em of + [] -> Nothing + s -> Just $ ErrorSuggestion (T.unlines $ suggestionText <$> s) (toErrorPosition <$> P.suggestionSpan em) -- TODO: Adding a newline because source spans chomp everything up to the next character suggestionText (P.ErrorSuggestion s) = if T.null s then s else s <> "\n" diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index f983266420..7db95a43db 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -34,6 +34,7 @@ import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Externs import Language.PureScript.Linter +import Language.PureScript.Suggest import Language.PureScript.ModuleDependencies import Language.PureScript.Names import Language.PureScript.Renamer @@ -125,7 +126,8 @@ make ma@MakeActions{..} ms = do results <- BuildPlan.collectResults buildPlan -- All threads have completed, rethrow any caught errors. - let errors = mapMaybe buildJobFailure $ M.elems results + let errors = decorateSuggestions (M.elems results) $ mapMaybe buildJobFailure $ M.elems results + unless (null errors) $ throwError (mconcat errors) -- Here we return all the ExternsFile in the ordering of the topological sort, diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index fcf7f469d3..2e199b55a0 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -419,11 +419,11 @@ renameInModule imports (Module modSS coms mn decls exps) = (Nothing, Just mn'') -> if mn'' `S.member` importedQualModules imports || mn'' `S.member` importedModules imports then throwUnknown - else throwError . errorMessage . UnknownName . Qualified Nothing $ ModName mn'' + else throwError . errorMessage . UnknownName [] . Qualified Nothing $ ModName mn'' -- If neither of the above cases are true then it's an undefined or -- unimported symbol. _ -> throwUnknown where - throwUnknown = throwError . errorMessage . UnknownName . fmap toName $ qname + throwUnknown = throwError . errorMessage . UnknownName [] . fmap toName $ qname diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index 31a109ba0e..594b9ee927 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -485,7 +485,7 @@ throwExportConflict' ss new existing newName existingName = getExports :: MonadError MultipleErrors m => Env -> ModuleName -> m Exports getExports env mn = maybe - (throwError . errorMessage . UnknownName . Qualified Nothing $ ModName mn) + (throwError . errorMessage . UnknownName [] . Qualified Nothing $ ModName mn) (return . envModuleExports) $ M.lookup mn env diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index 4253709055..46dd3968a7 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -70,7 +70,7 @@ resolveModuleImport env ie (mn, imps) = foldM go ie imps go ie' (ss, typ, impQual) = do modExports <- maybe - (throwError . errorMessage' ss . UnknownName . Qualified Nothing $ ModName mn) + (throwError . errorMessage' ss . UnknownName [] . Qualified Nothing $ ModName mn) (return . envModuleExports) (mn `M.lookup` env) let impModules = importedModules ie' diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 1d0bb8aec4..19018de262 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -149,7 +149,7 @@ rebracketFiltered pred_ externs modules = do Just (Qualified mn' (Right alias)) -> return $ Constructor pos (Qualified mn' alias) Nothing -> - throwError . errorMessage' pos . UnknownName $ fmap ValOpName op + throwError . errorMessage' pos . UnknownName [] $ fmap ValOpName op goExpr pos other = return (pos, other) goBinder :: SourceSpan -> Binder -> m (SourceSpan, Binder) @@ -161,7 +161,7 @@ rebracketFiltered pred_ externs modules = do Just (Qualified mn' (Right alias)) -> return (pos, ConstructorBinder pos (Qualified mn' alias) [lhs, rhs]) Nothing -> - throwError . errorMessage' pos . UnknownName $ fmap ValOpName op + throwError . errorMessage' pos . UnknownName [] $ fmap ValOpName op goBinder _ BinaryNoParensBinder{} = internalError "BinaryNoParensBinder has no OpBinder" goBinder pos other = return (pos, other) @@ -172,7 +172,7 @@ rebracketFiltered pred_ externs modules = do Just alias -> return $ TypeApp ann (TypeApp ann (TypeConstructor ann2 alias) lhs) rhs Nothing -> - throwError . errorMessage' pos $ UnknownName $ fmap TyOpName op + throwError . errorMessage' pos $ UnknownName [] $ fmap TyOpName op goType _ other = return other rebracketModule diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 761de6f631..4ed71411b6 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -303,7 +303,7 @@ typeInstanceDictionaryDeclaration sa@(ss, _) name mn deps className tys decls = -- Lookup the type arguments and member types for the type class TypeClassData{..} <- - maybe (throwError . errorMessage' ss . UnknownName $ fmap TyClassName className) return $ + maybe (throwError . errorMessage' ss . UnknownName [] $ fmap TyClassName className) return $ M.lookup (qualify mn className) m -- Replace the type arguments with the appropriate types in the member types diff --git a/src/Language/PureScript/Suggest.hs b/src/Language/PureScript/Suggest.hs new file mode 100644 index 0000000000..e84393921d --- /dev/null +++ b/src/Language/PureScript/Suggest.hs @@ -0,0 +1,36 @@ +-- | +-- This module implements a simple linting pass on the PureScript AST. +-- +module Language.PureScript.Suggest where + +import Prelude.Compat + +import Data.Maybe (catMaybes) + +import Language.PureScript.Make.BuildPlan +import Language.PureScript.Errors +import Language.PureScript.Externs +import Language.PureScript.Names + + +decorateSuggestions :: [BuildJobResult] -> [MultipleErrors] -> [MultipleErrors] +decorateSuggestions jobs multipleErrors = decorateMultipleErrors <$> multipleErrors + where + compiledExterns :: [ExternsFile] + compiledExterns = snd <$> (catMaybes $ buildJobSuccess <$> jobs) + + decorateMultipleErrors :: MultipleErrors -> MultipleErrors + decorateMultipleErrors (MultipleErrors errs) = MultipleErrors $ decorateErrorMessage <$> errs + + decorateErrorMessage :: ErrorMessage -> ErrorMessage + decorateErrorMessage (ErrorMessage hints err) = ErrorMessage hints (suggestionForSimpleError err) + + suggestionForSimpleError :: SimpleErrorMessage -> SimpleErrorMessage + suggestionForSimpleError (UnknownName imports qualName@(Qualified Nothing name)) = UnknownName (imports ++ findImportForName name) qualName + suggestionForSimpleError others = others + + findImportForName :: Name -> [(ModuleName, DeclarationRef)] + findImportForName name = + filter ((==name) . declRefName . snd) + $ concat + $ (\extern -> (\decl -> (efModuleName extern, decl)) <$> efExports extern) <$> compiledExterns \ No newline at end of file diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 28a4009b52..6fe00611ba 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -251,7 +251,7 @@ infer' other = (, []) <$> go other go (TypeConstructor ann v) = do env <- getEnv case M.lookup v (types env) of - Nothing -> throwError . errorMessage' (fst ann) . UnknownName $ fmap TyName v + Nothing -> throwError . errorMessage' (fst ann) . UnknownName [] $ fmap TyName v Just (kind, _) -> return $ kind $> ann go (TypeApp ann t1 t2) = do k0 <- freshKind ann diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index e4491359f2..e85891e051 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -387,7 +387,7 @@ infer' (Var ss var) = do infer' v@(Constructor _ c) = do env <- getEnv case M.lookup c (dataConstructors env) of - Nothing -> throwError . errorMessage . UnknownName . fmap DctorName $ c + Nothing -> throwError . errorMessage . UnknownName [] . fmap DctorName $ c Just (_, _, ty, _) -> do (v', ty') <- sndM (introduceSkolemScope <=< replaceAllTypeSynonyms) <=< instantiatePolyTypeWithUnknowns v $ ty return $ TypedValue' True v' ty' infer' (Case vals binders) = do @@ -495,7 +495,7 @@ inferBinder val (ConstructorBinder ss ctor binders) = do unless (expected == actual) . throwError . errorMessage' ss $ IncorrectConstructorArity ctor expected actual unifyTypes ret val M.unions <$> zipWithM inferBinder (reverse args) binders - _ -> throwError . errorMessage' ss . UnknownName . fmap DctorName $ ctor + _ -> throwError . errorMessage' ss . UnknownName [] . fmap DctorName $ ctor where peelArgs :: Type a -> ([Type a], Type a) peelArgs = go [] @@ -731,7 +731,7 @@ check' (Accessor prop val) ty = withErrorMessageHint (ErrorCheckingAccessor val check' v@(Constructor _ c) ty = do env <- getEnv case M.lookup c (dataConstructors env) of - Nothing -> throwError . errorMessage . UnknownName . fmap DctorName $ c + Nothing -> throwError . errorMessage . UnknownName [] . fmap DctorName $ c Just (_, _, ty1, _) -> do repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1 ty' <- introduceSkolemScope ty